diff --git a/fortitude.toml b/fortitude.toml new file mode 100644 index 000000000..f3f158533 --- /dev/null +++ b/fortitude.toml @@ -0,0 +1,10 @@ +[check] +preview = true +select = ["C", "E", "S", "MOD", "OB"] +# ignore = [] +file-extensions = ["f90", "F90"] +line-length = 78 +fix = false +# output-format = "full" +# show-fixes = false +# unsafe-fixes = true diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 index 7e424ed84..4afe02b7f 100644 --- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 +++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 @@ -40,26 +40,15 @@ MODULE BaseInterpolation_Method PUBLIC :: BaseInterpolation_FromInteger PUBLIC :: BaseInterpolation_FromString PUBLIC :: BaseInterpolationPointer_FromString -PUBLIC :: BaseType_ToInteger - PUBLIC :: BaseInterpolation_ToString -PUBLIC :: BaseType_ToChar PUBLIC :: BaseInterpolation_ToChar -INTERFACE BaseInterpolation_ToInteger - MODULE PROCEDURE BaseInterpolation_ToInteger1 - MODULE PROCEDURE BaseInterpolation_ToInteger2 -END INTERFACE BaseInterpolation_ToInteger - -INTERFACE BaseType_ToInteger - MODULE PROCEDURE BaseInterpolation_ToInteger1 - MODULE PROCEDURE BaseType_ToInteger1 -END INTERFACE BaseType_ToInteger +PUBLIC :: BaseType_ToChar +PUBLIC :: BaseType_ToInteger -INTERFACE BaseInterpolation_ToString - MODULE PROCEDURE BaseInterpolation_ToString1 - MODULE PROCEDURE BaseInterpolation_ToString2 -END INTERFACE BaseInterpolation_ToString +PUBLIC :: InterpolationPoint_ToChar +PUBLIC :: InterpolationPoint_ToString +PUBLIC :: InterpolationPoint_ToInteger INTERFACE ASSIGNMENT(=) MODULE PROCEDURE BaseInterpolation_Copy @@ -137,7 +126,7 @@ END SUBROUTINE BaseInterpolation_Copy ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) +FUNCTION BaseInterpolation_ToInteger(obj) RESULT(ans) CLASS(BaseInterpolation_), INTENT(IN) :: obj INTEGER(I4B) :: ans @@ -159,19 +148,19 @@ FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans) CLASS DEFAULT CALL ErrorMsg(msg="NO CASE FOUND for type of obj2", & - routine="BaseInterpolation_toInteger()", & + routine="BaseInterpolation_ToInteger()", & line=__LINE__, unitno=stdout, file=__FILE__) STOP END SELECT -END FUNCTION BaseInterpolation_ToInteger1 +END FUNCTION BaseInterpolation_ToInteger !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -FUNCTION BaseType_ToInteger1(name) RESULT(ans) +FUNCTION BaseType_ToInteger(name) RESULT(ans) CHARACTER(*), INTENT(IN) :: name INTEGER(I4B) :: ans @@ -212,12 +201,12 @@ FUNCTION BaseType_ToInteger1(name) RESULT(ans) CASE DEFAULT CALL ErrorMsg(msg="NO CASE FOUND for name: "//astr, & - routine="BaseType_ToInteger1()", & + routine="BaseType_ToInteger()", & line=__LINE__, unitno=stdout, file=__FILE__) STOP END SELECT -END FUNCTION BaseType_ToInteger1 +END FUNCTION BaseType_ToInteger !---------------------------------------------------------------------------- ! BaseInterpolation_toInteger @@ -227,7 +216,7 @@ END FUNCTION BaseType_ToInteger1 ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) +FUNCTION InterpolationPoint_ToInteger(name) RESULT(ans) CHARACTER(*), INTENT(IN) :: name INTEGER(I4B) :: ans @@ -310,7 +299,7 @@ FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans) END SELECT astr = "" -END FUNCTION BaseInterpolation_ToInteger2 +END FUNCTION InterpolationPoint_ToInteger !---------------------------------------------------------------------------- ! BaseInterpolation_fromInteger @@ -401,10 +390,21 @@ END SUBROUTINE BaseInterpolation_FromString ! date: 2023-08-09 ! summary: Returns a string name of base interpolation type -FUNCTION BaseInterpolation_ToString1(obj, isUpper) RESULT(ans) +FUNCTION BaseInterpolation_ToString(obj, isUpper) RESULT(ans) CLASS(BaseInterpolation_), INTENT(IN) :: obj LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper TYPE(String) :: ans + ans = BaseInterpolation_ToChar(obj=obj, isUpper=isUpper) +END FUNCTION BaseInterpolation_ToString + +!---------------------------------------------------------------------------- +! BaseInterpolation_ToChar +!---------------------------------------------------------------------------- + +FUNCTION BaseInterpolation_ToChar(obj, isUpper) RESULT(ans) + CLASS(BaseInterpolation_), INTENT(IN) :: obj + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper + CHARACTER(:), ALLOCATABLE :: ans ! internal variables LOGICAL(LGT) :: isUpper0 @@ -449,13 +449,14 @@ FUNCTION BaseInterpolation_ToString1(obj, isUpper) RESULT(ans) END IF CLASS DEFAULT + ans = "" CALL ErrorMsg(msg="No Case Found For Type of obj2", & - routine="BaseInterpolation_ToString1()", & + routine="BaseInterpolation_ToString()", & line=__LINE__, unitno=stdout, file=__FILE__) STOP END SELECT -END FUNCTION BaseInterpolation_ToString1 +END FUNCTION BaseInterpolation_ToChar !---------------------------------------------------------------------------- ! BaseType_ToChar @@ -556,18 +557,18 @@ END FUNCTION BaseType_ToChar ! QuadraturePointIDToName !---------------------------------------------------------------------------- -FUNCTION BaseInterpolation_ToString2(name, isUpper) RESULT(ans) +FUNCTION InterpolationPoint_ToString(name, isUpper) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper TYPE(String) :: ans - ans = BaseInterpolation_ToChar(name=name, isUpper=isUpper) -END FUNCTION BaseInterpolation_ToString2 + ans = InterpolationPoint_ToChar(name=name, isUpper=isUpper) +END FUNCTION InterpolationPoint_ToString !---------------------------------------------------------------------------- ! BaseInterpolation_ToChar !---------------------------------------------------------------------------- -FUNCTION BaseInterpolation_ToChar(name, isUpper) RESULT(ans) +FUNCTION InterpolationPoint_ToChar(name, isUpper) RESULT(ans) INTEGER(I4B), INTENT(IN) :: name LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper CHARACTER(:), ALLOCATABLE :: ans @@ -734,7 +735,7 @@ FUNCTION BaseInterpolation_ToChar(name, isUpper) RESULT(ans) STOP END SELECT -END FUNCTION BaseInterpolation_ToChar +END FUNCTION InterpolationPoint_ToChar !---------------------------------------------------------------------------- ! diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90 index 61ddc1fa1..a46ddded8 100644 --- a/src/modules/BaseType/src/BaseType.F90 +++ b/src/modules/BaseType/src/BaseType.F90 @@ -20,16 +20,78 @@ ! [[BaseType]] module contains several userful user defined data types. MODULE BaseType -USE GlobalData +USE GlobalData, ONLY: Monomial, LagrangePolynomial, SerendipityPolynomial, & + HierarchicalPolynomial, OrthogonalPolynomial, & + JacobiPolynomial, LegendrePolynomial, & + ChebyshevPolynomial, LobattoPolynomial, & + UnscaledLobattoPolynomial, HermitPolynomial, & + UltrasphericalPolynomial + +USE GlobalData, ONLY: I4B, LGT, DFP, DFPC + +USE GlobalData, ONLY: FMT_NODES, FMT_DOF + +USE GlobalData, ONLY: RelativeConvergence, ConvergenceInRes, & + ConvergenceInSol, ConvergenceInResSol, & + AbsoluteConvergence, NormL2, & + StressTypeVoigt, OMP_THREADS_JOINED + +USE GlobalData, ONLY: Equidistance, EquidistanceQP, GaussQP, & + GaussLegendreQP, GaussLegendreLobattoQP, & + GaussLegendreRadau, GaussLegendreRadauLeft, & + GaussLegendreRadauRight, GaussRadauQP, & + GaussRadauLeftQP, GaussRadauRightQP, & + GaussLobattoQP, GaussChebyshevQP, & + GaussChebyshevLobattoQP, GaussChebyshevRadau, & + GaussChebyshevRadauLeft, GaussChebyshevRadauRight, & + GaussJacobiQP, GaussJacobiLobattoQP, & + GaussJacobiRadau, GaussJacobiRadauLeft, & + GaussJacobiRadauRight, GaussUltraSphericalQP, & + GaussUltraSphericalLobattoQP, & + GaussUltraSphericalRadau, & + GaussUltraSphericalRadauLeft, & + GaussUltraSphericalRadauRight, & + ChenBabuskaQP, HesthavenQP, & + FeketQP, BlythPozLegendreQP, & + BlythPozChebyshevQP, IsaacLegendreQP, IsaacChebyshevQP + +USE GlobalData, ONLY: NO_PRECONDITION, LEFT_PRECONDITION, & + RIGHT_PRECONDITION, LEFT_RIGHT_PRECONDITION, & + PRECOND_JACOBI, PRECOND_ILU, PRECOND_SSOR, & + PRECOND_HYBRID, PRECOND_IS, PRECOND_SAINV, & + PRECOND_SAAMG, PRECOND_ILUC, PRECOND_ADDS, & + PRECOND_ILUTP, PRECOND_ILUD, PRECOND_ILUDP, & + PRECOND_ILU0, PRECOND_ILUK, PRECOND_ILUT + +USE GlobalData, ONLY: LIS_CG, LIS_BCG, LIS_BICG, LIS_CGS, LIS_BCGSTAB, & + LIS_BICGSTAB, LIS_BICGSTABL, LIS_GPBICG, LIS_TFQMR, & + LIS_OMN, LIS_FOM, LIS_ORTHOMIN, LIS_GMRES, LIS_GMR, & + LIS_JACOBI, LIS_GS, LIS_SOR, LIS_BICGSAFE, LIS_CR, & + LIS_BICR, LIS_CRS, LIS_BICRSTAB, LIS_GPBICR, & + LIS_BICRSAFE, LIS_FGMRES, LIS_IDRS, LIS_IDR1, & + LIS_MINRES, LIS_COCG, LIS_COCR, LIS_CGNR, LIS_CGN, & + LIS_DBCG, LIS_DBICG, LIS_DQGMRES, LIS_SUPERLU + +USE GlobalData, ONLY: Scalar, Vector, Matrix, Nodal, Quadrature, & + Constant, Space, Time, Spacetime, & + SolutionDependent, RandomSpace + +USE GlobalData, ONLY: Point, Line, Triangle, & + Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, & + Quadrangle16, & + Tetrahedron, Hexahedron, Prism, Pyramid + USE String_Class, ONLY: String + #ifdef USE_SuperLU USE SuperLUInterface USE ISO_C_BINDING, ONLY: C_CHAR, C_PTR, C_SIZE_T #endif + IMPLICIT NONE PRIVATE -PUBLIC :: Math +PUBLIC :: TypeMathOpt PUBLIC :: BoundingBox_ PUBLIC :: TypeBoundingBox PUBLIC :: BoundingBoxPointer_ @@ -159,6 +221,7 @@ MODULE BaseType PUBLIC :: DG_ PUBLIC :: TypeDG PUBLIC :: DEL_NONE, DEL_X, DEL_Y, DEL_Z, DEL_X_ALL, DEL_t +PUBLIC :: DerivativeTerm_, TypeDerivativeTerm PUBLIC :: ElementData_ PUBLIC :: TypeElementData PUBLIC :: ElementDataPointer_ @@ -201,29 +264,39 @@ MODULE BaseType INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6 !---------------------------------------------------------------------------- -! Math_ +! MathOpt_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 5 March 2022 ! summary: Math class -TYPE :: Math_ - REAL(DFP) :: PI = 3.14159265359_DFP +TYPE :: MathOpt_ + REAL(DFP) :: zero = 0.0_DFP + REAL(DFP) :: half = 0.5_DFP + REAL(DFP) :: one = 1.0_DFP + REAL(DFP) :: two = 2.0_DFP + REAL(DFP) :: pi = 3.14159265359_DFP REAL(DFP) :: e = 2.718281828459045_DFP + REAL(DFP), DIMENSION(3, 3) :: eye3 = RESHAPE([ & + 1.0_DFP, 0.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP, 0.0_DFP, & + 0.0_DFP, 0.0_DFP, 1.0_DFP], & + [3, 3]) + REAL(DFP), DIMENSION(2, 2) :: eye2 = RESHAPE([ & + 1.0_DFP, 0.0_DFP, & + 0.0_DFP, 1.0_DFP], & + [2, 2]) COMPLEX(DFPC) :: i = (0.0_DFP, 1.0_DFP) COMPLEX(DFPC) :: j = (0.0_DFP, 1.0_DFP) - REAL(DFP), DIMENSION(3, 3) :: Eye3 = RESHAPE([ & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, & - & 0.0_DFP, 1.0_DFP, 0.0_DFP, & - & 0.0_DFP, 0.0_DFP, 1.0_DFP], & - & [3, 3]) - REAL(DFP), DIMENSION(2, 2) :: Eye2 = RESHAPE([ & - & 1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP], & - & [2, 2]) -END TYPE Math_ + LOGICAL(LGT) :: yes = .TRUE. + LOGICAL(LGT) :: no = .FALSE. + INTEGER(I4B) :: zero_i = 0_I4B + INTEGER(I4B) :: one_i = 1_I4B + INTEGER(I4B) :: two_i = 2_I4B +END TYPE MathOpt_ -TYPE(Math_), PARAMETER :: Math = Math_() +TYPE(MathOpt_), PARAMETER :: TypeMathOpt = MathOpt_() !---------------------------------------------------------------------------- ! BoundingBox_ @@ -278,11 +351,11 @@ MODULE BaseType TYPE :: RealMatrix_ INTEGER(I4B) :: tDimension = 0_I4B - CHARACTER(5) :: MatrixProp = 'UNSYM' - REAL(DFP), ALLOCATABLE :: Val(:, :) + CHARACTER(5) :: matrixProp = 'UNSYM' + REAL(DFP), ALLOCATABLE :: val(:, :) END TYPE RealMatrix_ -TYPE(RealMatrix_), PARAMETER :: TypeRealMatrix = RealMatrix_(Val=NULL()) +TYPE(RealMatrix_), PARAMETER :: TypeRealMatrix = RealMatrix_(val=NULL()) TYPE :: RealMatrixPointer_ CLASS(RealMatrix_), POINTER :: ptr => NULL() @@ -300,10 +373,10 @@ MODULE BaseType TYPE :: IntVector_ INTEGER(I4B) :: tDimension = 1_I4B - INTEGER(I4B), ALLOCATABLE :: Val(:) + INTEGER(I4B), ALLOCATABLE :: val(:) END TYPE IntVector_ -TYPE(IntVector_), PARAMETER :: TypeIntVector = IntVector_(Val=NULL()) +TYPE(IntVector_), PARAMETER :: TypeIntVector = IntVector_(val=NULL()) TYPE :: IntVectorPointer_ CLASS(IntVector_), POINTER :: ptr => NULL() @@ -529,8 +602,8 @@ MODULE BaseType #endif END TYPE CSRMatrix_ -TYPE(CSRMatrix_), PARAMETER :: TypeCSRMatrix = CSRMatrix_(& - & A=NULL(), slu=NULL()) +TYPE(CSRMatrix_), PARAMETER :: TypeCSRMatrix = CSRMatrix_( & + A=NULL(), slu=NULL()) TYPE :: CSRMatrixPointer_ CLASS(CSRMatrix_), POINTER :: ptr => NULL() @@ -1038,26 +1111,38 @@ END SUBROUTINE highorder_refelem ! {!pages/FEVariable_.md!} TYPE :: FEVariable_ - REAL(DFP), ALLOCATABLE :: val(:) - !! values + LOGICAL(LGT) :: isInit = .FALSE. + !! True if it is initiated INTEGER(I4B) :: s(MAX_RANK_FEVARIABLE) = 0 !! shape of the data + INTEGER(I4B) :: tshape = 0 + !! Total shape of the data. + !! Following values are set based on rank and varType + !! Scalar, constant: 1 + !! Scalar, space: 1 + !! Scalar, time: 1 + !! Scalar, spaceTime: 2 + !! Vector, constant: 1 + !! Vector, space: 2 + !! Vector, time: 3 + !! Vector, spaceTime: 3 + !! Matrix, constant: 2 + !! Matrix, space: 3 + !! Matrix, time: 3 + !! Matrix, spaceTime: 4 INTEGER(I4B) :: defineOn = 0 !! Nodal: nodal values !! Quadrature: quadrature values INTEGER(I4B) :: varType = 0 - !! Space - !! Time - !! SpaceTime - !! Constant + !! Space ! Time ! SpaceTime ! Constant INTEGER(I4B) :: rank = 0 - !! Scalar - !! Vector - !! Matrix + !! Scalar ! Vector ! Matrix INTEGER(I4B) :: len = 0_I4B !! current total size INTEGER(I4B) :: capacity = 0_I4B !! capacity of the val + REAL(DFP), ALLOCATABLE :: val(:) + !! values END TYPE FEVariable_ TYPE(FEVariable_), PARAMETER :: TypeFEVariable = FEVariable_(val=NULL()) @@ -1094,10 +1179,8 @@ END SUBROUTINE highorder_refelem !! INTEGER(I4B):: Val = 2 END TYPE FEVariableSpace_ -TYPE(FEVariableSpace_), PARAMETER :: TypeFEVariableSpace = & - & FEVariableSpace_() -TYPE(FEVariableSpace_), PARAMETER :: TypeVariableSpace = & - & FEVariableSpace_() +TYPE(FEVariableSpace_), PARAMETER :: TypeFEVariableSpace = FEVariableSpace_() +TYPE(FEVariableSpace_), PARAMETER :: TypeVariableSpace = FEVariableSpace_() !---------------------------------------------------------------------------- ! FEVariableSpaceTime_ @@ -1205,8 +1288,8 @@ END SUBROUTINE highorder_refelem INTEGER(I4B) :: txi = 0 END TYPE QuadraturePoint_ -TYPE(QuadraturePoint_), PARAMETER :: TypeQuadraturePoint & - & = QuadraturePoint_(points=NULL()) +TYPE(QuadraturePoint_), PARAMETER :: TypeQuadraturePoint = & + QuadraturePoint_(points=NULL()) TYPE :: QuadraturePointPointer_ CLASS(QuadraturePoint_), POINTER :: ptr => NULL() @@ -1364,6 +1447,21 @@ END SUBROUTINE highorder_refelem INTEGER(I4B), PARAMETER :: DEL_X_ALL = 4 INTEGER(I4B), PARAMETER :: DEL_t = -1 +!---------------------------------------------------------------------------- +! DerivativeTerm_ +!---------------------------------------------------------------------------- + +TYPE :: DerivativeTerm_ + INTEGER(I4B) :: NONE = 0 + INTEGER(I4B) :: x = 1 + INTEGER(I4B) :: y = 2 + INTEGER(I4B) :: z = 3 + INTEGER(I4B) :: xAll = 4 + INTEGER(I4B) :: t = -1 +END TYPE DerivativeTerm_ + +TYPE(DerivativeTerm_), PARAMETER :: TypeDerivativeTerm = DerivativeTerm_() + !---------------------------------------------------------------------------- ! ElementData_ !---------------------------------------------------------------------------- @@ -1477,7 +1575,7 @@ END SUBROUTINE highorder_refelem REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :) !! Local derivative of a shape function !! shape = nns, xidim, nips - !! dim 1 = number of nodes in element + !! dim 1 = number of nodes in element !! dim 2 = xi dimension (xi, eta, zeta) !! dim 3 = number of integration points REAL(DFP), ALLOCATABLE :: jacobian(:, :, :) @@ -1859,6 +1957,9 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: line = Line INTEGER(I4B) :: triangle = Triangle INTEGER(I4B) :: quadrangle = Quadrangle + INTEGER(I4B) :: quadrangle8 = Quadrangle8 + INTEGER(I4B) :: quadrangle9 = Quadrangle9 + INTEGER(I4B) :: quadrangle16 = Quadrangle16 INTEGER(I4B) :: tetrahedron = Tetrahedron INTEGER(I4B) :: hexahedron = Hexahedron INTEGER(I4B) :: prism = Prism @@ -1884,6 +1985,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: unscaledLobatto = UnscaledLobattoPolynomial INTEGER(I4B) :: hermit = HermitPolynomial INTEGER(I4B) :: ultraspherical = UltrasphericalPolynomial + INTEGER(I4B) :: default = Monomial END TYPE PolynomialOpt_ TYPE(PolynomialOpt_), PARAMETER :: TypePolynomialOpt = PolynomialOpt_() @@ -1893,7 +1995,7 @@ END FUNCTION iface_MatrixFunction !---------------------------------------------------------------------------- TYPE :: QuadratureOpt_ - INTEGER(I4B) :: equidistance = EquidistanceQP + INTEGER(I4B) :: Equidistance = EquidistanceQP INTEGER(I4B) :: Gauss = GaussQP INTEGER(I4B) :: GaussLegendre = GaussLegendreQP INTEGER(I4B) :: GaussLegendreLobatto = GaussLegendreLobattoQP @@ -1927,6 +2029,7 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: BlythPozChebyshev = BlythPozChebyshevQP INTEGER(I4B) :: IsaacLegendre = IsaacLegendreQP INTEGER(I4B) :: IsaacChebyshev = IsaacChebyshevQP + INTEGER(I4B) :: default = GaussLegendreQP END TYPE QuadratureOpt_ TYPE(QuadratureOpt_), PARAMETER :: TypeQuadratureOpt = QuadratureOpt_() @@ -1948,6 +2051,10 @@ END FUNCTION iface_MatrixFunction INTEGER(I4B) :: spacetime = spacetime INTEGER(I4B) :: solutionDependent = solutionDependent INTEGER(I4B) :: randomSpace = randomSpace + INTEGER(I4B) :: maxRank = MAX_RANK_FEVARIABLE + INTEGER(I4B) :: capacityExpandFactor = 1 + INTEGER(I4B) :: defaultVectorSize = 3 + INTEGER(I4B) :: defaultMatrixSize = 3 END TYPE FEVariableOpt_ TYPE(FEVariableOpt_), PARAMETER :: TypeFEVariableOpt = FEVariableOpt_() diff --git a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 index aa0dd389b..dd8cabe7e 100644 --- a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 +++ b/src/modules/BeFoR64/src/befor64_pack_data_m.F90 @@ -57,13 +57,16 @@ MODULE befor64_pack_data_m !<... ! main + INTEGER(I1P), ALLOCATABLE :: p1(:) + INTEGER(I1P), ALLOCATABLE :: p2(:) + p1 = TRANSFER(a1, p1) + p2 = TRANSFER(a2, p2) + packed = [p1, p2] +END SUBROUTINE pack_data_I4_I4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- endmodule befor64_pack_data_m diff --git a/src/modules/BoundingBox/src/BoundingBox_Method.F90 b/src/modules/BoundingBox/src/BoundingBox_Method.F90 index 0df44a5c4..80a1eb43e 100644 --- a/src/modules/BoundingBox/src/BoundingBox_Method.F90 +++ b/src/modules/BoundingBox/src/BoundingBox_Method.F90 @@ -30,25 +30,27 @@ MODULE BoundingBox_Method USE tomlf, ONLY: toml_table IMPLICIT NONE -PUBLIC :: OPERATOR(.Xmin.) +PUBLIC :: OPERATOR(.Center.) +PUBLIC :: OPERATOR(.Intersection.) +PUBLIC :: OPERATOR(.Nptrs.) +PUBLIC :: OPERATOR(.UNION.) PUBLIC :: OPERATOR(.Xmax.) -PUBLIC :: OPERATOR(.Ymin.) +PUBLIC :: OPERATOR(.Xmin.) PUBLIC :: OPERATOR(.Ymax.) -PUBLIC :: OPERATOR(.Zmin.) +PUBLIC :: OPERATOR(.Ymin.) PUBLIC :: OPERATOR(.Zmax.) -PUBLIC :: OPERATOR(.isIntersect.) -PUBLIC :: OPERATOR(.Intersection.) -PUBLIC :: OPERATOR(.UNION.) -PUBLIC :: OPERATOR(.Center.) +PUBLIC :: OPERATOR(.Zmin.) PUBLIC :: OPERATOR(.isInside.) -PUBLIC :: OPERATOR(.Nptrs.) +PUBLIC :: OPERATOR(.isIntersect.) PUBLIC :: ASSIGNMENT(=) PUBLIC :: Initiate +PUBLIC :: Copy PUBLIC :: BoundingBox PUBLIC :: BoundingBox_Pointer PUBLIC :: DEALLOCATE +PUBLIC :: Reallocate PUBLIC :: Display PUBLIC :: isIntersectInX @@ -146,6 +148,10 @@ END SUBROUTINE Initiate_2 MODULE PROCEDURE Initiate_2 END INTERFACE +INTERFACE Copy + MODULE PROCEDURE Initiate_2 +END INTERFACE Copy + !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -165,6 +171,10 @@ END SUBROUTINE Initiate_3 MODULE PROCEDURE Initiate_3 END INTERFACE +INTERFACE Copy + MODULE PROCEDURE Initiate_3 +END INTERFACE Copy + !---------------------------------------------------------------------------- ! Append@ConstructorMethods !---------------------------------------------------------------------------- @@ -358,7 +368,7 @@ END SUBROUTINE BB_Deallocate END INTERFACE DEALLOCATE !---------------------------------------------------------------------------- -! Deallocate@Constructor +! Deallocate@Constructor !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -371,6 +381,21 @@ MODULE PURE SUBROUTINE BB_Deallocate2(obj) END SUBROUTINE BB_Deallocate2 END INTERFACE DEALLOCATE +!---------------------------------------------------------------------------- +! Reallocate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-07-25 +! summary: Reallocate the bounding box if necessary + +INTERFACE Reallocate + MODULE PURE SUBROUTINE obj_Reallocate(obj, tsize) + TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: obj(:) + INTEGER(I4B), INTENT(IN) :: tsize + END SUBROUTINE obj_Reallocate +END INTERFACE Reallocate + !---------------------------------------------------------------------------- ! Display@Constructor !---------------------------------------------------------------------------- diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt index 396c467c6..073cd78ae 100644 --- a/src/modules/CMakeLists.txt +++ b/src/modules/CMakeLists.txt @@ -60,8 +60,7 @@ include(${CMAKE_CURRENT_LIST_DIR}/ARPACK/CMakeLists.txt) # Hashing include(${CMAKE_CURRENT_LIST_DIR}/Hashing/CMakeLists.txt) -# Gnuplot -# include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt) +# Gnuplot include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt) # CInterface include(${CMAKE_CURRENT_LIST_DIR}/CInterface/CMakeLists.txt) @@ -96,6 +95,30 @@ include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt) # BaseContinuity include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt) +# Point +include(${CMAKE_CURRENT_LIST_DIR}/Point/CMakeLists.txt) + +# Line +include(${CMAKE_CURRENT_LIST_DIR}/Line/CMakeLists.txt) + +# Triangle +include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt) + +# Quadrangle +include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt) + +# Tetrahedron +include(${CMAKE_CURRENT_LIST_DIR}/Tetrahedron/CMakeLists.txt) + +# Hexahedron +include(${CMAKE_CURRENT_LIST_DIR}/Hexahedron/CMakeLists.txt) + +# Prism +include(${CMAKE_CURRENT_LIST_DIR}/Prism/CMakeLists.txt) + +# Pyramid +include(${CMAKE_CURRENT_LIST_DIR}/Pyramid/CMakeLists.txt) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) @@ -192,6 +215,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt) # FEVector include(${CMAKE_CURRENT_LIST_DIR}/FEVector/CMakeLists.txt) +# Projection +include(${CMAKE_CURRENT_LIST_DIR}/Projection/CMakeLists.txt) + # VoigtRank2Tensor include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt) diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 index 245733347..8a98e7b39 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 @@ -20,7 +20,48 @@ MODULE CSRMatrix_AddMethods IMPLICIT NONE PRIVATE -PUBLIC :: Add +PUBLIC :: Add, Add_ +PUBLIC :: AddToSTMatrix + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 Marach 2021 +! summary: This subroutine Add contribution + +INTERFACE AddMaster + MODULE PURE SUBROUTINE AddMaster1(obj, row, col, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row(:), col(:) + !! Node numbers + REAL(DFP), INTENT(IN) :: VALUE(:, :) + !! Element finite element matrix + REAL(DFP), INTENT(IN) :: scale + !! Scale is used to scale the Val before Adding it to the obj + END SUBROUTINE AddMaster1 +END INTERFACE AddMaster + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 Marach 2021 +! summary: This subroutine Add contribution + +INTERFACE AddMaster + MODULE PURE SUBROUTINE AddMaster2(obj, row, col, VALUE, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: row(:), col(:) + !! Node numbers + REAL(DFP), INTENT(IN) :: VALUE + !! Element finite element matrix + REAL(DFP), INTENT(IN) :: scale + !! Scale is used to scale the Val before Adding it to the obj + END SUBROUTINE AddMaster2 +END INTERFACE AddMaster !---------------------------------------------------------------------------- ! Add@addMethod @@ -50,6 +91,33 @@ END SUBROUTINE obj_Add0 ! date: 22 Marach 2021 ! summary: This subroutine Add contribution +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_0(obj, nodenum, VALUE, scale, row, col, & + nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! Node numbers + REAL(DFP), INTENT(IN) :: VALUE(:, :) + !! Element finite element matrix + REAL(DFP), INTENT(IN) :: scale + !! Scale is used to scale the Val before Adding it to the obj + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + !! needed for internal working + !! size of row should be .tdof. obj%csr%idof * size(nodenum) + !! size of col should be .tdof. obj%csr%jdof * size(nodenum) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! data written in row and col + END SUBROUTINE obj_Add_0 +END INTERFACE Add_ + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 Marach 2021 +! summary: This subroutine Add contribution + INTERFACE Add MODULE PURE SUBROUTINE obj_Add1(obj, nodenum, VALUE, scale, storageFMT) TYPE(CSRMatrix_), INTENT(INOUT) :: obj @@ -68,6 +136,38 @@ END SUBROUTINE obj_Add1 ! Add@addMethod !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 22 Marach 2021 +! summary: This subroutine Add contribution + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_1( & + obj, nodenum, VALUE, scale, storageFMT, m2, m2_nrow, m2_ncol, row, & + col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + !! Node numbers + REAL(DFP), INTENT(IN) :: VALUE(:, :) + !! Element finite element matrix + REAL(DFP), INTENT(IN) :: scale + !! Scale is used to scale the Val before Adding it to the obj + INTEGER(I4B), INTENT(IN) :: storageFMT + !! Storage format of element finite matrix + REAL(DFP), INTENT(INOUT) :: m2(:, :) + !! need for internal working + !! Size should at least enough to hold value + INTEGER(I4B), INTENT(OUT) :: m2_nrow, m2_ncol + !! size of m2 + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + !! needed for internal working + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_1 +END INTERFACE Add_ + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 ! summary: Adds all values of sparse matrix to given scalar value @@ -84,6 +184,10 @@ MODULE PURE SUBROUTINE obj_Add2(obj, VALUE, scale) END SUBROUTINE obj_Add2 END INTERFACE Add +INTERFACE Add_ + MODULE PROCEDURE obj_Add2 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -110,6 +214,10 @@ MODULE PURE SUBROUTINE obj_Add3(obj, irow, icolumn, VALUE, scale) END SUBROUTINE obj_Add3 END INTERFACE Add +INTERFACE Add_ + MODULE PROCEDURE obj_Add3 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -128,7 +236,7 @@ END SUBROUTINE obj_Add3 INTERFACE Add MODULE PURE SUBROUTINE obj_Add4(obj, iNodeNum, jNodeNum, idof, & - & jdof, VALUE, scale) + jdof, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum INTEGER(I4B), INTENT(IN) :: jNodeNum @@ -139,6 +247,10 @@ MODULE PURE SUBROUTINE obj_Add4(obj, iNodeNum, jNodeNum, idof, & END SUBROUTINE obj_Add4 END INTERFACE Add +INTERFACE Add_ + MODULE PROCEDURE obj_Add4 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -160,6 +272,26 @@ END SUBROUTINE obj_Add5 ! Add@addMethod !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: This subroutine Add the selected value in sparse matrix + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_5(obj, nodenum, VALUE, scale, & + row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: nodenum(:) + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_5 +END INTERFACE Add_ + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 ! summary: This subroutine Add the value in sparse matrix @@ -173,7 +305,6 @@ END SUBROUTINE obj_Add5 !$$ ! obj(Nptrs,Nptrs)=value(:,:) !$$ -! INTERFACE Add MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, & @@ -188,13 +319,32 @@ MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, & END SUBROUTINE obj_Add6 END INTERFACE Add +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_6( & + obj, iNodeNum, jNodeNum, ivar, jvar, VALUE, scale, row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + REAL(DFP), INTENT(IN) :: VALUE(:, :) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_6 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: Adds the specific row and column entry to a given value +! date: 22 March 2021 +! summary: Adds the specific row and column entry to a given value ! !# Introduction ! @@ -217,8 +367,8 @@ END SUBROUTINE obj_Add6 !@endnote INTERFACE Add - MODULE PURE SUBROUTINE obj_Add7(obj, iNodeNum, jNodeNum, ivar, & - & jvar, iDOF, jDOF, VALUE, scale) + MODULE PURE SUBROUTINE obj_Add7(obj, iNodeNum, jNodeNum, ivar, & + jvar, iDOF, jDOF, VALUE, scale) TYPE(CSRMatrix_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -238,6 +388,10 @@ MODULE PURE SUBROUTINE obj_Add7(obj, iNodeNum, jNodeNum, ivar, & END SUBROUTINE obj_Add7 END INTERFACE Add +INTERFACE Add_ + MODULE PROCEDURE obj_Add7 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -268,6 +422,36 @@ MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, & END SUBROUTINE obj_Add8 END INTERFACE Add +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_8( & + obj, iNodeNum, jNodeNum, ivar, jvar, iDOF, jDOF, VALUE, scale, & + row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + INTEGER(I4B), INTENT(IN) :: jvar + !! + INTEGER(I4B), INTENT(IN) :: iDOF + !! row degree of freedom + INTEGER(I4B), INTENT(IN) :: jDOF + !! col degree of freedom + REAL(DFP), INTENT(IN) :: VALUE(:, :) + !! scalar value to be Add + REAL(DFP), INTENT(IN) :: scale + !! scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_8 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -318,6 +502,10 @@ MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, & END SUBROUTINE obj_Add9 END INTERFACE Add +INTERFACE Add_ + MODULE PROCEDURE obj_Add9 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -350,6 +538,26 @@ MODULE PURE SUBROUTINE obj_Add10(obj, iNodeNum, jNodeNum, & END SUBROUTINE obj_Add10 END INTERFACE Add +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_10( & + obj, iNodeNum, jNodeNum, ivar, jvar, VALUE, scale, row, col, nrow, & + ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + INTEGER(I4B), INTENT(IN) :: ivar + INTEGER(I4B), INTENT(IN) :: jvar + REAL(DFP), INTENT(IN) :: VALUE + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_10 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -380,6 +588,35 @@ MODULE PURE SUBROUTINE obj_Add11(obj, iNodeNum, jNodeNum, ivar, & END SUBROUTINE obj_Add11 END INTERFACE Add +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_11( & + obj, iNodeNum, jNodeNum, ivar, jvar, iDOF, jDOF, VALUE, scale, & + row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + INTEGER(I4B), INTENT(IN) :: jvar + !! + INTEGER(I4B), INTENT(IN) :: iDOF + !! row degree of freedom + INTEGER(I4B), INTENT(IN) :: jDOF + !! col degree of freedom + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value to be Add + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_11 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -418,6 +655,39 @@ END SUBROUTINE obj_Add12 ! date: 17/01/2022 ! summary: Adds the specific row and column entry to a given value +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_12( & + obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, & + jspacecompo, jtimecompo, VALUE, scale, row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + INTEGER(I4B), INTENT(IN) :: jvar + !! + INTEGER(I4B), INTENT(IN) :: ispacecompo + INTEGER(I4B), INTENT(IN) :: itimecompo + INTEGER(I4B), INTENT(IN) :: jspacecompo + INTEGER(I4B), INTENT(IN) :: jtimecompo + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value to be Add + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_12 +END INTERFACE Add_ + +!---------------------------------------------------------------------------- +! Add@addMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 17/01/2022 +! summary: Adds the specific row and column entry to a given value + INTERFACE Add MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale) @@ -440,6 +710,35 @@ MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, & END SUBROUTINE obj_Add13 END INTERFACE Add +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_13( & + obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, & + jspacecompo, jtimecompo, VALUE, scale, row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! row variable + INTEGER(I4B), INTENT(IN) :: jvar + !! column variable + INTEGER(I4B), INTENT(IN) :: ispacecompo + INTEGER(I4B), INTENT(IN) :: itimecompo(:) + INTEGER(I4B), INTENT(IN) :: jspacecompo + INTEGER(I4B), INTENT(IN) :: jtimecompo(:) + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value to be Add + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_13 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@addMethod !---------------------------------------------------------------------------- @@ -470,6 +769,35 @@ MODULE PURE SUBROUTINE obj_Add14(obj, iNodeNum, jNodeNum, ivar, & END SUBROUTINE obj_Add14 END INTERFACE Add +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +INTERFACE Add_ + MODULE PURE SUBROUTINE obj_Add_14( & + obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, & + jspacecompo, jtimecompo, VALUE, scale, row, col, nrow, ncol) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! + INTEGER(I4B), INTENT(IN) :: jvar + !! + INTEGER(I4B), INTENT(IN) :: ispacecompo(:) + INTEGER(I4B), INTENT(IN) :: itimecompo + INTEGER(I4B), INTENT(IN) :: jspacecompo(:) + INTEGER(I4B), INTENT(IN) :: jtimecompo + REAL(DFP), INTENT(IN) :: VALUE + !! scalar value to be Add + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(INOUT) :: row(:), col(:) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Add_14 +END INTERFACE Add_ + !---------------------------------------------------------------------------- ! Add@Methods !---------------------------------------------------------------------------- @@ -483,8 +811,8 @@ END SUBROUTINE obj_Add14 ! Add a csrmatrix to another csrmatrix INTERFACE Add - MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, & - & isSorted) + MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, & + isSorted) TYPE(CSRMatrix_), INTENT(INOUT) :: obj !! CSRMatrix_ TYPE(CSRMatrix_), INTENT(IN) :: VALUE @@ -498,6 +826,44 @@ MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, & END SUBROUTINE obj_Add15 END INTERFACE Add +INTERFACE Add_ + MODULE PROCEDURE obj_Add15 +END INTERFACE Add_ + +!---------------------------------------------------------------------------- +! Add@AddMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-17 +! summary: (Obj)ab = Value +! +!# Introduction +! +! In time discontinuous fem, tangent matrix is block matrix +! First we assemble mass and stiffness matrix separately +! they can be represented by Value. +! Now we want to make one of the blocks of space-time matrix +! which is represented by Obj. +! This routine performs this task. +! Note that the storage format of Obj should be FMT_DOF +! Note that the storage format of Value and one of the blocks should be +! identical. + +INTERFACE AddToSTMatrix + MODULE PURE SUBROUTINE obj_AddToSTMatrix1( & + obj, VALUE, itimecompo, jtimecompo, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + !! space-time matrix, format should be FMT_DOF + TYPE(CSRMatrix_), INTENT(IN) :: VALUE + !! space matrix + INTEGER(I4B), INTENT(IN) :: itimecompo, jtimecompo + !! time components + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_AddToSTMatrix1 +END INTERFACE AddToSTMatrix + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 index 1a66b9b33..62b1e2523 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 @@ -39,102 +39,126 @@ MODULE CSRMatrix_GetMethods PUBLIC :: GetValue !---------------------------------------------------------------------------- -! GetIA +! GetIA !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-12-14 ! summary: Get entry in IA -INTERFACE GetIA +INTERFACE MODULE PURE FUNCTION obj_GetIA(obj, irow) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: irow INTEGER(I4B) :: ans END FUNCTION obj_GetIA +END INTERFACE + +INTERFACE GetIA + MODULE PROCEDURE obj_GetIA END INTERFACE GetIA !---------------------------------------------------------------------------- -! GetJA +! GetJA !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-12-14 ! summary: Get entry in JA -INTERFACE GetJA +INTERFACE MODULE PURE FUNCTION obj_GetJA(obj, indx) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx INTEGER(I4B) :: ans END FUNCTION obj_GetJA +END INTERFACE + +INTERFACE GetJA + MODULE PROCEDURE obj_GetJA END INTERFACE GetJA !---------------------------------------------------------------------------- -! GetSingleValue +! GetSingleValue !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-12-14 ! summary: Get single value -INTERFACE GetSingleValue +INTERFACE MODULE PURE FUNCTION obj_GetSingleValue(obj, indx) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx REAL(DFP) :: ans END FUNCTION obj_GetSingleValue -END INTERFACE GetSingleValue +END INTERFACE INTERFACE Get MODULE PROCEDURE obj_GetSingleValue END INTERFACE Get +INTERFACE GetSingleValue + MODULE PROCEDURE obj_GetSingleValue +END INTERFACE GetSingleValue + !---------------------------------------------------------------------------- -! GetSingleValue +! GetSingleValue !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-12-14 ! summary: Get single value -INTERFACE GetSeveralValue +INTERFACE MODULE PURE FUNCTION obj_GetSeveralValue(obj, indx) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx(:) REAL(DFP) :: ans(SIZE(indx)) END FUNCTION obj_GetSeveralValue -END INTERFACE GetSeveralValue +END INTERFACE INTERFACE Get MODULE PROCEDURE obj_GetSeveralValue END INTERFACE Get +INTERFACE GetSeveralValue + MODULE PROCEDURE obj_GetSeveralValue +END INTERFACE GetSeveralValue + !---------------------------------------------------------------------------- ! GetStorageFMT !---------------------------------------------------------------------------- -INTERFACE GetStorageFMT +INTERFACE MODULE PURE FUNCTION obj_GetStorageFMT(obj, i) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: i INTEGER(I4B) :: ans END FUNCTION obj_GetStorageFMT +END INTERFACE + +INTERFACE GetStorageFMT + MODULE PROCEDURE obj_GetStorageFMT END INTERFACE GetStorageFMT -INTERFACE OPERATOR(.storageFMT.) +INTERFACE OPERATOR(.StorageFMT.) MODULE PROCEDURE obj_GetStorageFMT -END INTERFACE OPERATOR(.storageFMT.) +END INTERFACE OPERATOR(.StorageFMT.) !---------------------------------------------------------------------------- ! GetMatrixProp !---------------------------------------------------------------------------- -INTERFACE GetMatrixProp +INTERFACE MODULE PURE FUNCTION obj_GetMatrixProp(obj) RESULT(ans) TYPE(CSRMatrix_), TARGET, INTENT(IN) :: obj CHARACTER(20) :: ans END FUNCTION obj_GetMatrixProp +END INTERFACE + +INTERFACE GetMatrixProp + MODULE PROCEDURE obj_GetMatrixProp END INTERFACE GetMatrixProp INTERFACE OPERATOR(.MatrixProp.) @@ -145,50 +169,66 @@ END FUNCTION obj_GetMatrixProp ! GetDOFPointer !---------------------------------------------------------------------------- -INTERFACE GetDOFPointer +INTERFACE MODULE FUNCTION obj_GetDOFPointer(obj, i) RESULT(ans) TYPE(CSRMatrix_), TARGET, INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: i CLASS(DOF_), POINTER :: ans END FUNCTION obj_GetDOFPointer +END INTERFACE + +INTERFACE GetDOFPointer + MODULE PROCEDURE obj_GetDOFPointer END INTERFACE GetDOFPointer !---------------------------------------------------------------------------- ! isSquare !---------------------------------------------------------------------------- -INTERFACE isSquare - MODULE PURE FUNCTION obj_isSquare(obj) RESULT(ans) +INTERFACE + MODULE PURE FUNCTION obj_IsSquare(obj) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj LOGICAL(LGT) :: ans - END FUNCTION obj_isSquare -END INTERFACE isSquare + END FUNCTION obj_IsSquare +END INTERFACE + +INTERFACE IsSquare + MODULE PROCEDURE obj_IsSquare +END INTERFACE IsSquare !---------------------------------------------------------------------------- -! isRectangle +! isRectangle !---------------------------------------------------------------------------- -INTERFACE isRectangle - MODULE PURE FUNCTION obj_isRectangle(obj) RESULT(ans) +INTERFACE + MODULE PURE FUNCTION obj_IsRectangle(obj) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj LOGICAL(LGT) :: ans - END FUNCTION obj_isRectangle + END FUNCTION obj_IsRectangle +END INTERFACE + +INTERFACE isRectangle + MODULE PROCEDURE obj_IsRectangle END INTERFACE isRectangle !---------------------------------------------------------------------------- -! GetColNumber +! GetColNumber !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2023-12-14 ! summary: Get the column number from JA. -INTERFACE GetColNumber +INTERFACE MODULE PURE FUNCTION obj_GetColNumber(obj, indx) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: indx INTEGER(I4B) :: ans END FUNCTION obj_GetColNumber +END INTERFACE + +INTERFACE GetColNumber + MODULE PROCEDURE obj_GetColNumber END INTERFACE GetColNumber !---------------------------------------------------------------------------- @@ -199,12 +239,16 @@ END FUNCTION obj_GetColNumber ! date: 2023-12-14 ! summary: Get the starting and ending column index of irow -INTERFACE GetColIndex +INTERFACE MODULE PURE FUNCTION obj_GetColIndex(obj, irow) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: irow INTEGER(I4B) :: ans(2) END FUNCTION obj_GetColIndex +END INTERFACE + +INTERFACE GetColIndex + MODULE PROCEDURE obj_GetColIndex END INTERFACE GetColIndex !---------------------------------------------------------------------------- @@ -215,13 +259,17 @@ END FUNCTION obj_GetColIndex ! date: 2023-12-14 ! summary: Get the starting column index of irow -INTERFACE OPERATOR(.startColumn.) - MODULE PURE FUNCTION obj_startColumn(obj, irow) RESULT(ans) +INTERFACE + MODULE PURE FUNCTION obj_StartColumn(obj, irow) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: irow INTEGER(I4B) :: ans - END FUNCTION obj_startColumn -END INTERFACE OPERATOR(.startColumn.) + END FUNCTION obj_StartColumn +END INTERFACE + +INTERFACE OPERATOR(.StartColumn.) + MODULE PROCEDURE obj_StartColumn +END INTERFACE OPERATOR(.StartColumn.) !---------------------------------------------------------------------------- ! endColumn @@ -231,13 +279,17 @@ END FUNCTION obj_startColumn ! date: 2023-12-14 ! summary: Get the ending column index of irow -INTERFACE OPERATOR(.endColumn.) - MODULE PURE FUNCTION obj_endColumn(obj, irow) RESULT(ans) +INTERFACE + MODULE PURE FUNCTION obj_EndColumn(obj, irow) RESULT(ans) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: irow INTEGER(I4B) :: ans - END FUNCTION obj_endColumn -END INTERFACE OPERATOR(.endColumn.) + END FUNCTION obj_EndColumn +END INTERFACE + +INTERFACE OPERATOR(.EndColumn.) + MODULE PROCEDURE obj_EndColumn +END INTERFACE OPERATOR(.EndColumn.) !---------------------------------------------------------------------------- ! Get @@ -254,13 +306,17 @@ END FUNCTION obj_endColumn ! - Usually `value` denotes the element matrix ! - Symbolic we are performing following task `obj(nodenum, nodenum)=value` -INTERFACE GetValue +INTERFACE MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: nodenum(:) REAL(DFP), INTENT(INOUT) :: VALUE(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get0 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get0 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -288,7 +344,7 @@ END SUBROUTINE obj_Get0 ! ! - Usually, element matrix is stored with `DOF_FMT` -INTERFACE GetValue +INTERFACE MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: nodenum(:) @@ -297,6 +353,10 @@ MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol) REAL(DFP), INTENT(INOUT) :: VALUE(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get1 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get1 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -319,7 +379,7 @@ END SUBROUTINE obj_Get1 ! This routine should be avoided by general user. !@endwarning -INTERFACE GetValue +INTERFACE MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: irow @@ -329,23 +389,10 @@ MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE) REAL(DFP), INTENT(INOUT) :: VALUE !! value END SUBROUTINE obj_Get2 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- +END INTERFACE INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE, nrow, ncol) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: irow(:) - !! row index - INTEGER(I4B), INTENT(IN) :: icolumn(:) - !! column index - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! value - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE obj_Get10 + MODULE PROCEDURE obj_Get2 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -377,9 +424,9 @@ END SUBROUTINE obj_Get10 ! or later physical variables will not start from 1. !@endnote -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, iDOF, & - jDOF, VALUE) +INTERFACE + MODULE PURE SUBROUTINE obj_Get3( & + obj, iNodeNum, jNodeNum, iDOF, jDOF, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -392,6 +439,10 @@ MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, iDOF, & REAL(DFP), INTENT(INOUT) :: VALUE !! scalar value to be Get END SUBROUTINE obj_Get3 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get3 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -412,9 +463,9 @@ END SUBROUTINE obj_Get3 ! obj(Nptrs,Nptrs)=value(:,:) !$$ -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, & - ivar, jvar, VALUE, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE obj_Get4( & + obj, iNodeNum, jNodeNum, ivar, jvar, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj !! Block csr matrix INTEGER(I4B), INTENT(IN) :: iNodeNum(:) @@ -429,6 +480,10 @@ MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, & !! value INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get4 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get4 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -459,18 +514,18 @@ END SUBROUTINE obj_Get4 ! or later physical variables will not start from 1. !@endnote -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, & - jvar, iDOF, jDOF, VALUE) +INTERFACE + MODULE PURE SUBROUTINE obj_Get5( & + obj, iNodeNum, jNodeNum, ivar, jvar, iDOF, jDOF, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number INTEGER(I4B), INTENT(IN) :: jNodeNum !! column node number INTEGER(I4B), INTENT(IN) :: ivar - !! + !! physical variable for row INTEGER(I4B), INTENT(IN) :: jvar - !! + !! physical variable for column INTEGER(I4B), INTENT(IN) :: iDOF !! row degree of freedom INTEGER(I4B), INTENT(IN) :: jDOF @@ -478,6 +533,10 @@ MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, & REAL(DFP), INTENT(INOUT) :: VALUE !! scalar value to be Get END SUBROUTINE obj_Get5 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get5 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -488,9 +547,9 @@ END SUBROUTINE obj_Get5 ! date: 2023-12-23 ! summary: Gets the specific row and column entry from a given value -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & - jvar, iDOF, jDOF, VALUE, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE obj_Get6( & + obj, iNodeNum, jNodeNum, ivar, jvar, iDOF, jDOF, VALUE, nrow, ncol) TYPE(CSRMatrix_), INTENT(IN) :: obj !! block matrix field INTEGER(I4B), INTENT(IN) :: iNodeNum(:) @@ -509,6 +568,10 @@ MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, & !! Matrix value INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE obj_Get6 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get6 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -539,9 +602,10 @@ END SUBROUTINE obj_Get6 ! or later physical variables will not start from 1. !@endnote -INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, & - jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE) +INTERFACE + MODULE PURE SUBROUTINE obj_Get7( & + obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, & + jspacecompo, jtimecompo, VALUE) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: iNodeNum !! row node number @@ -562,37 +626,10 @@ MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, & REAL(DFP), INTENT(INOUT) :: VALUE !! scalar value to be Get END SUBROUTINE obj_Get7 -END INTERFACE GetValue - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- +END INTERFACE INTERFACE GetValue - MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, & - jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, & - nrow, ncol) - TYPE(CSRMatrix_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: iNodeNum(:) - !! row node number - INTEGER(I4B), INTENT(IN) :: jNodeNum(:) - !! column node number - INTEGER(I4B), INTENT(IN) :: ivar - !! row physical variable - INTEGER(I4B), INTENT(IN) :: jvar - !! col physical variable - INTEGER(I4B), INTENT(IN) :: ispacecompo - !! row space component - INTEGER(I4B), INTENT(IN) :: itimecompo - !! row time component - INTEGER(I4B), INTENT(IN) :: jspacecompo - !! col space component - INTEGER(I4B), INTENT(IN) :: jtimecompo - !! col time component - REAL(DFP), INTENT(INOUT) :: VALUE(:, :) - !! scalar value to be Get - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE obj_Get9 + MODULE PROCEDURE obj_Get7 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -607,11 +644,11 @@ END SUBROUTINE obj_Get9 ! ! - The number of nodes in obj1 and obj2 should be same -INTERFACE GetValue - MODULE SUBROUTINE obj_Get8(obj1, obj2, ivar1, jvar1, & - ispacecompo1, jspacecompo1, itimecompo1, jtimecompo1, & - ivar2, jvar2, ispacecompo2, jspacecompo2, itimecompo2, & - jtimecompo2, ierr) +INTERFACE + MODULE SUBROUTINE obj_Get8( & + obj1, obj2, ivar1, jvar1, ispacecompo1, jspacecompo1, itimecompo1, & + jtimecompo1, ivar2, jvar2, ispacecompo2, jspacecompo2, itimecompo2, & + jtimecompo2, ierr) TYPE(CSRMatrix_), INTENT(IN) :: obj1 !! master object TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 @@ -643,6 +680,66 @@ MODULE SUBROUTINE obj_Get8(obj1, obj2, ivar1, jvar1, & INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: ierr !! Error code, if 0 no error, else error END SUBROUTINE obj_Get8 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get8 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE obj_Get9( & + obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, & + jspacecompo, jtimecompo, VALUE, nrow, ncol) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: iNodeNum(:) + !! row node number + INTEGER(I4B), INTENT(IN) :: jNodeNum(:) + !! column node number + INTEGER(I4B), INTENT(IN) :: ivar + !! row physical variable + INTEGER(I4B), INTENT(IN) :: jvar + !! col physical variable + INTEGER(I4B), INTENT(IN) :: ispacecompo + !! row space component + INTEGER(I4B), INTENT(IN) :: itimecompo + !! row time component + INTEGER(I4B), INTENT(IN) :: jspacecompo + !! col space component + INTEGER(I4B), INTENT(IN) :: jtimecompo + !! col time component + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! scalar value to be Get + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Get9 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get9 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE, nrow, ncol) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: irow(:) + !! row index + INTEGER(I4B), INTENT(IN) :: icolumn(:) + !! column index + REAL(DFP), INTENT(INOUT) :: VALUE(:, :) + !! value + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_Get10 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get10 END INTERFACE GetValue !---------------------------------------------------------------------------- @@ -658,8 +755,8 @@ END SUBROUTINE obj_Get8 ! - The number of nodes in obj1 and obj2 should be same INTERFACE - MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, & - jdof2, tNodes1, tNodes2) + MODULE SUBROUTINE CSR2CSR_Get_Master( & + obj1, obj2, idof1, jdof1, idof2, jdof2, tNodes1, tNodes2) TYPE(CSRMatrix_), INTENT(IN) :: obj1 !! master object TYPE(CSRMatrix_), INTENT(INOUT) :: obj2 @@ -677,4 +774,49 @@ MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, & END SUBROUTINE CSR2CSR_Get_Master END INTERFACE +!---------------------------------------------------------------------------- +! GetSingleValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get single value + +INTERFACE + MODULE PURE SUBROUTINE obj_Get11(obj, indx, ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx + REAL(DFP), INTENT(INOUT) :: ans + END SUBROUTINE obj_Get11 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get11 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! GetSingleValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-14 +! summary: Get single value + +INTERFACE + MODULE PURE SUBROUTINE obj_Get12(obj, indx, ans, tsize) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: indx(:) + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE obj_Get12 +END INTERFACE + +INTERFACE GetValue + MODULE PROCEDURE obj_Get12 +END INTERFACE GetValue + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE CSRMatrix_GetMethods diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 index 3ab0128e2..aa7dd02ef 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 @@ -22,6 +22,8 @@ MODULE CSRMatrix_GetSubMatrixMethods PRIVATE PUBLIC :: GetSubMatrix +PUBLIC :: GetSubMatrix_ +PUBLIC :: GetSubMatrixNNZ !---------------------------------------------------------------------------- ! GetColumn@Methods @@ -31,13 +33,67 @@ MODULE CSRMatrix_GetSubMatrixMethods ! date: 24 July 2021 ! summary: This routine returns the submatrix -INTERFACE GetSubMatrix +INTERFACE + MODULE SUBROUTINE obj_GetSubMatrixNNZ(obj, cols, selectCol, ans) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: cols(:) + !! column indices to be extracted + LOGICAL(LGT), INTENT(INOUT) :: selectCol(:) + !! size of subIndices + INTEGER(I4B), INTENT(OUT) :: ans + END SUBROUTINE obj_GetSubMatrixNNZ +END INTERFACE + +INTERFACE GetSubMatrixNNZ + MODULE PROCEDURE obj_GetSubMatrixNNZ +END INTERFACE GetSubMatrixNNZ + +!---------------------------------------------------------------------------- +! GetColumn@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the submatrix + +INTERFACE + MODULE SUBROUTINE obj_GetSubMatrix_1( & + obj, cols, submat, subIndices, selectCol, tsize) + TYPE(CSRMatrix_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: cols(:) + !! column indices to be extracted + TYPE(CSRMatrix_), INTENT(INOUT) :: submat + !! CSRMatrix to store the submatrix + INTEGER(I4B), INTENT(INOUT) :: subIndices(:) + LOGICAL(LGT), INTENT(INOUT) :: selectCol(:) + INTEGER(I4B), INTENT(OUT) :: tsize + !! size of subIndices + END SUBROUTINE obj_GetSubMatrix_1 +END INTERFACE + +INTERFACE GetSubMatrix_ + MODULE PROCEDURE obj_GetSubMatrix_1 +END INTERFACE GetSubMatrix_ + +!---------------------------------------------------------------------------- +! GetColumn@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 24 July 2021 +! summary: This routine returns the submatrix + +INTERFACE MODULE SUBROUTINE obj_GetSubMatrix1(obj, cols, submat, subIndices) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: cols(:) TYPE(CSRMatrix_), INTENT(INOUT) :: submat INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: subIndices(:) END SUBROUTINE obj_GetSubMatrix1 +END INTERFACE + +INTERFACE GetSubMatrix + MODULE PROCEDURE obj_GetSubMatrix1 END INTERFACE GetSubMatrix !---------------------------------------------------------------------------- @@ -48,14 +104,22 @@ END SUBROUTINE obj_GetSubMatrix1 ! date: 24 July 2021 ! summary: This routine returns the submatrix -INTERFACE GetSubMatrix +INTERFACE MODULE SUBROUTINE obj_GetSubMatrix2(obj, subIndices, submat) TYPE(CSRMatrix_), INTENT(IN) :: obj INTEGER(I4B), INTENT(IN) :: subIndices(:) TYPE(CSRMatrix_), INTENT(INOUT) :: submat END SUBROUTINE obj_GetSubMatrix2 +END INTERFACE + +INTERFACE GetSubMatrix + MODULE PROCEDURE obj_GetSubMatrix2 END INTERFACE GetSubMatrix +INTERFACE GetSubMatrix_ + MODULE PROCEDURE obj_GetSubMatrix2 +END INTERFACE GetSubMatrix_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 index 127461fde..293a6b8be 100644 --- a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 +++ b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90 @@ -24,6 +24,7 @@ MODULE CSRMatrix_SetMethods PUBLIC :: SetSingleValue PUBLIC :: ASSIGNMENT(=) PUBLIC :: SetIA, SetJA +PUBLIC :: SetToSTMatrix !---------------------------------------------------------------------------- ! Set@setMethod @@ -577,4 +578,38 @@ MODULE PURE SUBROUTINE obj_SetJA(obj, indx, VALUE) END SUBROUTINE obj_SetJA END INTERFACE SetJA +!---------------------------------------------------------------------------- +! Set@setMethod +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-17 +! summary: (Obj)ab = Value +! +!# Introduction +! +! In time discontinuous fem, tangent matrix is block matrix +! First we assemble mass and stiffness matrix separately +! they can be represented by Value. +! Now we want to make one of the blocks of space-time matrix +! which is represented by Obj. +! This routine performs this task. +! Note that the storage format of Obj should be FMT_DOF +! Note that the storage format of Value and one of the blocks should be +! identical. + +INTERFACE SetToSTMatrix + MODULE PURE SUBROUTINE obj_SetToSTMatrix1( & + obj, VALUE, itimecompo, jtimecompo, scale) + TYPE(CSRMatrix_), INTENT(INOUT) :: obj + !! space-time matrix, format should be FMT_DOF + TYPE(CSRMatrix_), INTENT(IN) :: VALUE + !! space matrix + INTEGER(I4B), INTENT(IN) :: itimecompo, jtimecompo + !! time components + REAL(DFP), OPTIONAL, INTENT(IN) :: scale + !! scale + END SUBROUTINE obj_SetToSTMatrix1 +END INTERFACE SetToSTMatrix + END MODULE CSRMatrix_SetMethods diff --git a/src/modules/DOF/src/DOF_IOMethods.F90 b/src/modules/DOF/src/DOF_IOMethods.F90 index fee5e0a80..adaf5142a 100644 --- a/src/modules/DOF/src/DOF_IOMethods.F90 +++ b/src/modules/DOF/src/DOF_IOMethods.F90 @@ -16,8 +16,9 @@ ! MODULE DOF_IOMethods -USE GlobalData -USE BaseType +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: RealVector_, DOF_ + IMPLICIT NONE PRIVATE diff --git a/src/modules/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90 index c516de534..7db090a23 100755 --- a/src/modules/Display/src/Display_Method.F90 +++ b/src/modules/Display/src/Display_Method.F90 @@ -61,51 +61,51 @@ MODULE Display_Method INTERFACE Display MODULE PROCEDURE & - & Display_Str, & - & Display_Str2, & - & Display_Real64, & - & Display_Real32, & - & Display_Cmplx64, & - & Display_Cmplx32, & - & Display_Int8, & - & Display_Int16, & - & Display_Int32, & - & Display_Int64, & - & Display_Logical, & - & Display_Vector_Logical, & - & Display_Vector_Real64, & - & Display_Vector_Real32, & - & Display_Vector_Cmplx64, & - & Display_Vector_Cmplx32, & - & Display_Vector_Int8, & - & Display_Vector_Int16, & - & Display_Vector_Int32, & - & Display_Vector_Int64, & - & Display_Mat2_Real64, & - & Display_Mat2_Real32, & - & Display_Mat2_Cmplx64, & - & Display_Mat2_Cmplx32, & - & Display_Mat2_Int64, & - & Display_Mat2_Int32, & - & Display_Mat2_Int16, & - & Display_Mat2_Int8, & - & Display_Mat2_Bool, & - & Display_Mat3_Real64, & - & Display_Mat3_Real32, & - & Display_Mat3_Cmplx64, & - & Display_Mat3_Cmplx32, & - & Display_Mat3_Int64, & - & Display_Mat3_Int32, & - & Display_Mat3_Int16, & - & Display_Mat3_Int8, & - & Display_Mat4_Real64, & - & Display_Mat4_Real32, & - & Display_Mat4_Cmplx64, & - & Display_Mat4_Cmplx32, & - & Display_Mat4_Int64, & - & Display_Mat4_Int32, & - & Display_Mat4_Int16, & - & Display_Mat4_Int8 + Display_Str, & + Display_Str2, & + Display_Real64, & + Display_Real32, & + Display_Cmplx64, & + Display_Cmplx32, & + Display_Int8, & + Display_Int16, & + Display_Int32, & + Display_Int64, & + Display_Logical, & + Display_Vector_Logical, & + Display_Vector_Real64, & + Display_Vector_Real32, & + Display_Vector_Cmplx64, & + Display_Vector_Cmplx32, & + Display_Vector_Int8, & + Display_Vector_Int16, & + Display_Vector_Int32, & + Display_Vector_Int64, & + Display_Mat2_Real64, & + Display_Mat2_Real32, & + Display_Mat2_Cmplx64, & + Display_Mat2_Cmplx32, & + Display_Mat2_Int64, & + Display_Mat2_Int32, & + Display_Mat2_Int16, & + Display_Mat2_Int8, & + Display_Mat2_Bool, & + Display_Mat3_Real64, & + Display_Mat3_Real32, & + Display_Mat3_Cmplx64, & + Display_Mat3_Cmplx32, & + Display_Mat3_Int64, & + Display_Mat3_Int32, & + Display_Mat3_Int16, & + Display_Mat3_Int8, & + Display_Mat4_Real64, & + Display_Mat4_Real32, & + Display_Mat4_Cmplx64, & + Display_Mat4_Cmplx32, & + Display_Mat4_Int64, & + Display_Mat4_Int32, & + Display_Mat4_Int16, & + Display_Mat4_Int8 END INTERFACE CONTAINS @@ -266,7 +266,7 @@ SUBROUTINE Display_Real64(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Real64 !---------------------------------------------------------------------------- @@ -293,7 +293,7 @@ SUBROUTINE Display_Real32(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Real32 !---------------------------------------------------------------------------- @@ -316,7 +316,7 @@ SUBROUTINE Display_Cmplx64(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Cmplx64 !---------------------------------------------------------------------------- @@ -339,7 +339,7 @@ SUBROUTINE Display_Cmplx32(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Cmplx32 !---------------------------------------------------------------------------- @@ -366,7 +366,7 @@ SUBROUTINE Display_Int64(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Int64 !---------------------------------------------------------------------------- @@ -393,7 +393,7 @@ SUBROUTINE Display_Int32(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Int32 !---------------------------------------------------------------------------- @@ -420,7 +420,7 @@ SUBROUTINE Display_Int16(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Int16 !---------------------------------------------------------------------------- @@ -447,7 +447,7 @@ SUBROUTINE Display_Int8(val, msg, unitNo, advance) CHARACTER(*), INTENT(IN) :: msg INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Scalar.inc" +#include "./include/Display_Scalar.F90" END SUBROUTINE Display_Int8 !---------------------------------------------------------------------------- @@ -530,7 +530,7 @@ SUBROUTINE Display_Vector_Logical(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Logical !---------------------------------------------------------------------------- @@ -568,7 +568,7 @@ SUBROUTINE Display_Vector_Real64(val, msg, unitNo, orient, full, advance) ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance !! vector of real numbers -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Real64 !---------------------------------------------------------------------------- @@ -605,7 +605,7 @@ SUBROUTINE Display_Vector_Real32(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Real32 !---------------------------------------------------------------------------- @@ -643,7 +643,7 @@ SUBROUTINE Display_Vector_Cmplx64(val, msg, unitNo, orient, full, advance) ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance !! vector of real numbers -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Cmplx64 !---------------------------------------------------------------------------- @@ -680,7 +680,7 @@ SUBROUTINE Display_Vector_Cmplx32(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Cmplx32 !---------------------------------------------------------------------------- @@ -718,7 +718,7 @@ SUBROUTINE Display_Vector_Int32(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Int32 !---------------------------------------------------------------------------- @@ -756,7 +756,7 @@ SUBROUTINE Display_Vector_Int64(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Int64 !---------------------------------------------------------------------------- @@ -793,7 +793,7 @@ SUBROUTINE Display_Vector_Int16(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Int16 !---------------------------------------------------------------------------- @@ -830,7 +830,7 @@ SUBROUTINE Display_Vector_Int8(val, msg, unitNo, orient, full, advance) LOGICAL(LGT), INTENT(IN), OPTIONAL :: full ! logical variable to print the whole vector CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Vector.inc" +#include "./include/Display_Vector.F90" END SUBROUTINE Display_Vector_Int8 !---------------------------------------------------------------------------- @@ -857,7 +857,7 @@ SUBROUTINE Display_Mat2_Real64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Real64 !---------------------------------------------------------------------------- @@ -884,7 +884,7 @@ SUBROUTINE Display_Mat2_Real32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Real32 !---------------------------------------------------------------------------- @@ -912,7 +912,7 @@ SUBROUTINE Display_Mat2_Cmplx64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Cmplx64 !---------------------------------------------------------------------------- @@ -940,7 +940,7 @@ SUBROUTINE Display_Mat2_Cmplx32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Cmplx32 !---------------------------------------------------------------------------- @@ -965,7 +965,7 @@ SUBROUTINE Display_Mat2_Int64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Int64 !---------------------------------------------------------------------------- @@ -990,7 +990,7 @@ SUBROUTINE Display_Mat2_Int32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Int32 !---------------------------------------------------------------------------- @@ -1015,7 +1015,7 @@ SUBROUTINE Display_Mat2_Int16(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Int16 !---------------------------------------------------------------------------- @@ -1040,7 +1040,7 @@ SUBROUTINE Display_Mat2_Int8(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Int8 !---------------------------------------------------------------------------- @@ -1065,7 +1065,7 @@ SUBROUTINE Display_Mat2_Bool(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), INTENT(IN), OPTIONAL :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat2.inc" +#include "./include/Display_Mat2.F90" END SUBROUTINE Display_Mat2_Bool !---------------------------------------------------------------------------- @@ -1094,7 +1094,7 @@ SUBROUTINE Display_Mat3_Real64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Real64 !---------------------------------------------------------------------------- @@ -1123,7 +1123,7 @@ SUBROUTINE Display_Mat3_Real32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Real32 !---------------------------------------------------------------------------- @@ -1153,7 +1153,7 @@ SUBROUTINE Display_Mat3_Cmplx64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Cmplx64 !---------------------------------------------------------------------------- @@ -1183,7 +1183,7 @@ SUBROUTINE Display_Mat3_Cmplx32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Cmplx32 !---------------------------------------------------------------------------- @@ -1212,7 +1212,7 @@ SUBROUTINE Display_Mat3_Int64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Int64 !---------------------------------------------------------------------------- @@ -1241,7 +1241,7 @@ SUBROUTINE Display_Mat3_Int32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Int32 !---------------------------------------------------------------------------- @@ -1271,7 +1271,7 @@ SUBROUTINE Display_Mat3_Int16(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Int16 !---------------------------------------------------------------------------- @@ -1301,7 +1301,7 @@ SUBROUTINE Display_Mat3_Int8(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat3.inc" +#include "./include/Display_Mat3.F90" END SUBROUTINE Display_Mat3_Int8 !---------------------------------------------------------------------------- @@ -1331,7 +1331,7 @@ SUBROUTINE Display_Mat4_Real64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Real64 !---------------------------------------------------------------------------- @@ -1361,7 +1361,7 @@ SUBROUTINE Display_Mat4_Real32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Real32 !---------------------------------------------------------------------------- @@ -1392,7 +1392,7 @@ SUBROUTINE Display_Mat4_Cmplx64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Cmplx64 !---------------------------------------------------------------------------- @@ -1422,7 +1422,7 @@ SUBROUTINE Display_Mat4_Cmplx32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Cmplx32 !---------------------------------------------------------------------------- @@ -1452,7 +1452,7 @@ SUBROUTINE Display_Mat4_Int64(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Int64 !---------------------------------------------------------------------------- @@ -1482,7 +1482,7 @@ SUBROUTINE Display_Mat4_Int32(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Int32 !---------------------------------------------------------------------------- @@ -1512,7 +1512,7 @@ SUBROUTINE Display_Mat4_Int16(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Int16 !---------------------------------------------------------------------------- @@ -1542,7 +1542,7 @@ SUBROUTINE Display_Mat4_Int8(Val, msg, unitNo, full, advance) INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full CHARACTER(*), OPTIONAL, INTENT(IN) :: advance -#include "./Display_Mat4.inc" +#include "./include/Display_Mat4.F90" END SUBROUTINE Display_Mat4_Int8 !---------------------------------------------------------------------------- @@ -1708,4 +1708,9 @@ SUBROUTINE TIMESTAMP() d, TRIM(month(m)), y, h, ':', n, ':', s, '.', mm, TRIM(ampm) END SUBROUTINE TIMESTAMP + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE Display_Method diff --git a/src/modules/Display/src/Display_Mat2.inc b/src/modules/Display/src/include/Display_Mat2.F90 similarity index 100% rename from src/modules/Display/src/Display_Mat2.inc rename to src/modules/Display/src/include/Display_Mat2.F90 diff --git a/src/modules/Display/src/Display_Mat3.inc b/src/modules/Display/src/include/Display_Mat3.F90 similarity index 100% rename from src/modules/Display/src/Display_Mat3.inc rename to src/modules/Display/src/include/Display_Mat3.F90 diff --git a/src/modules/Display/src/Display_Mat4.inc b/src/modules/Display/src/include/Display_Mat4.F90 similarity index 100% rename from src/modules/Display/src/Display_Mat4.inc rename to src/modules/Display/src/include/Display_Mat4.F90 diff --git a/src/modules/Display/src/Display_Scalar.inc b/src/modules/Display/src/include/Display_Scalar.F90 similarity index 100% rename from src/modules/Display/src/Display_Scalar.inc rename to src/modules/Display/src/include/Display_Scalar.F90 diff --git a/src/modules/Display/src/Display_Vector.inc b/src/modules/Display/src/include/Display_Vector.F90 similarity index 57% rename from src/modules/Display/src/Display_Vector.inc rename to src/modules/Display/src/include/Display_Vector.F90 index 897509be8..8b087060c 100644 --- a/src/modules/Display/src/Display_Vector.inc +++ b/src/modules/Display/src/include/Display_Vector.F90 @@ -19,55 +19,52 @@ CHARACTER(3) :: orient_ LOGICAL(LGT) :: full_ INTEGER(I4B) :: ii, ff, ss +LOGICAL(LGT) :: isok, abool CALL setDefaultSettings !> main -IF (PRESENT(unitNo)) THEN - I = unitNo -ELSE - I = stdout -END IF -IF (PRESENT(full)) THEN - full_ = full -ELSE - full_ = .FALSE. - ! do nothing for now -END IF -IF (I .NE. stdout .OR. (I .NE. stderr)) THEN - full_ = .TRUE. -END IF +I = stdout +full_ = .FALSE. +orient_ = "col" -IF (PRESENT(orient)) THEN - IF (orient(1:1) .EQ. "r" .OR. orient(1:1) .EQ. "R") THEN - orient_ = "row" - ELSE - orient_ = "col" - END IF -ELSE - orient_ = "col" +isok = PRESENT(unitNo); IF (isok) I = unitNo +isok = PRESENT(full); IF (isok) full_ = full +isok = (I .NE. stdout) .OR. (I .NE. stderr) +IF (isok) full_ = .TRUE. + +isok = PRESENT(orient) +IF (isok) THEN + abool = (orient(1:1) .EQ. "r") .OR. (orient(1:1) .EQ. "R") + IF (abool) orient_ = "row" END IF ss = SIZE(val) -IF (full_ .OR. ss .LE. (minRow + minRow)) THEN +abool = ss .LE. (minRow + minRow) +IF (full_ .OR. abool) THEN + #ifdef COLOR_DISP CALL DISP( & - & title=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, & - & style=COLOR_STYLE)), & - & x=val, unit=I, orient=orient_, advance=advance) + title=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, & + style=COLOR_STYLE)), & + x=val, unit=I, orient=orient_, advance=advance) #else CALL DISP(title=msg, x=val, unit=I, orient=orient_, advance=advance) #endif + ELSE IF (orient_ .EQ. "row") THEN CALL Disp(title=msg, unit=I, advance="YES") - CALL DISP(title="", x=val(1:minRow), unit=I, orient=orient_, advance="NO") + CALL Disp(title="", x=val(1:minRow), unit=I, orient=orient_, advance="NO") CALL Display("...", unitNo=I, advance=.FALSE.) - CALL DISP(title="", x=val(ss-minRow+1:ss), unit=I, orient=orient_, advance=advance) + CALL Disp(title="", x=val(ss - minRow + 1:ss), unit=I, orient=orient_, & + advance=advance) ELSE CALL Disp(title=msg, unit=I, advance="YES") - CALL DISP(title="", x=val(1:minRow), unit=I, orient=orient_, advance="YES") + CALL Disp(title="", x=val(1:minRow), unit=I, orient=orient_, & + advance="YES") CALL Display("."//CHAR_LF//"."//CHAR_LF//".", unitNo=I, advance=.TRUE.) - CALL DISP(title="", x=val(ss-minRow+1:ss), unit=I, orient=orient_, advance=advance) + CALL Disp(title="", x=val(ss - minRow + 1:ss), unit=I, orient=orient_, & + advance=advance) END IF END IF diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt index 1ce516e03..85dc0942c 100644 --- a/src/modules/ElemshapeData/CMakeLists.txt +++ b/src/modules/ElemshapeData/CMakeLists.txt @@ -34,6 +34,9 @@ target_sources( ${src_path}/ElemshapeData_HRGNParamMethods.F90 ${src_path}/ElemshapeData_HRQIParamMethods.F90 ${src_path}/ElemshapeData_InterpolMethods.F90 + ${src_path}/ElemshapeData_ScalarInterpolMethods.F90 + ${src_path}/ElemshapeData_VectorInterpolMethods.F90 + ${src_path}/ElemshapeData_MatrixInterpolMethods.F90 ${src_path}/ElemshapeData_IOMethods.F90 ${src_path}/ElemshapeData_LocalDivergenceMethods.F90 ${src_path}/ElemshapeData_LocalGradientMethods.F90 diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 index 48406b880..4f84eef0d 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 @@ -16,8 +16,9 @@ ! MODULE ElemshapeData_ConstructorMethods -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, QuadraturePoint_, & + ReferenceElement_ +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE PRIVATE @@ -40,7 +41,7 @@ MODULE ElemshapeData_ConstructorMethods !- This subroutine belongs to the generic interface called `Allocate()`. INTERFACE ALLOCATE - MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips, nnt) + MODULE PURE SUBROUTINE obj_Allocate(obj, nsd, xidim, nns, nips, nnt) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! object to be returned INTEGER(I4B), INTENT(IN) :: nsd @@ -53,9 +54,13 @@ MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips, nnt) !! number of integration points INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnt !! it is used when elemshape data is STElemShapeData - END SUBROUTINE elemsd_Allocate + END SUBROUTINE obj_Allocate END INTERFACE ALLOCATE +INTERFACE Initiate + MODULE PROCEDURE obj_Allocate +END INTERFACE Initiate + !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -65,8 +70,8 @@ END SUBROUTINE elemsd_Allocate ! summary: This routine Initiate the element shapefunction data INTERFACE Initiate - MODULE SUBROUTINE elemsd_Initiate1(obj, quad, refelem, continuityType, & - interpolType) + MODULE SUBROUTINE obj_Initiate1(obj, quad, refelem, continuityType, & + interpolType) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! ElemshapeData to be formed CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -77,7 +82,7 @@ MODULE SUBROUTINE elemsd_Initiate1(obj, quad, refelem, continuityType, & !! - continuity/ conformity of shape function (basis functions) CHARACTER(*), INTENT(IN) :: interpolType !! interpolation/polynomial family for basis functions - END SUBROUTINE elemsd_Initiate1 + END SUBROUTINE obj_Initiate1 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -89,14 +94,14 @@ END SUBROUTINE elemsd_Initiate1 ! summary: Copy data from an instance of elemshapedata to another instance INTERFACE Initiate - MODULE SUBROUTINE elemsd_Initiate2(obj1, obj2) + MODULE SUBROUTINE obj_Initiate2(obj1, obj2) CLASS(ElemshapeData_), INTENT(INOUT) :: obj1 CLASS(ElemshapeData_), INTENT(IN) :: obj2 - END SUBROUTINE elemsd_Initiate2 + END SUBROUTINE obj_Initiate2 END INTERFACE Initiate INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE elemsd_Initiate2 + MODULE PROCEDURE obj_Initiate2 END INTERFACE !---------------------------------------------------------------------------- @@ -125,11 +130,11 @@ END SUBROUTINE elemsd_Initiate2 ! INTERFACE Initiate - MODULE PURE SUBROUTINE stsd_Initiate(obj, elemsd) + MODULE PURE SUBROUTINE obj_Initiate3(obj, elemsd) TYPE(STElemshapeData_), ALLOCATABLE, INTENT(INOUT) :: obj(:) TYPE(ElemshapeData_), INTENT(IN) :: elemsd !! It has information about location shape function for time element - END SUBROUTINE stsd_Initiate + END SUBROUTINE obj_Initiate3 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -147,9 +152,9 @@ END SUBROUTINE stsd_Initiate ! INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE elemsd_Deallocate(obj) + MODULE PURE SUBROUTINE obj_Deallocate(obj) CLASS(ElemshapeData_), INTENT(INOUT) :: obj - END SUBROUTINE elemsd_Deallocate + END SUBROUTINE obj_Deallocate END INTERFACE DEALLOCATE END MODULE ElemshapeData_ConstructorMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 index 185537cb6..2258d1958 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 @@ -47,7 +47,8 @@ MODULE ElemshapeData_H1Methods INTERFACE Initiate MODULE SUBROUTINE H1_Hierarchy1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -87,7 +88,8 @@ END SUBROUTINE H1_Hierarchy1 INTERFACE Initiate MODULE SUBROUTINE H1_Orthogonal1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -124,7 +126,8 @@ END SUBROUTINE H1_Orthogonal1 INTERFACE Initiate MODULE SUBROUTINE H1_Hermit1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad @@ -157,7 +160,8 @@ END SUBROUTINE H1_Hermit1 INTERFACE Initiate MODULE SUBROUTINE H1_Serendipity1(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, alpha, beta, lambda) + baseInterpolation, order, ipType, & + basisType, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! Element shape data CLASS(QuadraturePoint_), INTENT(IN) :: quad diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 index 15c3184f6..9c83a8d71 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 @@ -28,6 +28,7 @@ MODULE ElemshapeData_Hierarchical PRIVATE PUBLIC :: HierarchicalElemShapeData +PUBLIC :: HierarchicalFacetElemShapeData PUBLIC :: Initiate !---------------------------------------------------------------------------- @@ -39,9 +40,9 @@ MODULE ElemshapeData_Hierarchical ! summary: This routine initiate the shape data INTERFACE HierarchicalElemShapeData - MODULE SUBROUTINE HierarchicalElemShapeData1(obj, quad, nsd, xidim, & - elemType, refelemCoord, domainName, cellOrder, faceOrder, edgeOrder, & - cellOrient, faceOrient, edgeOrient) + MODULE SUBROUTINE HierarchicalElemShapeData1( & + obj, quad, nsd, xidim, elemType, refelemCoord, domainName, cellOrder, & + faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) TYPE(ElemshapeData_), INTENT(INOUT) :: obj !! element shape data TYPE(QuadraturePoint_), INTENT(IN) :: quad @@ -80,8 +81,9 @@ END SUBROUTINE HierarchicalElemShapeData1 ! summary: This routine initiate the shape data INTERFACE HierarchicalElemShapeData - MODULE SUBROUTINE HierarchicalElemShapeData2(obj, quad, refelem, cellOrder, & - faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + MODULE SUBROUTINE HierarchicalElemShapeData2( & + obj, quad, refelem, cellOrder, faceOrder, edgeOrder, cellOrient, & + faceOrient, edgeOrient) TYPE(ElemshapeData_), INTENT(INOUT) :: obj TYPE(QuadraturePoint_), INTENT(IN) :: quad CLASS(ReferenceElement_), INTENT(IN) :: refelem @@ -105,9 +107,9 @@ END SUBROUTINE HierarchicalElemShapeData2 !---------------------------------------------------------------------------- INTERFACE HierarchicalElemShapeData - MODULE SUBROUTINE HierarchicalElemShapeData3(obj, quad, refelem, & - baseContinuity, baseInterpolation, cellOrder, & - faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) + MODULE SUBROUTINE HierarchicalElemShapeData3( & + obj, quad, refelem, baseContinuity, baseInterpolation, cellOrder, & + faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient) TYPE(ElemshapeData_), INTENT(INOUT) :: obj TYPE(QuadraturePoint_), INTENT(IN) :: quad CLASS(ReferenceElement_), INTENT(IN) :: refelem @@ -135,4 +137,48 @@ END SUBROUTINE HierarchicalElemShapeData3 MODULE PROCEDURE HierarchicalElemShapeData3 END INTERFACE Initiate +!---------------------------------------------------------------------------- +! Initiate@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE HierarchicalFacetElemShapeData + MODULE SUBROUTINE HierarchicalFacetElemShapeData1( & + obj, facetElemsd, quad, facetQuad, localFaceNumber, nsd, xidim, & + elemType, refelemCoord, domainName, cellOrder, faceOrder, edgeOrder, & + cellOrient, faceOrient, edgeOrient) + TYPE(ElemshapeData_), INTENT(INOUT) :: obj, facetElemsd + !! element shape data + TYPE(QuadraturePoint_), INTENT(IN) :: quad, facetQuad + !! quadrature point + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(IN) :: nsd + !! number of spatial dimension + INTEGER(I4B), INTENT(IN) :: xidim + !! dimension of xi + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: refelemCoord(:, :) + !! coordinate of reference element + CHARACTER(*), INTENT(IN) :: domainName + !! name of reference element domain + INTEGER(I4B), INTENT(IN) :: cellOrder(:) + !! cell order, always needed + INTEGER(I4B), INTENT(IN) :: faceOrder(:, :) + !! face order, needed for 2D and 3D elements + INTEGER(I4B), INTENT(IN) :: edgeOrder(:) + !! edge order, needed for 3D elements only + INTEGER(I4B), INTENT(IN) :: cellOrient(:) + !! orientation of cell + INTEGER(I4B), INTENT(IN) :: faceOrient(:, :) + !! orientation of face + INTEGER(I4B), INTENT(IN) :: edgeOrient(:) + !! edge orientation + END SUBROUTINE HierarchicalFacetElemShapeData1 +END INTERFACE HierarchicalFacetElemShapeData + END MODULE ElemshapeData_Hierarchical diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 index f6ab5ef77..b76509037 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 @@ -18,641 +18,164 @@ ! This file contains the interpolation methods interfaces\ MODULE ElemshapeData_InterpolMethods -USE BaseType -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_ IMPLICIT NONE PRIVATE -PUBLIC :: GetInterpolation PUBLIC :: GetInterpolation_ +PUBLIC :: GetInterpolation PUBLIC :: Interpolation -PUBLIC :: STInterpolation !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 4 March 2021 -! summary: This subroutine performs interpolations of scalar -! -!# Introduction -! -! This subroutine performs interpolation of a scalar from its spatial nodal -! values. -! -! $$u=u_{I}N^{I}$$ -! -! - TODO Make it work when the size of val is not the same as NNS - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) - !! Interpolation value of of scalar - REAL(DFP), INTENT(IN) :: val(:) - !! spatial nodal values of scalar - END SUBROUTINE scalar_getInterpolation_1 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation1_(obj, interpol, val, tsize) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) - REAL(DFP), INTENT(IN) :: val(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE scalar_getInterpolation1_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolations of scalar nodal values -! -!# Introduction -! -! This subroutine performs interpolation of a scalar from its space-time nodal -! values. -! -! $$u=u^{a}_{I}N^{I}T_{a}$$ -! -! The resultant represents the interpolation value of `val` at -! spatial-quadrature points - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:) - !! Interpolation of scalar - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time nodal values of scalar - END SUBROUTINE scalar_getInterpolation_2 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation2_(obj, interpol, val, tsize) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) - REAL(DFP), INTENT(IN) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE scalar_getInterpolation2_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolations of scalar nodal values -! -!# Introduction -! -! This subroutine performs interpolation of a scalar from its space-time nodal -! values. -! -! $$u=u^{a}_{I}N^{I}T_{a}$$ -! -! The resultant represents the interpolation value of `val` at -! spatial-temporal quadrature points - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) - !! space-time Interpolation of scalar - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time nodal values of scalar - END SUBROUTINE scalar_getInterpolation_3 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation3_(obj, interpol, val, & - nrow, ncol) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - REAL(DFP), INTENT(IN) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE scalar_getInterpolation3_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: returns the interpolation of scalar FEVariable +! summary: returns the interpolation of a FEVariable ! !# Introduction ! -! Returns the interpolation of scalar variable -! The scalar variable can be+ +! If ans is not initiated then it will be initiated +! If ans is initiated then we will just call GetInterpolation_ +! which does not alter the properties of ans, it just fills the +! value of ans ! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values +! - Returns the interpolation of a FEVariable_ +! - The result is returned in ans, which is a FEVariable +! - The rank of ans is same as the rank of val +! - ans is defined on Quadrature, that is, ans is QuadratureVariable +! - ans will vary in space only ! -!@note -!This routine calls [[Interpolation]] function from the same module. -!@endnote - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE scalar_getInterpolation_4(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:) - !! interpolation of scalar - TYPE(FEVariable_), INTENT(IN) :: val - !! Scalar FE variable - END SUBROUTINE scalar_getInterpolation_4 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- +! - 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 ! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of scalar without allocation +! - If ans is not initiated then it will be initiated and then we will call +! GetInterpolation_. In this case following properties are set for ans +! - rank of ans and rank of val will be same +! - vartype of ans will Space (We cannot set spacetime or time as +! we do not have time shape function for +! all quadrature points in time in obj) -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE scalar_getInterpolation4_(obj, interpol, val, tsize) +INTERFACE + MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:) + TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE scalar_getInterpolation4_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolations of scalar FEVariable -! -!# Introduction -! -! This subroutine performs interpolation of a scalar [[FEVariable_]] -! The FE Variable can be a -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values -! -! $$u=u^{a}_{I}N^{I}T_{a}$$ -! -! The resultant represents the interpolation value of `val` at -! spatial-quadrature points + END SUBROUTINE GetInterpolation1 +END INTERFACE INTERFACE GetInterpolation - MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) - !! space-time interpolation of scalar - TYPE(FEVariable_), INTENT(IN) :: val - !! scalar FE variable - END SUBROUTINE scalar_getInterpolation_5 + MODULE PROCEDURE GetInterpolation1 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 +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 4 March 2021 -! summary: This subroutine performs interpolation of a vector -! -!# Introduction -! -! This subroutine performs interpolation of a vector from its spatial -! nodal values -! -! $$u_{i}=u_{iI}N^{I}$$ - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) - !! interpolation of vector - REAL(DFP), INTENT(IN) :: val(:, :) - !! nodal values of vector in `xiJ` format - END SUBROUTINE vector_getInterpolation_1 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation1_(obj, interpol, val, & - nrow, ncol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - REAL(DFP), INTENT(IN) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE vector_getInterpolation1_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of a vector -! -!# Introduction -! -! This subroutine performs interpolation of a vector from its space-time -! nodal values -! -! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :) - !! - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE vector_getInterpolation_2 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, interpol, val, & - nrow, ncol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :) - REAL(DFP), INTENT(IN) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE vector_getInterpolation2_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of a vector +! summary: returns the interpolation of a FEVariable ! !# Introduction ! -! This subroutine performs interpolation of a vector from its space-time -! nodal values -! -! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) - !! - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! space-time nodal values of vector in `xiJa` format - END SUBROUTINE vector_getInterpolation_3 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- +! - Returns the interpolation of a FEVariable_ +! - The result is returned in ans +! - ans is a FEVariable +! - The rank of ans is same as the rank of val +! - ans is defined on Quadrature, that is, ans is QuadratureVariable ! -!---------------------------------------------------------------------------- - -!> 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 -!---------------------------------------------------------------------------- +! - 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 -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: returns the interpolation of vector FEVariable -! -!# Introduction -! -! Returns the interpolation of vector variable -! The vector variable can be+ -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values -! -! NOTE This routine calls [[Interpolation]] function from the same module. -! -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val) +INTERFACE + MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :) - !! interpolation of vector + TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - !! vector FEvariable - END SUBROUTINE vector_getInterpolation_4 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation + END SUBROUTINE GetInterpolation_1 +END INTERFACE 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_ + MODULE PROCEDURE GetInterpolation_1 END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 4 March 2021 -! summary: returns the interpolation of vector FEVariable +! summary: returns the interpolation of a FEVariable ! !# Introduction ! -! Returns the interpolation of vector variable -! The vector variable can be+ -! -! - constant -! - spatial nodal values -! - spatial quadrature values -! - space-time nodal values +! - Returns the interpolation of a FEVariable_ +! - The result is returned in ans +! - ans is a FEVariable +! - The rank of ans is same as the rank of val +! - ans is defined on Quadrature, that is, ans is QuadratureVariable ! -! NOTE This routine calls [[Interpolation]] function from the same module. +! - The val can have following ranks; scalar, vector, matrix +! - the val can be defined on quadrature (do nothing) or nodal (interpol) +! - The `vartype` of val can be constant, space, time, spacetime ! -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) - !! space-time interpolation of vector +INTERFACE + MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, scale, & + addContribution) + CLASS(ElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - !! vector FEvariable - END SUBROUTINE vector_getInterpolation_5 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-03 -! summary: get interpolation of vector without allocation + REAL(DFP), INTENT(IN) :: scale + LOGICAL, INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_1a +END INTERFACE 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_ + MODULE PROCEDURE GetInterpolation_1a END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 4 March 2021 -! summary: This subroutine performs interpolation of matrix - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) - !! interpolation of matrix - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! nodal value of matrix - END SUBROUTINE matrix_getInterpolation_1 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE matrix_getInterpolation1_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of matrix +! summary: returns the interpolation of a FEVariable ! !# Introduction ! -! This subroutine performs interpolation of matrix from its space-time -! nodal values - -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal value of matrix - END SUBROUTINE matrix_getInterpolation_2 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- +! If ans is not initiated then it will be initiated. If +! ans is initiated then its properties will not be altered. ! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE matrix_getInterpolation2_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 1 Nov 2021 -! summary: This subroutine performs interpolation of matrix +! - Returns the interpolation of a FEVariable +! - The result is returned in ans, which is a FEVariable +! - The rank of ans is same as the rank of val +! - ans is defined on Quadrature, that is, ans is QuadratureVariable ! -!# Introduction +! - 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 ! -! This subroutine performs interpolation of matrix from its space-time -! nodal values +! - ans will Quadrature and SpaceTime -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val) +INTERFACE + MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :) - !! space-time interpolation - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! space-time nodal value of matrix - END SUBROUTINE matrix_getInterpolation_3 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This subroutine performs interpolation of matrix FEVariable -! -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :) - !! interpolation of matrix - TYPE(FEVariable_), INTENT(IN) :: val - !! matrix fe variable - END SUBROUTINE matrix_getInterpolation_4 -END INTERFACE GetInterpolation - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: get interpolation of matrix without allocation - -INTERFACE GetInterpolation_ - MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, interpol, val, & - dim1, dim2, dim3) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: interpol(:, :, :) + TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE matrix_getInterpolation4_ -END INTERFACE GetInterpolation_ - -!---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods -!---------------------------------------------------------------------------- + END SUBROUTINE GetInterpolation2 +END INTERFACE INTERFACE GetInterpolation - MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val) - CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :) - !! space-time interpolation of matrix - TYPE(FEVariable_), INTENT(IN) :: val - !! matrix fe variable - END SUBROUTINE matrix_getInterpolation_5 + MODULE PROCEDURE GetInterpolation2 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 +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -671,100 +194,55 @@ END SUBROUTINE matrix_getInterpolation5_ ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime ! -INTERFACE GetInterpolation - MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val) - CLASS(ElemshapeData_), INTENT(IN) :: obj - TYPE(FEVariable_), INTENT(INOUT) :: interpol +INTERFACE + MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: ans TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE master_getInterpolation_1 -END INTERFACE GetInterpolation + END SUBROUTINE GetInterpolation_2 +END INTERFACE + +INTERFACE GetInterpolation_ + MODULE PROCEDURE GetInterpolation_2 +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! getInterpolation@InterpolMethods +! GetInterpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 +! date: 2025-09-01 ! summary: returns the interpolation of a FEVariable ! !# Introduction ! -! - Returns the interpolation of a [[fevariable_]] -! - The result is returned in interpol -! - interpol is a FEVariable -! - The rank of interpol is same as the rank of val -! - interpol is defined on Quadrature, that is, interpol is QuadratureVariable +! - Returns the interpolation of a FEVariable_ +! - The result is returned in ans +! - ans is a FEVariable +! - The rank of ans is same as the rank of val +! - ans is defined on Quadrature, that is, ans is QuadratureVariable ! ! - The val can have following ranks; scalar, vector, matrix ! - the val can be defined on quadrature (do nothing) or nodal (interpol) ! - The `vartype` of val can be constant, space, time, spacetime -! -INTERFACE 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 GetInterpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This function returns the interpolation of a scalar - -INTERFACE Interpolation - MODULE PURE FUNCTION scalar_interpolation_1(obj, val) RESULT(interpol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:) - REAL(DFP), ALLOCATABLE :: interpol(:) - END FUNCTION scalar_interpolation_1 -END INTERFACE Interpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This function returns the interpolation of vector INTERFACE - MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(interpol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - REAL(DFP), ALLOCATABLE :: interpol(:, :) - END FUNCTION vector_interpolation_1 -END INTERFACE - -INTERFACE Interpolation - MODULE PROCEDURE vector_interpolation_1 -END INTERFACE Interpolation - -!---------------------------------------------------------------------------- -! Interpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 4 March 2021 -! summary: This function returns the interpolation of matrix - -INTERFACE - MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(interpol) - CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - REAL(DFP), ALLOCATABLE :: interpol(:, :, :) - END FUNCTION matrix_interpolation_1 + MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(INOUT) :: ans + TYPE(FEVariable_), INTENT(IN) :: val + REAL(DFP), INTENT(IN) :: scale + LOGICAL, INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_2a END INTERFACE -INTERFACE Interpolation - MODULE PROCEDURE matrix_interpolation_1 -END INTERFACE Interpolation +INTERFACE GetInterpolation_ + MODULE PROCEDURE GetInterpolation_2a +END INTERFACE GetInterpolation_ !---------------------------------------------------------------------------- -! Interpolation@InterpolMethods +! Interpolation@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -773,97 +251,15 @@ END FUNCTION matrix_interpolation_1 ! summary: Interpolation of FEVariable INTERFACE - MODULE PURE FUNCTION master_interpolation_1(obj, val) RESULT(Ans) + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: obj TYPE(FEVariable_), INTENT(IN) :: val TYPE(FEVariable_) :: ans - END FUNCTION master_interpolation_1 + END FUNCTION Interpolation1 END INTERFACE INTERFACE Interpolation - MODULE PROCEDURE master_interpolation_1 + MODULE PROCEDURE Interpolation1 END INTERFACE Interpolation -!---------------------------------------------------------------------------- -! STInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-11-23 -! update: 2021-11-23 -! summary: This function performs interpolations of scalar -! -!# Introduction -! -! This function performs interpolation of a scalar from its space-time nodal -! values. -! -! $$u=u^{a}_{I}N^{I}T_{a}$$ - -INTERFACE - MODULE PURE FUNCTION scalar_stinterpolation_1(obj, val) RESULT(interpol) - CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :) - !! space-time nodal values of scalar - REAL(DFP), ALLOCATABLE :: interpol(:) - !! Interpolation value of `val` at integration points - END FUNCTION scalar_stinterpolation_1 -END INTERFACE - -INTERFACE STInterpolation - MODULE PROCEDURE scalar_stinterpolation_1 -END INTERFACE STInterpolation - -!---------------------------------------------------------------------------- -! STInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -INTERFACE -!! This function performs interpolations of vector - -!> author: Dr. Vikas Sharma -! -! This function performs interpolation of a vector from its space-time nodal -! values. -! $$u=u^{a}_{I}N^{I}T_{a}$$ - - MODULE PURE FUNCTION vector_stinterpolation_1(obj, val) RESULT(interpol) - CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :) - !! spatial nodal values of vector - REAL(DFP), ALLOCATABLE :: interpol(:, :) - !! Interpolation value of vector - END FUNCTION vector_stinterpolation_1 -END INTERFACE - -INTERFACE STInterpolation - MODULE PROCEDURE vector_stinterpolation_1 -END INTERFACE STInterpolation - -!---------------------------------------------------------------------------- -! STInterpolation@InterpolMethods -!---------------------------------------------------------------------------- - -INTERFACE -!! This function performs interpolations of matrix - -!> author: Dr. Vikas Sharma -! -! This function performs interpolation of a matrix from its space-time nodal -! values. -! $$u=u^{a}_{I}N^{I}T_{a}$$ - - MODULE PURE FUNCTION matrix_stinterpolation_1(obj, val) RESULT(interpol) - CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(IN) :: val(:, :, :, :) - !! spatial nodal values of matrix - REAL(DFP), ALLOCATABLE :: interpol(:, :, :) - !! Interpolation value of matrix - END FUNCTION matrix_stinterpolation_1 -END INTERFACE - -INTERFACE STInterpolation - MODULE PROCEDURE matrix_stinterpolation_1 -END INTERFACE STInterpolation - END MODULE ElemshapeData_InterpolMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 index 9e35d13e3..97d3e5b90 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 @@ -28,6 +28,7 @@ MODULE ElemshapeData_Lagrange PRIVATE PUBLIC :: LagrangeElemShapeData +PUBLIC :: LagrangeFacetElemShapeData PUBLIC :: Initiate !---------------------------------------------------------------------------- @@ -40,8 +41,10 @@ MODULE ElemshapeData_Lagrange INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, & - elemType, refelemCoord, domainName, order, ipType, basisType, & - coeff, firstCall, alpha, beta, lambda) + elemType, refelemCoord, & + domainName, order, ipType, & + basisType, coeff, firstCall, & + alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj !! element shape data TYPE(QuadraturePoint_), INTENT(IN) :: quad @@ -85,7 +88,8 @@ END SUBROUTINE LagrangeElemShapeData1 INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData2(obj, quad, refelem, order, & - ipType, basisType, coeff, firstCall, alpha, beta, lambda) + ipType, basisType, coeff, & + firstCall, alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj TYPE(QuadraturePoint_), INTENT(IN) :: quad CLASS(ReferenceElement_), INTENT(IN) :: refelem @@ -113,7 +117,8 @@ END SUBROUTINE LagrangeElemShapeData2 INTERFACE LagrangeElemShapeData MODULE SUBROUTINE LagrangeElemShapeData3(obj, quad, refelem, baseContinuity, & - baseInterpolation, order, ipType, basisType, coeff, firstCall, & + baseInterpolation, order, ipType, & + basisType, coeff, firstCall, & alpha, beta, lambda) CLASS(ElemshapeData_), INTENT(INOUT) :: obj TYPE(QuadraturePoint_), INTENT(IN) :: quad @@ -141,4 +146,56 @@ END SUBROUTINE LagrangeElemShapeData3 MODULE PROCEDURE LagrangeElemShapeData3 END INTERFACE Initiate +!---------------------------------------------------------------------------- +! LagrangeFacetElemShapeData@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-16 +! summary: This routine initiate the shape data + +INTERFACE LagrangeFacetElemShapeData + MODULE SUBROUTINE LagrangeFacetElemShapeData1( & + obj, facetElemsd, quad, facetQuad, localFaceNumber, nsd, xidim, & + elemType, refelemCoord, domainName, order, ipType, basisType, coeff, & + firstCall, alpha, beta, lambda) + CLASS(ElemshapeData_), INTENT(INOUT) :: obj + !! element shape data + CLASS(ElemshapeData_), INTENT(INOUT) :: facetElemsd + !! facet element shape data + TYPE(QuadraturePoint_), INTENT(IN) :: quad + !! quadrature point + TYPE(QuadraturePoint_), INTENT(IN) :: facetQuad + !! quadrature point on local facet + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(IN) :: nsd + !! number of spatial dimension + INTEGER(I4B), INTENT(IN) :: xidim + !! dimension of xi + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + REAL(DFP), INTENT(IN) :: refelemCoord(:, :) + !! coordinate of reference element + CHARACTER(*), INTENT(IN) :: domainName + !! name of reference element domain + INTEGER(I4B), INTENT(IN) :: order + !! order of interpolation + INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType + !! Interpolation point type + !! Default value is Equidistance + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Basis function types + !! Default value is Monomial + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is false, then coeff will be used + !! Default value of firstCall is True + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda + !! Jacobi parameter and Ultra-spherical parameter + END SUBROUTINE LagrangeFacetElemShapeData1 +END INTERFACE LagrangeFacetElemShapeData + END MODULE ElemshapeData_Lagrange diff --git a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 new file mode 100644 index 000000000..e8b867966 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 @@ -0,0 +1,411 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +! This file contains the interpolation methods interfaces\ + +MODULE ElemshapeData_MatrixInterpolMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetInterpolation +PUBLIC :: GetInterpolation_ +PUBLIC :: Interpolation +PUBLIC :: STInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of matrix + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! interpolation of matrix + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! nodal value of matrix + END SUBROUTINE GetInterpolation1 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, & + dim1, dim2, dim3, scale, & + addContribution) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_1a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of matrix +! +!# Introduction +! +! This subroutine performs interpolation of matrix from its space-time +! nodal values + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal value of matrix + END SUBROUTINE GetInterpolation2 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, & + dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, & + dim1, dim2, dim3, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_2a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of matrix +! +!# Introduction +! +! This subroutine performs interpolation of matrix from its space-time +! nodal values + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :, :) + !! space-time interpolation + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal value of matrix + END SUBROUTINE GetInterpolation3 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of matrix +! +!# Introduction +! +! This subroutine performs interpolation of matrix from its space-time +! nodal values + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, dim1, dim2, & + dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + !! space-time interpolation + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal value of matrix + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + !! size of data written in ans + END SUBROUTINE GetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of matrix +! +!# Introduction +! +! This subroutine performs interpolation of matrix from its space-time +! nodal values + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, dim1, dim2, & + dim3, dim4, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + !! space-time interpolation + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! space-time nodal value of matrix + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + !! size of data written in ans + REAL(DFP), INTENT(IN) :: scale + !! scaling factor + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_3a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of matrix FEVariable +! +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! interpolation of matrix + TYPE(FEVariable_), INTENT(IN) :: val + !! matrix fe variable + END SUBROUTINE GetInterpolation4 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetInterpolation_4 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-04 +! summary: Get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, & + dim1, dim2, dim3, scale, & + addContribution, timeIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + INTEGER(I4B), INTENT(IN), OPTIONAL :: timeIndx + END SUBROUTINE GetInterpolation_4a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4b(obj, ans, val, & + nrow, ncol, scale, & + addContribution, spaceIndx, & + timeIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + INTEGER(I4B), INTENT(IN) :: timeIndx, spaceIndx + END SUBROUTINE GetInterpolation_4b +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + !! space-time interpolation of matrix + TYPE(FEVariable_), INTENT(IN) :: val + !! matrix fe variable + END SUBROUTINE GetInterpolation5 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, & + dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE GetInterpolation_5 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: get interpolation of matrix without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, & + dim1, dim2, dim3, dim4, & + scale, addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_5a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! Interpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This function returns the interpolation of matrix + +INTERFACE + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + END FUNCTION Interpolation1 +END INTERFACE + +INTERFACE Interpolation + MODULE PROCEDURE Interpolation1 +END INTERFACE Interpolation + +!---------------------------------------------------------------------------- +! STInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: This function performs interpolations of matrix +! +!!# Introduction +! +! This function performs interpolation of a matrix from its space-time nodal +! values. +! $$u=u^{a}_{I}N^{I}T_{a}$$ + +INTERFACE + + MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + !! spatial nodal values of matrix + REAL(DFP), ALLOCATABLE :: ans(:, :, :) + !! Interpolation value of matrix + END FUNCTION STInterpolation1 +END INTERFACE + +INTERFACE STInterpolation + MODULE PROCEDURE STInterpolation1 +END INTERFACE STInterpolation + +END MODULE ElemshapeData_MatrixInterpolMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 index 841d55eda..9d1e6e6c0 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 @@ -33,7 +33,12 @@ MODULE ElemshapeData_Method USE ElemshapeData_HRQIParamMethods USE ElemshapeData_HminHmaxMethods USE ElemshapeData_IOMethods + USE ElemshapeData_InterpolMethods +USE ElemshapeData_ScalarInterpolMethods +USE ElemshapeData_VectorInterpolMethods +USE ElemshapeData_MatrixInterpolMethods + USE ElemshapeData_LocalDivergenceMethods USE ElemshapeData_LocalGradientMethods USE ElemshapeData_ProjectionMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 index 0f71ae33b..4ea20281e 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 @@ -16,19 +16,19 @@ ! MODULE ElemshapeData_ProjectionMethods -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_, & + FEVariableVector_ +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE PRIVATE -PUBLIC :: getProjectionOfdNdXt -PUBLIC :: getProjectionOfdNdXt_ -PUBLIC :: getProjectionOfdNTdXt -! TODO: implement -! PUBLIC :: getProjectionOfdNTdXt_ +PUBLIC :: GetProjectionOfdNdXt +PUBLIC :: GetProjectionOfdNdXt_ +PUBLIC :: GetProjectionOfdNTdXt +PUBLIC :: GetProjectionOfdNTdXt_ !---------------------------------------------------------------------------- -! getProjectionOfdNdXt@ProjectionMethods +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -43,35 +43,43 @@ MODULE ElemshapeData_ProjectionMethods ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt_1(obj, c, ans) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :) - !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ - REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), INTENT(IN) :: c(:) !! constant value of vector - END SUBROUTINE getProjectionOfdNdXt_1 + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNdXt_1 +END INTERFACE + +INTERFACE GetProjectionOfdNdXt + MODULE PROCEDURE GetProjectionOfdNdXt_1 END INTERFACE GetProjectionOfdNdXt !---------------------------------------------------------------------------- -! +! 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) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt1_(obj, c, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) - REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE getProjectionOfdNdXt1_ + END SUBROUTINE GetProjectionOfdNdXt1_ +END INTERFACE + +INTERFACE GetProjectionOfdNdXt_ + MODULE PROCEDURE GetProjectionOfdNdXt1_ END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- -! getProjectionOfdNdXt@getMethod +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -86,28 +94,40 @@ END SUBROUTINE getProjectionOfdNdXt1_ ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt_2(obj, c, crank, ans) CLASS(ElemshapeData_), INTENT(IN) :: obj !! ElemshapeData object - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :) - !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ - CLASS(FEVariable_), INTENT(IN) :: val + CLASS(FEVariable_), INTENT(IN) :: c !! FEVariable vector - END SUBROUTINE getProjectionOfdNdXt_2 + TYPE(FEVariableVector_), INTENT(IN) :: crank + !! rank of c should be vector + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNdXt_2 +END INTERFACE + +INTERFACE GetProjectionOfdNdXt + MODULE PROCEDURE GetProjectionOfdNdXt_2 END INTERFACE GetProjectionOfdNdXt !---------------------------------------------------------------------------- -! +! GetProjectionofdNdXt_ !---------------------------------------------------------------------------- -INTERFACE GetProjectionOfdNdXt_ - MODULE PURE SUBROUTINE getProjectionOfdNdXt2_(obj, cdNdXt, val, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt2_(obj, c, crank, ans, nrow, & + ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) - CLASS(FEVariable_), INTENT(IN) :: val + CLASS(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE getProjectionOfdNdXt2_ + END SUBROUTINE GetProjectionOfdNdXt2_ +END INTERFACE + +INTERFACE GetProjectionOfdNdXt_ + MODULE PROCEDURE GetProjectionOfdNdXt2_ END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- @@ -126,15 +146,19 @@ END SUBROUTINE getProjectionOfdNdXt2_ ! ! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$ -INTERFACE GetProjectionOfdNdXt - MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt_3(obj, c, ans) CLASS(ElemshapeData_), INTENT(IN) :: obj !! ElemshapeData object - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :) - !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ - REAL(DFP), INTENT(IN) :: val(:, :) + REAL(DFP), INTENT(IN) :: c(:, :) !! a vector, defined over quadrature points - END SUBROUTINE getProjectionOfdNdXt_3 + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNdXt_3 +END INTERFACE + +INTERFACE GetProjectionOfdNdXt + MODULE PROCEDURE GetProjectionOfdNdXt_3 END INTERFACE GetProjectionOfdNdXt !---------------------------------------------------------------------------- @@ -145,13 +169,18 @@ END SUBROUTINE getProjectionOfdNdXt_3 ! date: 2025-03-05 ! summary: get interpolation of vector without allocation -INTERFACE GetProjectionOfdNdXt_ - MODULE PURE SUBROUTINE getProjectionOfdNdXt3_(obj, cdNdXt, val, nrow, ncol) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNdXt3_(obj, c, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: obj - REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :) - REAL(DFP), INTENT(IN) :: val(:, :) + REAL(DFP), INTENT(IN) :: c(:, :) + !! a vector, defined over quadrature points + REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE getProjectionOfdNdXt3_ + END SUBROUTINE GetProjectionOfdNdXt3_ +END INTERFACE + +INTERFACE GetProjectionOfdNdXt_ + MODULE PROCEDURE GetProjectionOfdNdXt3_ END INTERFACE GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- @@ -168,16 +197,50 @@ END SUBROUTINE getProjectionOfdNdXt3_ ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -INTERFACE GetProjectionOfdNTdXt - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val) +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_1(obj, c, ans) CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :) - !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ - REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), INTENT(IN) :: c(:) !! constant value of vector - END SUBROUTINE getProjectionOfdNTdXt_1 + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNTdXt_1 +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt + MODULE PROCEDURE GetProjectionOfdNdXt_1 END INTERFACE GetProjectionOfdNTdXt +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-23 +! update: 2021-11-23 +! summary: Computes the projection of dNTdXt on a vector +! +! This subroutine computes the projcetion cdNTdXt on the vector `val` +! Here the vector `val` is constant in space and time +! +! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt1_(obj, c, ans, dim1, dim2, & + dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: c(:) + !! constant value of vector + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetProjectionOfdNTdXt1_ +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt_ + MODULE PROCEDURE GetProjectionOfdNTdXt1_ +END INTERFACE GetProjectionOfdNTdXt_ + !---------------------------------------------------------------------------- ! getProjectionOfdNTdXt@getMethod !---------------------------------------------------------------------------- @@ -197,19 +260,45 @@ END SUBROUTINE getProjectionOfdNTdXt_1 ! - It can vary in space and time domain ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -! -INTERFACE GetProjectionOfdNTdXt - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val) + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_2(obj, c, crank, ans) CLASS(STElemshapeData_), INTENT(IN) :: obj - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :) - !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ - TYPE(FEVariable_), INTENT(IN) :: val + TYPE(FEVariable_), INTENT(IN) :: c !! constant value of vector - END SUBROUTINE getProjectionOfdNTdXt_2 + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ + END SUBROUTINE GetProjectionOfdNTdXt_2 +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt + MODULE PROCEDURE GetProjectionOfdNTdXt_2 END INTERFACE GetProjectionOfdNTdXt !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt@getMethod +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt2_(obj, c, crank, ans, & + dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj + TYPE(FEVariable_), INTENT(IN) :: c + !! constant value of vector + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$ + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetProjectionOfdNTdXt2_ +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt_ + MODULE PROCEDURE GetProjectionOfdNTdXt2_ +END INTERFACE GetProjectionOfdNTdXt_ + +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt@getMethod !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -228,13 +317,57 @@ END SUBROUTINE getProjectionOfdNTdXt_2 ! - It can vary in space and time domain ! ! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$ -! -INTERFACE GetProjectionOfdNTdXt - MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val) + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_3(obj, c, crank, ans) CLASS(STElemshapeData_), INTENT(IN) :: obj(:) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :, :) - TYPE(FEVariable_), INTENT(IN) :: val - END SUBROUTINE getProjectionOfdNTdXt_3 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :) + END SUBROUTINE GetProjectionOfdNTdXt_3 +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt + MODULE PROCEDURE GetProjectionOfdNTdXt_3 END INTERFACE GetProjectionOfdNTdXt +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt3_(obj, c, crank, ans, & + dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE GetProjectionOfdNTdXt3_ +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt_ + MODULE PROCEDURE GetProjectionOfdNTdXt3_ +END INTERFACE GetProjectionOfdNTdXt_ + +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE GetProjectionOfdNTdXt4_( & + obj, c, crank, ans, nrow, ncol, ips, ipt) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + INTEGER(I4B), INTENT(IN) :: ips, ipt + END SUBROUTINE GetProjectionOfdNTdXt4_ +END INTERFACE + +INTERFACE GetProjectionOfdNTdXt_ + MODULE PROCEDURE GetProjectionOfdNTdXt4_ +END INTERFACE GetProjectionOfdNTdXt_ + END MODULE ElemshapeData_ProjectionMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 new file mode 100644 index 000000000..4c967af73 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 @@ -0,0 +1,449 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +! This file contains the interpolation methods interfaces\ + +MODULE ElemshapeData_ScalarInterpolMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetInterpolation +PUBLIC :: GetInterpolation_ +PUBLIC :: Interpolation +PUBLIC :: STInterpolation + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolations of scalar +! +!# Introduction +! +! This subroutine performs interpolation of a scalar from its spatial nodal +! values. +! +! $$u=u_{I}N^{I}$$ +! +! - TODO Make it work when the size of val is not the same as NNS + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) + CLASS(ElemShapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:) + !! Interpolation value of of scalar + REAL(DFP), INTENT(IN) :: val(:) + !! spatial nodal values of scalar + END SUBROUTINE GetInterpolation1 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, tsize) + CLASS(ElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, & + tsize, scale, & + addContribution) + CLASS(ElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_1a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolations of scalar nodal values +! +!# Introduction +! +! This subroutine performs interpolation of a scalar from its space-time nodal +! values. +! +! $$u=u^{a}_{I}N^{I}T_{a}$$ +! +! The resultant represents the interpolation value of `val` at +! spatial-quadrature points + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) + CLASS(STElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:) + !! Interpolation of scalar + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time nodal values of scalar + !! val(I,a) where I is the node number and a is the time level + END SUBROUTINE GetInterpolation2 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of space-time nodal values at a single time +! +!# Introduction +! +! This method is like GetInterpolation_2 but without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, tsize) + CLASS(STElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of space-time nodal values at a single time +! +!# Introduction +! +! This method is like GetInterpolation_2 but without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, & + tsize, scale, & + addContribution) + CLASS(STElemShapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: tsize + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_2a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolations of scalar nodal values +! +!# Introduction +! +! This subroutine performs interpolation of a scalar from its space-time nodal +! values. +! +! $$u=u^{a}_{I}N^{I}T_{a}$$ +! +! The resultant represents the interpolation value of `val` at +! spatial-temporal quadrature points + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :) + !! space-time Interpolation of scalar + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time nodal values of scalar + END SUBROUTINE GetInterpolation3 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: Get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, & + nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE GetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, & + nrow, ncol, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_3a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of scalar FEVariable +! +!# Introduction +! +! Returns the interpolation of scalar variable +! The scalar variable can be+ +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +!@note +!This routine calls [[Interpolation]] function from the same module. +!@endnote + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:) + !! interpolation of scalar + TYPE(FEVariable_), INTENT(IN) :: val + !! Scalar FE variable + END SUBROUTINE GetInterpolation4 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, tsize) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE GetInterpolation_4 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, tsize, & + scale, addContribution, timeIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: tsize + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + INTEGER(I4B), OPTIONAL, INTENT(IN) :: timeIndx + END SUBROUTINE GetInterpolation_4a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-03 +! summary: Get Interpolation of scalar variable at a single space +! and time integration point + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4b(obj, ans, val, scale, & + addContribution, timeIndx, & + spaceIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans + TYPE(FEVariable_), INTENT(IN) :: val + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + INTEGER(I4B), INTENT(IN) :: timeIndx + INTEGER(I4B), INTENT(IN) :: spaceIndx + END SUBROUTINE GetInterpolation_4b +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! getInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolations of scalar FEVariable +! +!# Introduction +! +! This subroutine performs interpolation of a scalar [[FEVariable_]] +! The FE Variable can be a +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +! $$u=u^{a}_{I}N^{I}T_{a}$$ +! +! The resultant represents the interpolation value of `val` at +! spatial-quadrature points + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! space-time interpolation of scalar + TYPE(FEVariable_), INTENT(IN) :: val + !! scalar FE variable + END SUBROUTINE GetInterpolation5 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, & + nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE GetInterpolation_5 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, & + nrow, ncol, scale, & + addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_5a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! Interpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This function returns the interpolation of a scalar + +INTERFACE Interpolation + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:) + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION Interpolation1 +END INTERFACE Interpolation + +!---------------------------------------------------------------------------- +! STInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-23 +! update: 2021-11-23 +! summary: This function performs interpolations of scalar +! +!# Introduction +! +! This function performs interpolation of a scalar from its space-time nodal +! values. +! +! $$u=u^{a}_{I}N^{I}T_{a}$$ + +INTERFACE + MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + !! space-time nodal values of scalar + REAL(DFP), ALLOCATABLE :: ans(:) + !! Interpolation value of `val` at integration points + END FUNCTION STInterpolation1 +END INTERFACE + +INTERFACE STInterpolation + MODULE PROCEDURE STInterpolation1 +END INTERFACE STInterpolation + +END MODULE ElemshapeData_ScalarInterpolMethods diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 index fb8531e84..40d6a8b0c 100644 --- a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 +++ b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 @@ -388,12 +388,17 @@ END SUBROUTINE elemsd_Set1 !@endnote INTERFACE Set - MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & - celldNdXi, facetN, facetdNdXi, facetNptrs) + MODULE PURE SUBROUTINE elemsd_Set2( & + facetobj, cellobj, cellval, facetval, cellN, celldNdXi, facetN, & + facetdNdXi) CLASS(ElemshapeData_), INTENT(INOUT) :: facetobj + !! facet element shape data CLASS(ElemshapeData_), INTENT(INOUT) :: cellobj + !! cell element shape data REAL(DFP), INTENT(IN) :: cellval(:, :) !! Spatial nodal coordinates of cell + REAL(DFP), INTENT(IN) :: facetval(:, :) + !! Spatial nodal coordinates of facet element REAL(DFP), INTENT(IN) :: cellN(:, :) !! shape function for cell REAL(DFP), INTENT(IN) :: facetN(:, :) @@ -401,7 +406,6 @@ MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, & REAL(DFP), INTENT(IN) :: celldNdXi(:, :, :) REAL(DFP), INTENT(IN) :: facetdNdXi(:, :, :) !! Local derivative of shape functions for geometry - INTEGER(I4B), INTENT(IN) :: facetNptrs(:) END SUBROUTINE elemsd_Set2 END INTERFACE Set @@ -419,22 +423,10 @@ END SUBROUTINE elemsd_Set2 INTERFACE Set MODULE PURE SUBROUTINE elemsd_Set3( & - & masterFacetobj, & - & masterCellobj, & - & masterCellval, & - & masterCellN, & - & masterCelldNdXi, & - & masterFacetN, & - & masterFacetdNdXi, & - & masterFacetNptrs, & - & slaveFacetobj, & - & slaveCellobj, & - & slaveCellval, & - & slaveCellN, & - & slaveCelldNdXi, & - & slaveFacetN, & - & slaveFacetdNdXi, & - & slaveFacetNptrs) + masterFacetobj, masterCellobj, masterCellval, masterCellN, & + masterCelldNdXi, masterFacetN, masterFacetdNdXi, masterFacetVal, & + slaveFacetobj, slaveCellobj, slaveCellval, slaveCellN, slaveCelldNdXi, & + slaveFacetN, slaveFacetdNdXi, slaveFacetVal) CLASS(ElemshapeData_), INTENT(INOUT) :: masterFacetobj CLASS(ElemshapeData_), INTENT(INOUT) :: masterCellobj REAL(DFP), INTENT(IN) :: masterCellval(:, :) @@ -448,8 +440,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( & REAL(DFP), INTENT(IN) :: masterFacetdNdXi(:, :, :) !! Local gradient of shape functions for geometry of !! facet element of master cell - INTEGER(I4B), INTENT(IN) :: masterFacetNptrs(:) - !! + REAL(DFP), INTENT(IN) :: masterFacetVal(:, :) + !! master facet xij CLASS(ElemshapeData_), INTENT(INOUT) :: slaveFacetobj !! Shape function data for facet element of slave cell CLASS(ElemshapeData_), INTENT(INOUT) :: slaveCellobj @@ -466,7 +458,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( & REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :) !! Local derivative of shape function for geometry of facet element !! of slave - INTEGER(I4B), INTENT(IN) :: slaveFacetNptrs(:) + REAL(DFP), INTENT(IN) :: slaveFacetVal(:, :) + !! slave facet xij END SUBROUTINE elemsd_Set3 END INTERFACE Set diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 new file mode 100644 index 000000000..625b58020 --- /dev/null +++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 @@ -0,0 +1,420 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! +! +! This file contains the interpolation methods interfaces\ + +MODULE ElemshapeData_VectorInterpolMethods +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_ +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetInterpolation +PUBLIC :: GetInterpolation_ +PUBLIC :: Interpolation +PUBLIC :: STInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This subroutine performs interpolation of a vector +! +!# Introduction +! +! This subroutine performs interpolation of a vector from its spatial +! nodal values +! +! $$u_{i}=u_{iI}N^{I}$$ + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! interpolation of vector + REAL(DFP), INTENT(IN) :: val(:, :) + !! nodal values of vector in `xiJ` format + END SUBROUTINE GetInterpolation1 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE GetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, nrow, ncol, & + scale, addContribution) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_1a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of a vector +! +!# Introduction +! +! This subroutine performs interpolation of a vector from its space-time +! nodal values +! +! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :) + !! + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE GetInterpolation2 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-03 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE GetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, nrow, ncol, & + scale, addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_2a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 1 Nov 2021 +! summary: This subroutine performs interpolation of a vector +! +!# Introduction +! +! This subroutine performs interpolation of a vector from its space-time +! nodal values +! +! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$ + +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :) + !! + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! space-time nodal values of vector in `xiJa` format + END SUBROUTINE GetInterpolation3 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, dim1, dim2, & + dim3, scale, addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_3a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of vector FEVariable +! +!# Introduction +! +! Returns the interpolation of vector variable +! The vector variable can be+ +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +! NOTE This routine calls [[Interpolation]] function from the same module. +! +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) + !! interpolation of vector + TYPE(FEVariable_), INTENT(IN) :: val + !! vector FEvariable + END SUBROUTINE GetInterpolation4 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE GetInterpolation_4 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, nrow, ncol, & + scale, addContribution, timeIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + INTEGER(I4B), OPTIONAL, INTENT(IN) :: timeIndx + END SUBROUTINE GetInterpolation_4a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_4b(obj, ans, val, tsize, & + scale, addContribution, & + timeIndx, spaceIndx) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: ans(:) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: tsize + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + END SUBROUTINE GetInterpolation_4b +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: returns the interpolation of vector FEVariable +! +!# Introduction +! +! Returns the interpolation of vector variable +! The vector variable can be+ +! +! - constant +! - spatial nodal values +! - spatial quadrature values +! - space-time nodal values +! +! NOTE This routine calls [[Interpolation]] function from the same module. +! +INTERFACE GetInterpolation + MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :) + !! space-time interpolation of vector + TYPE(FEVariable_), INTENT(IN) :: val + !! vector FEvariable + END SUBROUTINE GetInterpolation5 +END INTERFACE GetInterpolation + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE GetInterpolation_5 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-30 +! summary: get interpolation of vector without allocation + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, dim1, dim2, & + dim3, scale, addContribution) + CLASS(STElemshapeData_), INTENT(IN) :: obj(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + TYPE(FEVariable_), INTENT(IN) :: val + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE GetInterpolation_5a +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! Interpolation@InterpolMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 March 2021 +! summary: This function returns the interpolation of vector + +INTERFACE + MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION Interpolation1 +END INTERFACE + +INTERFACE Interpolation + MODULE PROCEDURE Interpolation1 +END INTERFACE Interpolation + +!---------------------------------------------------------------------------- +! STInterpolation@InterpolMethods +!---------------------------------------------------------------------------- + +INTERFACE +!! This function performs interpolations of vector + +!> author: Dr. Vikas Sharma +! +! This function performs interpolation of a vector from its space-time nodal +! values. +! $$u=u^{a}_{I}N^{I}T_{a}$$ + + MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + !! spatial nodal values of vector + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! Interpolation value of vector + END FUNCTION STInterpolation1 +END INTERFACE + +INTERFACE STInterpolation + MODULE PROCEDURE STInterpolation1 +END INTERFACE STInterpolation + +END MODULE ElemshapeData_VectorInterpolMethods diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90 index 09242bda0..0ce5c35fb 100644 --- a/src/modules/FACE/src/face.F90 +++ b/src/modules/FACE/src/face.F90 @@ -21,7 +21,7 @@ MODULE face #ifdef UCS4_SUPPORTED MODULE PROCEDURE colorize_ucs4 #endif -end interface +END INTERFACE ! kind parameters #ifdef ASCII_SUPPORTED @@ -119,7 +119,7 @@ SUBROUTINE colors_samples() colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))// & ' code: '//colorize(trim(COLORS_BG(2, c)), color_bg=COLORS_BG(1, c), style='inverse_on') END DO -end subroutine colors_samples +END SUBROUTINE colors_samples SUBROUTINE styles_samples() !< Print to standard output all styles samples. @@ -131,7 +131,7 @@ SUBROUTINE styles_samples() colorize(STYLES(1, s), style=STYLES(1, s))// & ' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on') END DO -end subroutine styles_samples +END SUBROUTINE styles_samples ! private procedures pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized) @@ -172,7 +172,7 @@ pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized colorized = colorized//buffer END IF END IF -end function colorize_ascii +END FUNCTION colorize_ascii pure function colorize_default(string, color_fg, color_bg, style) result(colorized) !< Colorize and stylize strings, DEFAULT kind. @@ -196,7 +196,7 @@ pure function colorize_default(string, color_fg, color_bg, style) result(coloriz i = style_index(upper(style)) if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR END IF -end function colorize_default +END FUNCTION colorize_default pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) !< Colorize and stylize strings, UCS4 kind. @@ -236,7 +236,7 @@ pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized) colorized = colorized//buffer END IF END IF -end function colorize_ucs4 +END FUNCTION colorize_ucs4 ELEMENTAL FUNCTION color_index(color) !< Return the array-index corresponding to the queried color. @@ -254,7 +254,7 @@ ELEMENTAL FUNCTION color_index(color) EXIT END IF END DO -end function color_index +END FUNCTION color_index ELEMENTAL FUNCTION style_index(style) !< Return the array-index corresponding to the queried style. @@ -269,7 +269,7 @@ ELEMENTAL FUNCTION style_index(style) EXIT END IF END DO -end function style_index +END FUNCTION style_index ELEMENTAL FUNCTION upper(string) !< Return a string with all uppercase characters. @@ -283,5 +283,5 @@ ELEMENTAL FUNCTION upper(string) n2 = INDEX(LOWER_ALPHABET, string(n1:n1)) IF (n2 > 0) upper(n1:n1) = UPPER_ALPHABET(n2:n2) END DO -end function upper +END FUNCTION upper endmodule face diff --git a/src/modules/FEVariable/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt index 2bf970d1a..2e1b0aede 100644 --- a/src/modules/FEVariable/CMakeLists.txt +++ b/src/modules/FEVariable/CMakeLists.txt @@ -1,13 +1,39 @@ -# This file is a part of easifem-base -# (c) 2021, Vikas Sharma, Ph.D. -# All right reserved +# This program is a part of EASIFEM library Expandable And Scalable +# Infrastructure for Finite Element Methods htttps://www.easifem.com Vikas +# Sharma, Ph.D., vickysharma0812@gmail.com +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -# log -# 16/02/2021 this file was created -#----------------------------------------------------------------------- -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FEVariable_Method.F90 -) \ No newline at end of file +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/FEVariable_Method.F90 + ${src_path}/FEVariable_AdditionMethod.F90 + ${src_path}/FEVariable_SubtractionMethod.F90 + ${src_path}/FEVariable_DivisionMethod.F90 + ${src_path}/FEVariable_MultiplicationMethod.F90 + ${src_path}/FEVariable_DotProductMethod.F90 + ${src_path}/FEVariable_ConstructorMethod.F90 + ${src_path}/FEVariable_QuadratureVariableMethod.F90 + ${src_path}/FEVariable_NodalVariableMethod.F90 + ${src_path}/FEVariable_UnaryMethod.F90 + ${src_path}/FEVariable_GetMethod.F90 + ${src_path}/FEVariable_InterpolationMethod.F90 + ${src_path}/FEVariable_ScalarInterpolationMethod.F90 + ${src_path}/FEVariable_VectorInterpolationMethod.F90 + ${src_path}/FEVariable_MatrixInterpolationMethod.F90 + ${src_path}/FEVariable_IOMethod.F90 + ${src_path}/FEVariable_MeanMethod.F90 + ${src_path}/FEVariable_SetMethod.F90) diff --git a/src/modules/FEVariable/src/FEVariable_AdditionMethod.F90 b/src/modules/FEVariable/src/FEVariable_AdditionMethod.F90 new file mode 100644 index 000000000..10add7673 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_AdditionMethod.F90 @@ -0,0 +1,87 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_AdditionMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: OPERATOR(+) + +!---------------------------------------------------------------------------- +! Addition@AdditioMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable + FEVariable + +INTERFACE OPERATOR(+) + MODULE PURE FUNCTION fevar_Addition1(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Addition1 +END INTERFACE OPERATOR(+) + +!---------------------------------------------------------------------------- +! Addition@AdditioMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable + Real + +INTERFACE OPERATOR(+) + MODULE PURE FUNCTION fevar_Addition2(obj1, val) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + REAL(DFP), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Addition2 +END INTERFACE OPERATOR(+) + +!---------------------------------------------------------------------------- +! Addition@AdditioMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = Real + FEVariable + +INTERFACE OPERATOR(+) + MODULE PURE FUNCTION fevar_Addition3(val, obj1) RESULT(ans) + REAL(DFP), INTENT(IN) :: val + CLASS(FEVariable_), INTENT(IN) :: obj1 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Addition3 +END INTERFACE OPERATOR(+) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_AdditionMethod diff --git a/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 new file mode 100644 index 000000000..cdd07b9e6 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 @@ -0,0 +1,117 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_ConstructorMethod +USE BaseType, ONLY: FEVariable_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: DEALLOCATE +PUBLIC :: ASSIGNMENT(=) +PUBLIC :: Copy +PUBLIC :: Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-02 +! summary: Initiate FEVariable + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate1(obj, s, defineon, vartype, rank, & + len, val) + TYPE(FEVariable_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: s(:) + !! shape of data + INTEGER(I4B), INTENT(IN) :: defineon + !! where is the data defined nodal or quadrature + INTEGER(I4B), INTENT(IN) :: vartype + !! variable type + INTEGER(I4B), INTENT(IN) :: rank + !! rank of the variable + INTEGER(I4B), INTENT(IN) :: len + !! length of data to be extractd from val + REAL(DFP), INTENT(IN) :: val(:) + !! The size of val should be atleast len + END SUBROUTINE obj_Initiate1 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Initiate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-02 +! summary: Initiate FEVariable + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_Initiate2(obj, s, defineon, vartype, rank, & + len) + TYPE(FEVariable_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: s(:) + !! shape of data + INTEGER(I4B), INTENT(IN) :: defineon + !! where is the data defined nodal or quadrature + INTEGER(I4B), INTENT(IN) :: vartype + !! variable type + INTEGER(I4B), INTENT(IN) :: rank + !! rank of the variable + INTEGER(I4B), INTENT(IN) :: len + !! length of data to be extractd from val + END SUBROUTINE obj_Initiate2 +END INTERFACE Initiate + +!---------------------------------------------------------------------------- +! Deallocate@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! summary: Deallocates the content of FEVariable + +INTERFACE DEALLOCATE + MODULE PURE SUBROUTINE obj_Deallocate(obj) + TYPE(FEVariable_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate +END INTERFACE DEALLOCATE + +!---------------------------------------------------------------------------- +! Assignment@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-13 +! summary: obj1 = obj2 + +INTERFACE ASSIGNMENT(=) + MODULE PURE SUBROUTINE obj_Copy(obj1, obj2) + TYPE(FEVariable_), INTENT(INOUT) :: obj1 + TYPE(FEVariable_), INTENT(IN) :: obj2 + END SUBROUTINE obj_Copy +END INTERFACE + +INTERFACE Copy + MODULE PROCEDURE obj_Copy +END INTERFACE Copy + +END MODULE FEVariable_ConstructorMethod diff --git a/src/modules/FEVariable/src/FEVariable_DivisionMethod.F90 b/src/modules/FEVariable/src/FEVariable_DivisionMethod.F90 new file mode 100644 index 000000000..3d342f346 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_DivisionMethod.F90 @@ -0,0 +1,87 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_DivisionMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: OPERATOR(/) + +!---------------------------------------------------------------------------- +! Division@DivisionMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = obj1 / obj2 + +INTERFACE OPERATOR(/) + MODULE PURE FUNCTION fevar_Division1(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Division1 +END INTERFACE OPERATOR(/) + +!---------------------------------------------------------------------------- +! Division@DivisionMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = obj1 / val + +INTERFACE OPERATOR(/) + MODULE PURE FUNCTION fevar_Division2(obj1, val) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + REAL(DFP), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Division2 +END INTERFACE OPERATOR(/) + +!---------------------------------------------------------------------------- +! Division@DivisionMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = val / obj1 + +INTERFACE OPERATOR(/) + MODULE PURE FUNCTION fevar_Division3(val, obj1) RESULT(ans) + REAL(DFP), INTENT(IN) :: val + CLASS(FEVariable_), INTENT(IN) :: obj1 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Division3 +END INTERFACE OPERATOR(/) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_DivisionMethod diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 similarity index 54% rename from src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 rename to src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 index 6cecc69f9..6964ed6b4 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 +++ b/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 @@ -13,52 +13,45 @@ ! ! 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 +MODULE FEVariable_DotProductMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE -CONTAINS +PRIVATE + +PUBLIC :: DOT_PRODUCT !---------------------------------------------------------------------------- -! Abs +! !---------------------------------------------------------------------------- -MODULE PROCEDURE fevar_Abs -SELECT CASE (obj%rank) +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! update: 2021-12-12 +! summary: FEVariable = FEVariable + FEVariable -CASE (scalar) -#include "./include/ScalarElemMethod.F90" - -CASE (vector) -#include "./include/VectorElemMethod.F90" - -CASE (matrix) -#include "./include/MatrixElemMethod.F90" - -END SELECT - -END PROCEDURE fevar_Abs +INTERFACE DOT_PRODUCT + MODULE PURE FUNCTION fevar_dot_product(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_dot_product +END INTERFACE DOT_PRODUCT !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -END SUBMODULE AbsMethods - -#undef _ELEM_METHOD_ +END MODULE FEVariable_DotProductMethod diff --git a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 new file mode 100644 index 000000000..fa7578bcd --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_GetMethod.F90 @@ -0,0 +1,744 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_GetMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: SIZE +PUBLIC :: SHAPE +PUBLIC :: GetShape +PUBLIC :: OPERATOR(.rank.) +PUBLIC :: GetRank +PUBLIC :: OPERATOR(.vartype.) +PUBLIC :: GetVarType +PUBLIC :: OPERATOR(.defineon.) +PUBLIC :: GetDefineOn +PUBLIC :: OPERATOR(.len.) +PUBLIC :: GetLen +PUBLIC :: isNodalVariable +PUBLIC :: isQuadratureVariable +PUBLIC :: FEVariable_ToChar +PUBLIC :: FEVariable_ToInteger +PUBLIC :: GetLambdaFromYoungsModulus +PUBLIC :: GetTotalShape + +PUBLIC :: Get +PUBLIC :: Get_ + +!---------------------------------------------------------------------------- +! GetLambdaFromYoungsModulus@SpecialMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-12-12 +! summary: Get lame parameter lambda from YoungsModulus + +INTERFACE GetLambdaFromYoungsModulus + MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus( & + youngsModulus, shearModulus, lambda) + TYPE(FEVariable_), INTENT(IN) :: youngsModulus, shearModulus + TYPE(FEVariable_), INTENT(INOUT) :: lambda + END SUBROUTINE fevar_GetLambdaFromYoungsModulus +END INTERFACE GetLambdaFromYoungsModulus + +!---------------------------------------------------------------------------- +! FEVariable_ToChar@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-07-01 +! summary: Converts scalar, vector, matrix to string name + +INTERFACE + MODULE PURE FUNCTION FEVariable_ToChar(name, isUpper) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: name + CHARACTER(:), ALLOCATABLE :: ans + LOGICAL(LGT), INTENT(IN), OPTIONAL :: isUpper + END FUNCTION FEVariable_ToChar +END INTERFACE + +!---------------------------------------------------------------------------- +! FEVariable_ToInteger@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-07-01 +! summary: Converts scalar, vector, matrix to string name + +INTERFACE + MODULE PURE FUNCTION FEVariable_ToInteger(name) RESULT(ans) + CHARACTER(*), INTENT(IN) :: name + INTEGER(I4B) :: ans + END FUNCTION FEVariable_ToInteger +END INTERFACE + +!---------------------------------------------------------------------------- +! SIZE@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-12 +! summary: Returns the size of variable +! +!# Introduction +! +! If dim is present then obj%s(dim) is returned. +! +! In this case be careful that dim is not out of bound. +! +! Scalar, constant => dim <=1 +! Scalar, space or time => dim <=1 +! Scalar, spaceTime => dim <=2 +! +! Vector, constant => dim <=1 +! Vector, space => dim <=2 +! Vector, time => dim <=2 +! Vector, spaceTime => dim <=3 +! +! Matrix, constant => dim <=2 +! Matrix, space => dim <=3 +! Matrix, time => dim <=3 +! Matrix, spaceTime => dim <=4 +! +! If dim is absent then following rule is followed +! +! For scalar, ans = 1 +! For vector, ans = obj%s(1) +! For matrix, and = obj%s(1) * obj%s(2) + +INTERFACE Size + MODULE PURE FUNCTION fevar_Size(obj, Dim) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B), OPTIONAL, INTENT(IN) :: Dim + INTEGER(I4B) :: ans + END FUNCTION fevar_Size +END INTERFACE Size + +!---------------------------------------------------------------------------- +! SHAPE@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-06-12 +! summary: Returns the shape of data +! +!# Introduction +! +! ans depends on the rank and vartype +! +!| rank | vartype | ans | +!| --- | --- | --- | +!| Scalar | Constant | [1] | +!| Scalar | Space, Time | [obj%s(1)] | +!| Scalar | SpaceTime | [obj%s(1), obj%s(2)] | +!| Vector | Constant | [obj%s(1)] | +!| Vector | Space, Time | [obj%s(1), obj%s(2)] | +!| Vector | SpaceTime | [obj%s(1), obj%s(2), obj%s(3)] | +!| Matrix | Constant | [obj%s(1), obj%s(2)] | +!| Matrix | Space, Time | [obj%s(1), obj%s(2), obj%s(3)] | +!| Matrix | SpaceTime | [obj%s(1), obj%s(2), obj%s(3), obj%s(4)] | + +INTERFACE Shape + MODULE PURE FUNCTION fevar_Shape(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B), ALLOCATABLE :: ans(:) + END FUNCTION fevar_Shape +END INTERFACE Shape + +!---------------------------------------------------------------------------- +! GetShape@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-28 +! summary: Returns the shape of data + +INTERFACE GetShape + MODULE PURE SUBROUTINE fevar_GetShape(obj, ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE fevar_GetShape +END INTERFACE GetShape + +!---------------------------------------------------------------------------- +! GetTotalShape@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-03 +! summary: Returns the total size of shape of data +! +!# Introduction +! +! ans depends on the rank and vartype +! +!| rank | vartype | ans | +!| --- | --- | --- | +!| Scalar | Constant | 1 | +!| Scalar | Space, Time | 1 | +!| Scalar | SpaceTime | 2 | +!| Vector | Constant | 1 | +!| Vector | Space, Time | 2 | +!| Vector | SpaceTime | 3 | +!| Matrix | Constant | 2 | +!| Matrix | Space, Time | 3 | +!| Matrix | SpaceTime | 4 | + +INTERFACE GetTotalShape + MODULE PURE FUNCTION fevar_GetTotalShape(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION fevar_GetTotalShape +END INTERFACE GetTotalShape + +!---------------------------------------------------------------------------- +! rank@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the rank of FEvariable + +INTERFACE OPERATOR(.RANK.) + MODULE PURE FUNCTION fevar_rank(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION fevar_rank +END INTERFACE OPERATOR(.RANK.) + +INTERFACE GetRank + MODULE PROCEDURE fevar_rank +END INTERFACE GetRank + +!---------------------------------------------------------------------------- +! vartype@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the vartype of FEvariable + +INTERFACE OPERATOR(.vartype.) + MODULE PURE FUNCTION fevar_vartype(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION fevar_vartype +END INTERFACE OPERATOR(.vartype.) + +INTERFACE GetVarType + MODULE PROCEDURE fevar_vartype +END INTERFACE GetVarType + +!---------------------------------------------------------------------------- +! defineon@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the defineon of FEvariable + +INTERFACE OPERATOR(.defineon.) + MODULE PURE FUNCTION fevar_defineon(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION fevar_defineon +END INTERFACE OPERATOR(.defineon.) + +INTERFACE GetDefineOn + MODULE PROCEDURE fevar_defineon +END INTERFACE GetDefineOn + +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! summary: Returns the defineon of FEvariable + +INTERFACE OPERATOR(.len.) + MODULE PURE FUNCTION fevar_len(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B) :: ans + END FUNCTION fevar_len +END INTERFACE OPERATOR(.len.) + +INTERFACE GetLen + MODULE PROCEDURE fevar_len +END INTERFACE GetLen + +!---------------------------------------------------------------------------- +! IsNodalVariable@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the defineon of FEvariable + +INTERFACE IsNodalVariable + MODULE PURE FUNCTION fevar_IsNodalVariable(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION fevar_IsNodalVariable +END INTERFACE IsNodalVariable + +!---------------------------------------------------------------------------- +! isQuadratureVariable@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-27 +! update: 2021-11-27 +! summary: Returns the defineon of FEvariable + +INTERFACE IsQuadratureVariable + MODULE PURE FUNCTION fevar_IsQuadratureVariable(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + LOGICAL(LGT) :: ans + END FUNCTION fevar_IsQuadratureVariable +END INTERFACE IsQuadratureVariable + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is scalar, constant + +INTERFACE Get + MODULE PURE FUNCTION Scalar_Constant(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP) :: val + END FUNCTION Scalar_Constant +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is scalar, space + +INTERFACE Get + MODULE PURE FUNCTION Scalar_Space(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:) + END FUNCTION Scalar_Space +END INTERFACE Get + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is scalar, space without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Scalar_Space_(obj, rank, vartype, val, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE Scalar_Space_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is scalar, time + +INTERFACE Get + MODULE PURE FUNCTION Scalar_Time(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:) + END FUNCTION Scalar_Time +END INTERFACE Get + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is scalar, time without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Scalar_Time_(obj, rank, vartype, val, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE Scalar_Time_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is scalar, SpaceTime + +INTERFACE Get + MODULE PURE FUNCTION Scalar_SpaceTime(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :) + END FUNCTION Scalar_SpaceTime +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is scalar, SpaceTime without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Scalar_SpaceTime_(obj, rank, vartype, val, & + nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Scalar_SpaceTime_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is vector, constant + +INTERFACE Get + MODULE PURE FUNCTION Vector_Constant(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:) + END FUNCTION Vector_Constant +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is vector, constant without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Vector_Constant_(obj, rank, vartype, val, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE Vector_Constant_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is vector, space + +INTERFACE Get + MODULE PURE FUNCTION Vector_Space(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :) + END FUNCTION Vector_Space +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is vector, space without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Vector_Space_(obj, rank, vartype, val, & + nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Vector_Space_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is vector, time + +INTERFACE Get + MODULE PURE FUNCTION Vector_Time(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :) + END FUNCTION Vector_Time +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is vector, time without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Vector_Time_(obj, rank, vartype, val, & + nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Vector_Time_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is vector, spaceTime + +INTERFACE Get + MODULE PURE FUNCTION Vector_SpaceTime(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :, :) + END FUNCTION Vector_SpaceTime +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is vector, spaceTime without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Vector_SpaceTime_(obj, rank, vartype, val, & + dim1, dim2, dim3) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE Vector_SpaceTime_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is Matrix, Constant + +INTERFACE Get + MODULE PURE FUNCTION Matrix_Constant(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :) + END FUNCTION Matrix_Constant +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is Matrix, Constant without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Matrix_Constant_(obj, rank, vartype, val, & + nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(inout) :: val(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE Matrix_Constant_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is Matrix, Space + +INTERFACE Get + MODULE PURE FUNCTION Matrix_Space(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :, :) + END FUNCTION Matrix_Space +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is Matrix, Space without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Matrix_Space_(obj, rank, vartype, val, & + dim1, dim2, dim3) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE Matrix_Space_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is Matrix, Time + +INTERFACE Get + MODULE PURE FUNCTION Matrix_Time(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :, :) + END FUNCTION Matrix_Time +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is Matrix, Time without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Matrix_Time_(obj, rank, vartype, val, & + dim1, dim2, dim3) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE Matrix_Time_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! Get@GetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2 Jan 2022 +! summary: Returns value which is Matrix, SpaceTime + +INTERFACE Get + MODULE PURE FUNCTION Matrix_SpaceTime(obj, rank, vartype) RESULT(val) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), ALLOCATABLE :: val(:, :, :, :) + END FUNCTION Matrix_SpaceTime +END INTERFACE Get + +!---------------------------------------------------------------------------- +! Get_@GetMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-03-04 +! summary: Returns value which is Matrix, SpaceTime without allocation + +INTERFACE Get_ + MODULE PURE SUBROUTINE Matrix_SpaceTime_(obj, rank, vartype, val, & + dim1, dim2, dim3, dim4) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(INOUT) :: val(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE Matrix_SpaceTime_ +END INTERFACE Get_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_GetMethod diff --git a/src/modules/FEVariable/src/FEVariable_IOMethod.F90 b/src/modules/FEVariable/src/FEVariable_IOMethod.F90 new file mode 100644 index 000000000..1c9bf063c --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_IOMethod.F90 @@ -0,0 +1,52 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_IOMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: Display + +!---------------------------------------------------------------------------- +! Display@IOMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Displays the content of [[FEVariable_]] + +INTERFACE Display + MODULE SUBROUTINE fevar_Display(obj, Msg, UnitNo) + TYPE(FEVariable_), INTENT(IN) :: obj + CHARACTER(*), INTENT(IN) :: Msg + INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo + END SUBROUTINE fevar_Display +END INTERFACE Display + +END MODULE FEVariable_IOMethod diff --git a/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 new file mode 100644 index 000000000..1d06938b2 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 @@ -0,0 +1,91 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_InterpolationMethod +USE BaseType, ONLY: FEVariable_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE FEVariableGetInterpolation_1( & + obj, N, nns, nips, scale, addContribution, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable_ format + !! Scalar, or Vector, or Matrix, Quadrature, Space + END SUBROUTINE FEVariableGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE FEVariableGetInterpolation_2( & + obj, N, nns, nips, T, nnt, scale, addContribution, timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + REAL(DFP), INTENT(IN) :: T(:) + !! shape functions data, T(I) : I is node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of nodes in N, bound for dim1 in N + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable_ format + END SUBROUTINE FEVariableGetInterpolation_2 +END INTERFACE GetInterpolation_ + +END MODULE FEVariable_InterpolationMethod diff --git a/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 new file mode 100644 index 000000000..d8a1955a7 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 @@ -0,0 +1,414 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_MatrixInterpolationMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE +PUBLIC :: GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, scale, addContribution, ans, dim1, & + dim2, dim3) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Interpolated value + !! Size of ans should be at least nips + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! Number of data written in ans + END SUBROUTINE MatrixConstantGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is for putting value in ans + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable + !! Matrix, Quadrature, Space + END SUBROUTINE MatrixConstantGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, & + ans, nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + END SUBROUTINE MatrixConstantGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixSpaceGetInterpolation_1(obj, rank, vartype, & + N, nns, nips, & + scale, & + addContribution, & + ans, dim1, dim2, dim3) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! Number of data written in ans + END SUBROUTINE MatrixSpaceGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixSpaceGetInterpolation_2(obj, rank, vartype, & + N, nns, nips, & + scale, & + addContribution, & + timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is for putting value in ans + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable + !! Size of ans should be at least nips + END SUBROUTINE MatrixSpaceGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixSpaceGetInterpolation_3(obj, rank, vartype, & + N, nns, spaceIndx, & + timeIndx, & + scale, & + addContribution, & + ans, nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + END SUBROUTINE MatrixSpaceGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_1(obj, rank, & + vartype, & + N, nns, nips, & + T, nnt, & + scale, & + addContribution, & + ans, dim1, dim2, & + dim3, timeIndx) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! Number of data written in ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is used when varType is spaceTime and defined on Quad + END SUBROUTINE MatrixSpaceTimeGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_2(obj, rank, & + vartype, & + N, nns, nips, & + T, nnt, & + scale, & + addContribution, & + timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is used when varType is spaceTime and defined on Quad + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable + END SUBROUTINE MatrixSpaceTimeGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_3(obj, rank, & + vartype, & + N, nns, & + spaceIndx, & + timeIndx, & + T, nnt, & + scale, & + addContribution, & + ans, nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + END SUBROUTINE MatrixSpaceTimeGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@MatrixInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Matrix, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE MatrixGetInterpolation_3( & + obj, rank, N, nns, spaceIndx, timeIndx, T, nnt, scale, addContribution, & + ans, nrow, ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + END SUBROUTINE MatrixGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_MatrixInterpolationMethod diff --git a/src/modules/FEVariable/src/FEVariable_MeanMethod.F90 b/src/modules/FEVariable/src/FEVariable_MeanMethod.F90 new file mode 100644 index 000000000..7162e187f --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_MeanMethod.F90 @@ -0,0 +1,99 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_MeanMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: MEAN + +!---------------------------------------------------------------------------- +! MEAN@MeanMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 May 2022 +! summary: FEVariable = Mean( obj ) + +INTERFACE MEAN + MODULE PURE FUNCTION fevar_Mean1(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Mean1 +END INTERFACE + +!---------------------------------------------------------------------------- +! MEAN@MeanMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 May 2022 +! summary: FEVariable = Mean( obj ) + +INTERFACE MEAN + MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: dataType + REAL(DFP) :: ans + END FUNCTION fevar_Mean2 +END INTERFACE + +!---------------------------------------------------------------------------- +! MEAN@MeanMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 May 2022 +! summary: FEVariable = Mean( obj ) + +INTERFACE MEAN + MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION fevar_Mean3 +END INTERFACE + +!---------------------------------------------------------------------------- +! MEAN@MeanMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 May 2022 +! summary: FEVariable = Mean( obj ) + +INTERFACE MEAN + MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableMatrix_), INTENT(IN) :: dataType + REAL(DFP), ALLOCATABLE :: ans(:, :) + END FUNCTION fevar_Mean4 +END INTERFACE + +END MODULE FEVariable_MeanMethod diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90 index 718aba242..a6dbabc49 100644 --- a/src/modules/FEVariable/src/FEVariable_Method.F90 +++ b/src/modules/FEVariable/src/FEVariable_Method.F90 @@ -15,1819 +15,21 @@ ! 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 :: 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is scalar, space without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Scalar_Space_(obj, rank, vartype, val, tsize) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE Scalar_Space_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is scalar, time - -INTERFACE Get - MODULE PURE FUNCTION Scalar_Time(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:) - END FUNCTION Scalar_Time -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is scalar, time without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Scalar_Time_(obj, rank, vartype, val, tsize) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE Scalar_Time_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is scalar, SpaceTime - -INTERFACE Get - MODULE PURE FUNCTION Scalar_SpaceTime(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :) - END FUNCTION Scalar_SpaceTime -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is scalar, SpaceTime without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Scalar_SpaceTime_(obj, rank, vartype, val, & - nrow, ncol) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableScalar_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE Scalar_SpaceTime_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is vector, constant - -INTERFACE Get - MODULE PURE FUNCTION Vector_Constant(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableConstant_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:) - END FUNCTION Vector_Constant -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is vector, constant without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Vector_Constant_(obj, rank, vartype, val, tsize) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableConstant_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:) - INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE Vector_Constant_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is vector, space - -INTERFACE Get - MODULE PURE FUNCTION Vector_Space(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :) - END FUNCTION Vector_Space -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is vector, space without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Vector_Space_(obj, rank, vartype, val, & - nrow, ncol) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE Vector_Space_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is vector, time - -INTERFACE Get - MODULE PURE FUNCTION Vector_Time(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :) - END FUNCTION Vector_Time -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is vector, time without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Vector_Time_(obj, rank, vartype, val, & - nrow, ncol) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE Vector_Time_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is vector, spaceTime - -INTERFACE Get - MODULE PURE FUNCTION Vector_SpaceTime(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :, :) - END FUNCTION Vector_SpaceTime -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is vector, spaceTime without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Vector_SpaceTime_(obj, rank, vartype, val, & - dim1, dim2, dim3) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE Vector_SpaceTime_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is Matrix, Constant - -INTERFACE Get - MODULE PURE FUNCTION Matrix_Constant(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableConstant_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :) - END FUNCTION Matrix_Constant -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is Matrix, Constant without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Matrix_Constant_(obj, rank, vartype, val, & - nrow, ncol) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableConstant_), INTENT(IN) :: vartype - REAL(DFP), INTENT(inout) :: val(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE Matrix_Constant_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is Matrix, Space - -INTERFACE Get - MODULE PURE FUNCTION Matrix_Space(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :, :) - END FUNCTION Matrix_Space -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is Matrix, Space without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Matrix_Space_(obj, rank, vartype, val, & - dim1, dim2, dim3) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpace_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE Matrix_Space_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is Matrix, Time - -INTERFACE Get - MODULE PURE FUNCTION Matrix_Time(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :, :) - END FUNCTION Matrix_Time -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is Matrix, Time without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Matrix_Time_(obj, rank, vartype, val, & - dim1, dim2, dim3) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - END SUBROUTINE Matrix_Time_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Get@GetMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2 Jan 2022 -! summary: Returns value which is Matrix, SpaceTime - -INTERFACE Get - MODULE PURE FUNCTION Matrix_SpaceTime(obj, rank, vartype) RESULT(val) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), ALLOCATABLE :: val(:, :, :, :) - END FUNCTION Matrix_SpaceTime -END INTERFACE Get - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Shion Shimizu -! date: 2025-03-04 -! summary: Returns value which is Matrix, SpaceTime without allocation - -INTERFACE Get_ - MODULE PURE SUBROUTINE Matrix_SpaceTime_(obj, rank, vartype, val, & - dim1, dim2, dim3, dim4) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: rank - TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype - REAL(DFP), INTENT(INOUT) :: val(:, :, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 - END SUBROUTINE Matrix_SpaceTime_ -END INTERFACE Get_ - -!---------------------------------------------------------------------------- -! Addition@AdditioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable + FEVariable - -INTERFACE OPERATOR(+) - MODULE PURE FUNCTION fevar_Addition1(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Addition1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Addition@AdditioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable + Real - -INTERFACE OPERATOR(+) - - MODULE PURE FUNCTION fevar_Addition2(obj1, val) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - REAL(DFP), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Addition2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Addition@AdditioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = Real + FEVariable - -INTERFACE OPERATOR(+) - MODULE PURE FUNCTION fevar_Addition3(val, obj1) RESULT(ans) - REAL(DFP), INTENT(IN) :: val - CLASS(FEVariable_), INTENT(IN) :: obj1 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Addition3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Substraction@SubstractioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable - FEVariable - -INTERFACE OPERATOR(-) - MODULE PURE FUNCTION fevar_Subtraction1(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Subtraction1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Substraction@SubstractioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable - RealVal - -INTERFACE OPERATOR(-) - MODULE PURE FUNCTION fevar_Subtraction2(obj1, val) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - REAL(DFP), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Subtraction2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Substraction@SubstractioMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = RealVal - FEVariable - -INTERFACE OPERATOR(-) - MODULE PURE FUNCTION fevar_Subtraction3(val, obj1) RESULT(ans) - REAL(DFP), INTENT(IN) :: val - CLASS(FEVariable_), INTENT(IN) :: obj1 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Subtraction3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Multiplication@MultiplicationMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-1 -! summary: FEVariable = FEVariable * FEVariable - -INTERFACE OPERATOR(*) - MODULE PURE FUNCTION fevar_Multiplication1(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Multiplication1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Multiplication@MultiplicationMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable * Real - -INTERFACE OPERATOR(*) - MODULE PURE FUNCTION fevar_Multiplication2(obj1, val) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - REAL(DFP), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Multiplication2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Multiplication@MultiplicationMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = Real * FEVariable - -INTERFACE OPERATOR(*) - MODULE PURE FUNCTION fevar_Multiplication3(val, obj1) RESULT(ans) - REAL(DFP), INTENT(IN) :: val - CLASS(FEVariable_), INTENT(IN) :: obj1 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Multiplication3 -END INTERFACE - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable + FEVariable - -INTERFACE ABS - MODULE PURE FUNCTION fevar_abs(obj) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariable_) :: ans - END FUNCTION fevar_abs -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable + FEVariable - -INTERFACE DOT_PRODUCT - MODULE PURE FUNCTION fevar_dot_product(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_dot_product -END INTERFACE - -!---------------------------------------------------------------------------- -! Division@DivisionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable - FEVariable - -INTERFACE OPERATOR(/) - MODULE PURE FUNCTION fevar_Division1(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Division1 -END INTERFACE - -!---------------------------------------------------------------------------- -! Division@DivisionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable - Real - -INTERFACE OPERATOR(/) - MODULE PURE FUNCTION fevar_Division2(obj1, val) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - REAL(DFP), INTENT(IN) :: val - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Division2 -END INTERFACE - -!---------------------------------------------------------------------------- -! Division@DivisionMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = Real - FEVariable - -INTERFACE OPERATOR(/) - MODULE PURE FUNCTION fevar_Division3(val, obj1) RESULT(ans) - REAL(DFP), INTENT(IN) :: val - CLASS(FEVariable_), INTENT(IN) :: obj1 - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Division3 -END INTERFACE - -!---------------------------------------------------------------------------- -! Power@PowerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable + FEVariable - -INTERFACE OPERATOR(**) - MODULE PURE FUNCTION fevar_power(obj, n) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN) :: n - TYPE(FEVariable_) :: ans - END FUNCTION fevar_power -END INTERFACE - -!---------------------------------------------------------------------------- -! Power@PowerMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = FEVariable + FEVariable - -INTERFACE SQRT - MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariable_) :: ans - END FUNCTION fevar_sqrt -END INTERFACE - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = NORM2(FEVariable) - -INTERFACE NORM2 - MODULE PURE FUNCTION fevar_norm2(obj) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariable_) :: ans - END FUNCTION fevar_norm2 -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = NORM2(FEVariable) - -INTERFACE OPERATOR(.EQ.) - MODULE PURE FUNCTION fevar_isEqual(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - LOGICAL(LGT) :: ans - END FUNCTION fevar_isEqual -END INTERFACE - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2021-12-12 -! update: 2021-12-12 -! summary: FEVariable = NORM2(FEVariable) - -INTERFACE OPERATOR(.NE.) - MODULE PURE FUNCTION fevar_notEqual(obj1, obj2) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj1 - CLASS(FEVariable_), INTENT(IN) :: obj2 - LOGICAL(LGT) :: ans - END FUNCTION fevar_notEqual -END INTERFACE - -!---------------------------------------------------------------------------- -! MEAN@MeanMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 May 2022 -! summary: FEVariable = Mean( obj ) - -INTERFACE MEAN - MODULE PURE FUNCTION fevar_Mean1(obj) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariable_) :: ans - END FUNCTION fevar_Mean1 -END INTERFACE - -!---------------------------------------------------------------------------- -! MEAN@MeanMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 May 2022 -! summary: FEVariable = Mean( obj ) - -INTERFACE MEAN - MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableScalar_), INTENT(IN) :: dataType - REAL(DFP) :: ans - END FUNCTION fevar_Mean2 -END INTERFACE - -!---------------------------------------------------------------------------- -! MEAN@MeanMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 May 2022 -! summary: FEVariable = Mean( obj ) - -INTERFACE MEAN - MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableVector_), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION fevar_Mean3 -END INTERFACE - -!---------------------------------------------------------------------------- -! MEAN@MeanMethods -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 27 May 2022 -! summary: FEVariable = Mean( obj ) - -INTERFACE MEAN - MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans) - CLASS(FEVariable_), INTENT(IN) :: obj - TYPE(FEVariableMatrix_), INTENT(IN) :: dataType - REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION fevar_Mean4 -END INTERFACE - +USE FEVariable_AdditionMethod +USE FEVariable_ConstructorMethod +USE FEVariable_DivisionMethod +USE FEVariable_DotProductMethod +USE FEVariable_GetMethod +USE FEVariable_IOMethod +USE FEVariable_MeanMethod +USE FEVariable_MultiplicationMethod +USE FEVariable_NodalVariableMethod +USE FEVariable_QuadratureVariableMethod +USE FEVariable_SetMethod +USE FEVariable_SubtractionMethod +USE FEVariable_UnaryMethod +USE FEVariable_ScalarInterpolationMethod +USE FEVariable_VectorInterpolationMethod +USE FEVariable_MatrixInterpolationMethod +USE FEVariable_InterpolationMethod END MODULE FEVariable_Method diff --git a/src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90 b/src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90 new file mode 100644 index 000000000..cbfadabdb --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90 @@ -0,0 +1,91 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_MultiplicationMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: OPERATOR(*) + +!---------------------------------------------------------------------------- +! Multiplication@MultiplicationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! update: 2021-12-1 +! summary: FEVariable = FEVariable * FEVariable + +INTERFACE OPERATOR(*) + MODULE PURE FUNCTION fevar_Multiplication1(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Multiplication1 +END INTERFACE OPERATOR(*) + +!---------------------------------------------------------------------------- +! Multiplication@MultiplicationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! update: 2021-12-12 +! summary: FEVariable = FEVariable * Real + +INTERFACE OPERATOR(*) + MODULE PURE FUNCTION fevar_Multiplication2(obj1, val) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + REAL(DFP), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Multiplication2 +END INTERFACE OPERATOR(*) + +!---------------------------------------------------------------------------- +! Multiplication@MultiplicationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! update: 2021-12-12 +! summary: FEVariable = Real * FEVariable + +INTERFACE OPERATOR(*) + MODULE PURE FUNCTION fevar_Multiplication3(val, obj1) RESULT(ans) + REAL(DFP), INTENT(IN) :: val + CLASS(FEVariable_), INTENT(IN) :: obj1 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Multiplication3 +END INTERFACE OPERATOR(*) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_MultiplicationMethod diff --git a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 new file mode 100644 index 000000000..e15511ea0 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 @@ -0,0 +1,750 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_NodalVariableMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, constant + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val + CLASS(FEVariableScalar_), INTENT(IN) :: rank + CLASS(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Constant +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_Constant +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Space +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_Space +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-11-04 +! summary: Create nodal variable, which is scalar, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_Space2(tsize, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: tsize + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Space2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_Space2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Time +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_Time +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_Time2(tsize, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: tsize + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_Time2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_Time2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_SpaceTime(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_SpaceTime +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_SpaceTime +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Scalar_SpaceTime2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_SpaceTime2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is scalar, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Scalar_SpaceTime3(nrow, ncol, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: nrow, ncol + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Scalar_SpaceTime3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Scalar_SpaceTime3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Constant + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_Constant +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Constant +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Constant + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Constant2(tsize, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: tsize + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_Constant2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Constant2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Space(val, rank, vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_Space +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Space +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Space2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Vector_Space2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Space2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-11-05 +! summary: Create nodal variable, which is vector, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Space3(nrow, ncol, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: nrow, ncol + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_Space3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Space3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Time(val, rank, vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_Time +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Time +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Time2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Vector_Time2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Time2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_Time3(nrow, ncol, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: nrow, ncol + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_Time3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_Time3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_SpaceTime +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_SpaceTime +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Nodal_Vector_SpaceTime2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_SpaceTime2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is vector, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Vector_SpaceTime3(dim1, dim2, dim3, rank, & + vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3 + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Vector_SpaceTime3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Vector_SpaceTime3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Constant + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_Constant +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Constant +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Constant + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Constant2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Nodal_Matrix_Constant2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Constant2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Constant + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Constant3(nrow, ncol, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: nrow, ncol + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_Constant3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Constant3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Space(val, rank, vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_Space +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Space +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Space2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Nodal_Matrix_Space2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Space2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Space + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Space3(dim1, dim2, dim3, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3 + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_Space3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Space3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Time(val, rank, vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_Time +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Time +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Time2(val, rank, vartype, s) RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Nodal_Matrix_Time2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Time2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, Time + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_Time3(dim1, dim2, dim3, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3 + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_Time3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_Time3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_SpaceTime +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_SpaceTime +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(4) + END FUNCTION Nodal_Matrix_SpaceTime2 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_SpaceTime2 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create nodal variable, which is Matrix, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Nodal_Matrix_SpaceTime3(dim1, dim2, dim3, dim4, rank, & + vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3, dim4 + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Nodal_Matrix_SpaceTime3 +END INTERFACE + +INTERFACE NodalVariable + MODULE PROCEDURE Nodal_Matrix_SpaceTime3 +END INTERFACE NodalVariable + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_NodalVariableMethod diff --git a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 new file mode 100644 index 000000000..fce35456d --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 @@ -0,0 +1,616 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_QuadratureVariableMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE +PRIVATE + +PUBLIC :: QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, Constant + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_Constant +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Constant +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_Space +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Space +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-11-04 +! summary: Create quadrature variable, which is Scalar, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_Space2(tsize, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: tsize + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_Space2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Space2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, Time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_Time +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Time +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, Time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_Time2(tsize, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: tsize + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_Time2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_Time2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_SpaceTime +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_SpaceTime +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Scalar_SpaceTime2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_SpaceTime2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Scalar, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime3( & + nrow, ncol, rank, vartype) RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: nrow, ncol + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Scalar_SpaceTime3 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Scalar_SpaceTime3 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! NodalVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Constant + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Vector_Constant +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Constant +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Vector_Space +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Space +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Vector_Space2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Space2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-11-05 +! summary: Create quadrature variable, which is Vector, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_Space3(nrow, ncol, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + INTEGER(I4B), INTENT(IN) :: nrow, ncol + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Vector_Space3 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Space3 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_Time(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Vector_Time +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Time +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, Time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_Time2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Vector_Time2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_Time2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Vector_SpaceTime +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_SpaceTime +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Vector, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Quadrature_Vector_SpaceTime2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_SpaceTime2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Shion Shimizu +! date: 2025-12-11 +! summary: Create FEVariable which is vector and space-time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Vector_SpaceTime3(rank, vartype, & + dim1, dim2, dim3) & + RESULT(obj) + TYPE(FEVariable_) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3 + END FUNCTION Quadrature_Vector_SpaceTime3 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Vector_SpaceTime3 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Constant + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Matrix_Constant +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Constant +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Constant + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_Constant2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(2) + END FUNCTION Quadrature_Matrix_Constant2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Constant2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_Space(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Matrix_Space +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Space +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Space + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_Space2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Quadrature_Matrix_Space2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Space2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_Time(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Matrix_Time +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Time +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, Time + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_Time2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(3) + END FUNCTION Quadrature_Matrix_Time2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_Time2 +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + END FUNCTION Quadrature_Matrix_SpaceTime +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_SpaceTime +END INTERFACE QuadratureVariable + +!---------------------------------------------------------------------------- +! QuadratureVariable@ConstructorMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-10 +! update: 2021-12-10 +! summary: Create quadrature variable, which is Matrix, SpaceTime + +INTERFACE + MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime2(val, rank, vartype, s) & + RESULT(obj) + TYPE(FEVariable_) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + INTEGER(I4B), INTENT(IN) :: s(4) + END FUNCTION Quadrature_Matrix_SpaceTime2 +END INTERFACE + +INTERFACE QuadratureVariable + MODULE PROCEDURE Quadrature_Matrix_SpaceTime2 +END INTERFACE QuadratureVariable + +END MODULE FEVariable_QuadratureVariableMethod diff --git a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 new file mode 100644 index 000000000..a77d18f36 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 @@ -0,0 +1,396 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_ScalarInterpolationMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, scale, addContribution, ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + END SUBROUTINE ScalarConstantGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index for ans + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable_ format + !! Scalar, QuadratureVariable, Space + END SUBROUTINE ScalarConstantGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, & + ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx + !! number of integration points in N, bound for dim2 in N + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans + !! Interpolated value + !! Size of ans should be at least nips + END SUBROUTINE ScalarConstantGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, scale, addContribution, ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + END SUBROUTINE ScalarSpaceGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable_ format + !! Scalar, QuadratureVariable, Space + END SUBROUTINE ScalarSpaceGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, & + ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! space and time integration point index + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans + !! Interpolated value + !! Size of ans should be at least nips + END SUBROUTINE ScalarSpaceGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, & + ans, tsize, timeIndx) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is used when varType is spaceTime and defined on Quad + END SUBROUTINE ScalarSpaceTimeGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space-time +! +!# Introduction +! +! If obj%varType is SpaceTime Then following thing happens +! In this case ans will be Scalar, Space, QuadratureVariable +! The values corresponding to timeIndx will be returned in ans as follows +! +! valStart = (timeIndx - 1) * obj%s(1) +! DO aa = 1, tsize +! ans%val(aa) = ans%val(aa) + scale * obj%val(aa+valStart) +! END DO + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, & + timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is used when varType is spaceTime and defined on Quad + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable_ format + !! Scalar, QuadratureVariable, SpaceTime + END SUBROUTINE ScalarSpaceTimeGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, T, nnt, scale, & + addContribution, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + END SUBROUTINE ScalarSpaceTimeGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@ScalarInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of scalar, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE ScalarGetInterpolation_3( & + obj, rank, N, nns, spaceIndx, timeIndx, T, nnt, scale, addContribution, & + ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableScalar_), INTENT(IN) :: rank + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + END SUBROUTINE ScalarGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_ScalarInterpolationMethod diff --git a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 new file mode 100644 index 000000000..099efef6f --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_SetMethod.F90 @@ -0,0 +1,230 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE FEVariable_SetMethod +USE BaseType, ONLY: FEVariable_, & + TypeFEVariableOpt, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_ + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set1(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set1 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set2(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set2 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set3(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set3 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set4(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set4 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set5(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set5 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set6(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set6 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set7(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set7 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set8(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set8 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set9(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set9 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set10(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:) + TYPE(FEVariableScalar_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set10 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set11(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :) + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set11 +END INTERFACE Set + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set12(obj, val, rank, vartype, scale, & + addContribution) + TYPE(FEVariable_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: val(:, :, :) + TYPE(FEVariableMatrix_), INTENT(IN) :: rank + TYPE(FEVariableTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: scale + LOGICAL(LGT), INTENT(IN) :: addContribution + END SUBROUTINE obj_Set12 +END INTERFACE Set + +END MODULE FEVariable_SetMethod diff --git a/src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90 b/src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90 new file mode 100644 index 000000000..bc6e69697 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90 @@ -0,0 +1,87 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_SubtractionMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE +PUBLIC :: OPERATOR(-) + +!---------------------------------------------------------------------------- +! Substraction@SubstractioMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable - FEVariable + +INTERFACE OPERATOR(-) + MODULE PURE FUNCTION fevar_Subtraction1(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Subtraction1 +END INTERFACE OPERATOR(-) + +!---------------------------------------------------------------------------- +! Substraction@SubstractioMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable - RealVal + +INTERFACE OPERATOR(-) + MODULE PURE FUNCTION fevar_Subtraction2(obj1, val) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + REAL(DFP), INTENT(IN) :: val + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Subtraction2 +END INTERFACE OPERATOR(-) + +!---------------------------------------------------------------------------- +! Substraction@SubstractioMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = RealVal - FEVariable + +INTERFACE OPERATOR(-) + MODULE PURE FUNCTION fevar_Subtraction3(val, obj1) RESULT(ans) + REAL(DFP), INTENT(IN) :: val + CLASS(FEVariable_), INTENT(IN) :: obj1 + TYPE(FEVariable_) :: ans + END FUNCTION fevar_Subtraction3 +END INTERFACE OPERATOR(-) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_SubtractionMethod diff --git a/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 b/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 new file mode 100644 index 000000000..ef59f1d6e --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 @@ -0,0 +1,138 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_UnaryMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableScalar_, & + FEVariableVector_, & + FEVariableMatrix_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: ABS +PUBLIC :: OPERATOR(**) +PUBLIC :: Sqrt +PUBLIC :: OPERATOR(.EQ.) +PUBLIC :: OPERATOR(.NE.) +PUBLIC :: Norm2 + +!---------------------------------------------------------------------------- +! Abs@AbsMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable + FEVariable + +INTERFACE ABS + MODULE PURE FUNCTION fevar_abs(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariable_) :: ans + END FUNCTION fevar_abs +END INTERFACE ABS + +!---------------------------------------------------------------------------- +! Power@PowerMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable + FEVariable + +INTERFACE OPERATOR(**) + MODULE PURE FUNCTION fevar_power(obj, n) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + INTEGER(I4B), INTENT(IN) :: n + TYPE(FEVariable_) :: ans + END FUNCTION fevar_power +END INTERFACE OPERATOR(**) + +!---------------------------------------------------------------------------- +! Sqrt@UnaryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = FEVariable + FEVariable + +INTERFACE Sqrt + MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariable_) :: ans + END FUNCTION fevar_sqrt +END INTERFACE Sqrt + +!---------------------------------------------------------------------------- +! Norm2@UnaryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = NORM2(FEVariable) + +INTERFACE Norm2 + MODULE PURE FUNCTION fevar_norm2(obj) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariable_) :: ans + END FUNCTION fevar_norm2 +END INTERFACE Norm2 + +!---------------------------------------------------------------------------- +! InquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = NORM2(FEVariable) + +INTERFACE OPERATOR(.EQ.) + MODULE PURE FUNCTION fevar_isEqual(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + LOGICAL(LGT) :: ans + END FUNCTION fevar_isEqual +END INTERFACE OPERATOR(.EQ.) + +!---------------------------------------------------------------------------- +! InquiryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-12 +! summary: FEVariable = NORM2(FEVariable) + +INTERFACE OPERATOR(.NE.) + MODULE PURE FUNCTION fevar_notEqual(obj1, obj2) RESULT(ans) + CLASS(FEVariable_), INTENT(IN) :: obj1 + CLASS(FEVariable_), INTENT(IN) :: obj2 + LOGICAL(LGT) :: ans + END FUNCTION fevar_notEqual +END INTERFACE OPERATOR(.NE.) + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_UnaryMethod diff --git a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 new file mode 100644 index 000000000..efdbca984 --- /dev/null +++ b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 @@ -0,0 +1,410 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +MODULE FEVariable_VectorInterpolationMethod +USE BaseType, ONLY: FEVariable_, & + FEVariableVector_, & + FEVariableConstant_, & + FEVariableSpace_, & + FEVariableTime_, & + FEVariableSpaceTime_, & + TypeFEVariableOpt + +USE GlobalData, ONLY: I4B, DFP, LGT + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorConstantGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, scale, addContribution, ans, nrow, & + ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + END SUBROUTINE VectorConstantGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, constant +! +!# Introduction +! +! ans%s(1) and obj%s(1) should be same +! ans%s(2) and nips should be same + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorConstantGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index for ans + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value in FEVariable form + !! Size of ans should be at least nips + END SUBROUTINE VectorConstantGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@InterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, constant + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorConstantGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, & + ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableConstant_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + END SUBROUTINE VectorConstantGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, scale, addContribution, ans, nrow, & + ncol) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + END SUBROUTINE VectorSpaceGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index for ans + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value + !! Size of ans should be at least nips + END SUBROUTINE VectorSpaceGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, & + ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpace_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + END SUBROUTINE VectorSpaceGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_1( & + obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, & + ans, nrow, ncol, timeIndx) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of data written in ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is used when varType is spaceTime and defined on Quad + END SUBROUTINE VectorSpaceTimeGetInterpolation_1 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space-time +! +!# Introduction +! +! When obj%vartype is Nodal: +! - Convert nodal values to quadrature values by using N +! - make sure nns .LE. obj%len +! - obj%s(1) denotes the nsd in obj +! - obj%s(2) should be equal to nns +! - obj%s(3) should be atleast nnt +! +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_2( & + obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, & + timeIndx, ans) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: nips + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(IN) :: timeIndx + !! time index is used when varType is spaceTime and defined on Quad + TYPE(FEVariable_), INTENT(INOUT) :: ans + !! Interpolated value + !! Size of ans should be at least nips + END SUBROUTINE VectorSpaceTimeGetInterpolation_2 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_3( & + obj, rank, vartype, N, nns, spaceIndx, timeIndx, T, nnt, scale, & + addContribution, ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + END SUBROUTINE VectorSpaceTimeGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! GetInterpolation_@VectorInterpolationMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-08-29 +! summary: Get interpolation of Vector, space-time + +INTERFACE GetInterpolation_ + MODULE PURE SUBROUTINE VectorGetInterpolation_3( & + obj, rank, N, nns, spaceIndx, timeIndx, T, nnt, scale, addContribution, & + ans, tsize) + CLASS(FEVariable_), INTENT(IN) :: obj + TYPE(FEVariableVector_), INTENT(IN) :: rank + REAL(DFP), INTENT(IN) :: N(:, :) + !! shape functions data, N(I, ips) : I is node or dof number + !! ips is integration point number + INTEGER(I4B), INTENT(IN) :: nns + !! number of nodes in N, bound for dim1 in N + INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx + !! number of integration points in N, bound for dim2 in N + REAL(DFP), INTENT(IN) :: T(:) + !! time shape functions data, T(a) : a is time node or dof number + INTEGER(I4B), INTENT(IN) :: nnt + !! number of time nodes in T, bound for dim1 in T + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Interpolated value + !! Size of ans should be at least nips + REAL(DFP), INTENT(IN) :: scale + !! scale factor to be applied to the interpolated value + LOGICAL(LGT), INTENT(IN) :: addContribution + !! if true, the interpolated value is added to ans + INTEGER(I4B), INTENT(OUT) :: tsize + !! Number of data written in ans + END SUBROUTINE VectorGetInterpolation_3 +END INTERFACE GetInterpolation_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE FEVariable_VectorInterpolationMethod diff --git a/src/modules/FPL/src/FPL_utils.F90 b/src/modules/FPL/src/FPL_utils.F90 index 978416506..c54472f0d 100644 --- a/src/modules/FPL/src/FPL_utils.F90 +++ b/src/modules/FPL/src/FPL_utils.F90 @@ -15,9 +15,9 @@ ! along with this program. If not, see ! -module FPL_Utils -USE PENF, only: I1P, I4P -contains +MODULE FPL_Utils +USE PENF, ONLY: I1P, I4P +CONTAINS !---------------------------------------------------------------------------- ! @@ -27,19 +27,19 @@ module FPL_Utils ! date: 2022-12-02 ! summary: Procedure for computing the number of bytes of a logical variable. -elemental function byte_size_logical(l) result(bytes) - logical, intent(IN) :: l +ELEMENTAL FUNCTION byte_size_logical(l) RESULT(bytes) + LOGICAL, INTENT(IN) :: l !! Character variable whose number of bits must be computed. - integer(I4P) :: bytes + INTEGER(I4P) :: bytes !! Number of bits of l. - integer(I1P) :: mold(1) + INTEGER(I1P) :: mold(1) !! "Molding" dummy variable for bits counting. - bytes = size(transfer(l, mold), dim=1, kind=I1P) - return -end function byte_size_logical + bytes = SIZE(TRANSFER(l, mold), dim=1, kind=I1P) + RETURN +END FUNCTION byte_size_logical !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -end module FPL_Utils +END MODULE FPL_Utils diff --git a/src/modules/FPL/src/ParameterList.F90 b/src/modules/FPL/src/ParameterList.F90 index aec8a6919..0dd1076ad 100644 --- a/src/modules/FPL/src/ParameterList.F90 +++ b/src/modules/FPL/src/ParameterList.F90 @@ -136,27 +136,27 @@ MODULE ParameterList ParameterList_isAssignable6D, & ParameterList_isAssignable7D PROCEDURE, NON_OVERRIDABLE, PUBLIC :: DataSizeInBytes => & - & ParameterList_DataSizeInBytes + ParameterList_DataSizeInBytes PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Del => ParameterList_RemoveEntry GENERIC, PUBLIC :: Remove => Del PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Init => ParameterList_Init GENERIC, PUBLIC :: Initiate => Init PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetShape => ParameterList_GetShape PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetDimensions => & - & ParameterList_GetDimensions + ParameterList_GetDimensions PROCEDURE, NON_OVERRIDABLE, PUBLIC :: NewSubList => ParameterList_NewSubList PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetSubList => ParameterList_GetSubList PROCEDURE, NON_OVERRIDABLE, PUBLIC :: isPresent => ParameterList_isPresent PROCEDURE, NON_OVERRIDABLE, PUBLIC :: isSubList => ParameterList_isSubList PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetAsString => & - & ParameterList_GetAsString + ParameterList_GetAsString PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Free => ParameterList_Free GENERIC, PUBLIC :: DEALLOCATE => Free PROCEDURE, NON_OVERRIDABLE, PUBLIC :: PRINT => ParameterList_Print PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Display => ParameterList_Display PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Length => ParameterList_Length PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetIterator => & - & ParameterList_GetIterator + ParameterList_GetIterator FINAL :: ParameterList_Finalize END TYPE ParameterList_t @@ -200,30 +200,30 @@ MODULE ParameterList PROCEDURE, NON_OVERRIDABLE :: GetEntry => ParameterListIterator_GetEntry PROCEDURE, NON_OVERRIDABLE :: GetIndex => ParameterListIterator_GetIndex PROCEDURE, NON_OVERRIDABLE :: PointToValue => & - & ParameterListIterator_PointToValue + ParameterListIterator_PointToValue PROCEDURE, NON_OVERRIDABLE :: NextNotEmptyListIterator => & - & ParameterListIterator_NextNotEmptyListIterator + ParameterListIterator_NextNotEmptyListIterator PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetKey => ParameterListIterator_GetKey PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Init => ParameterListIterator_Init PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Begin => ParameterListIterator_Begin PROCEDURE, PUBLIC, NON_OVERRIDABLE :: END => ParameterListIterator_End PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Next => ParameterListIterator_Next PROCEDURE, PUBLIC, NON_OVERRIDABLE :: HasFinished => & - & ParameterListIterator_HasFinished + ParameterListIterator_HasFinished PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetShape => & - & ParameterListIterator_GetShape + ParameterListIterator_GetShape PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetDimensions => & - & ParameterListIterator_GetDimensions + ParameterListIterator_GetDimensions PROCEDURE, PUBLIC, NON_OVERRIDABLE :: DataSizeInBytes => & - & ParameterListIterator_DataSizeInBytes + ParameterListIterator_DataSizeInBytes PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetAsString => & - & ParameterListIterator_GetAsString + ParameterListIterator_GetAsString PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetSubList => & - & ParameterListIterator_GetSubList + ParameterListIterator_GetSubList PROCEDURE, PUBLIC, NON_OVERRIDABLE :: isSubList => & - & ParameterListIterator_isSubList + ParameterListIterator_isSubList PROCEDURE, PUBLIC, NON_OVERRIDABLE :: toString => & - & ParameterListIterator_toString + ParameterListIterator_toString PROCEDURE, PUBLIC, NON_OVERRIDABLE :: PRINT => ParameterListIterator_Print PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Free => ParameterListIterator_Free GENERIC, PUBLIC :: Get => ParameterListIterator_Get0D, & @@ -364,21 +364,19 @@ END SUBROUTINE ParameterList_Finalize ! !---------------------------------------------------------------------------- - !> author: Vikas Sharma, Ph. D. -! date: 2023-09-22 +! date: 2023-09-22 ! summary: Set a Key/Value pair into the dictionary FUNCTION ParameterList_NewSubList(this, Key, Size) RESULT(SubListPointer) - - CLASS(ParameterList_t), INTENT(INOUT) :: this + CLASS(ParameterList_t), INTENT(INOUT) :: this !! Parameter List - CHARACTER(*), INTENT(IN) :: Key + CHARACTER(*), INTENT(IN) :: Key !! String Key - INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size + INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size !! Sublist Size - TYPE(ParameterList_t), POINTER :: SublistPointer + TYPE(ParameterList_t), POINTER :: SublistPointer !! New Sublist pointer ! Internal variables @@ -431,7 +429,7 @@ FUNCTION ParameterList_GetSublist(this, Key, Sublist) RESULT(FPLerror) END FUNCTION ParameterList_GetSubList !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- FUNCTION ParameterList_Set0D(this, Key, VALUE) RESULT(FPLerror) @@ -1656,13 +1654,14 @@ END FUNCTION ParameterList_GetAsString ! !---------------------------------------------------------------------------- -SUBROUTINE ParameterList_Display(this, msg, unitno) - - !< Print the content of the DataBase +!> author: Vikas Sharma, Ph. D. +! date: 2025-07-20 +! summary: Print the content of the DataBase - CLASS(ParameterList_t), INTENT(in) :: this - CHARACTER(*), INTENT(in) :: msg - INTEGER(i4p), OPTIONAL, INTENT(in) :: unitno +SUBROUTINE ParameterList_Display(this, msg, unitno) + CLASS(ParameterList_t), INTENT(IN) :: this + CHARACTER(*), INTENT(IN) :: msg + INTEGER(i4p), OPTIONAL, INTENT(IN) :: unitno CALL this%PRINT(unitno, msg) END SUBROUTINE ParameterList_Display @@ -1760,8 +1759,10 @@ SUBROUTINE ParameterListIterator_Assignment(this, ParameterListIterator) !< Dictionary iterator Assignment - CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Output Dictionary iterator - TYPE(ParameterListIterator_t), INTENT(IN) :: ParameterListIterator ! Input Dictionary iterator + CLASS(ParameterListIterator_t), INTENT(INOUT) :: this + !! Output Dictionary iterator + TYPE(ParameterListIterator_t), INTENT(IN) :: ParameterListIterator + !! Input Dictionary iterator this%DataBase(0:) => ParameterListIterator%DataBase this%EntryListIterator = ParameterListIterator%EntryListIterator @@ -1859,7 +1860,7 @@ SUBROUTINE ParameterListIterator_Next(this) END SUBROUTINE ParameterListIterator_Next !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- FUNCTION ParameterListIterator_GetEntry(this) RESULT(CurrentEntry) @@ -1880,7 +1881,7 @@ FUNCTION ParameterListIterator_GetEntry(this) RESULT(CurrentEntry) END FUNCTION ParameterListIterator_GetEntry !---------------------------------------------------------------------------- -! +! !---------------------------------------------------------------------------- FUNCTION ParameterListIterator_PointToValue(this) RESULT(VALUE) diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 index 0220fa6c8..49555558c 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 @@ -18,199 +18,188 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper0D_I4P +MODULE DimensionsWrapper0D_I4P USE DimensionsWrapper0D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I4P_t - integer(I4P), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_I4P_Set - procedure, public :: Get => DimensionsWrapper0D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper0D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_I4P_toString - procedure, public :: Free => DimensionsWrapper0D_I4P_Free - procedure, public :: Print => DimensionsWrapper0D_I4P_Print - final :: DimensionsWrapper0D_I4P_Final - end type - -public :: DimensionsWrapper0D_I4P_t - -contains - - - subroutine DimensionsWrapper0D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value, stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper0D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper0D_I4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this !< Dimensions wrapper 0D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%Value) - end function DimensionsWrapper0D_I4P_DataSizeInBytes - - - function DimensionsWrapper0D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this !< Dimensions wrapper 0D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_I4P_isOfDataType - - - subroutine DimensionsWrapper0D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' - if(allocated(this%Value)) String = trim(str(n=this%Value)) - end subroutine - - - subroutine DimensionsWrapper0D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper0D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_I4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_I4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_I4P_Print + FINAL :: DimensionsWrapper0D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper0D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper0D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper0D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE, stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + VALUE = this%VALUE + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper0D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + ALLOCATE (VALUE, source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE) +END FUNCTION DimensionsWrapper0D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper0D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper0D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper0D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' + IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE)) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper0D_I4P_Print - -end module DimensionsWrapper0D_I4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper0D_I4P_Print + +END MODULE DimensionsWrapper0D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 index bbc8b0a38..ed79da75a 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 @@ -18,200 +18,188 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper0D_I8P +MODULE DimensionsWrapper0D_I8P USE DimensionsWrapper0D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I8P_t - integer(I8P), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_I8P_Set - procedure, public :: Get => DimensionsWrapper0D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper0D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_I8P_toString - procedure, public :: Free => DimensionsWrapper0D_I8P_Free - procedure, public :: Print => DimensionsWrapper0D_I8P_Print - final :: DimensionsWrapper0D_I8P_Final - end type - -public :: DimensionsWrapper0D_I8P_t - -contains - - - subroutine DimensionsWrapper0D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value, stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper0D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper0D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this !< Dimensions wrapper 0D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%Value) - end function DimensionsWrapper0D_I8P_DataSizeInBytes - - - function DimensionsWrapper0D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this !< Dimensions wrapper 0D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_I8P_isOfDataType - - - subroutine DimensionsWrapper0D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' - if(allocated(this%Value)) String = trim(str(n=this%Value)) - end subroutine - - - subroutine DimensionsWrapper0D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper0D_I8P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_I8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_I8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_I8P_Print + FINAL :: DimensionsWrapper0D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper0D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper0D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper0D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE, stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + VALUE = this%VALUE + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper0D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + ALLOCATE (VALUE, source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE) +END FUNCTION DimensionsWrapper0D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper0D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper0D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper0D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' + IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE)) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper0D_I8P_Print - - -end module DimensionsWrapper0D_I8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper0D_I8P_Print + +END MODULE DimensionsWrapper0D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 index 1ba2b3c05..8a31fddf8 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 @@ -18,201 +18,189 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper0D_L +MODULE DimensionsWrapper0D_L USE DimensionsWrapper0D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_L_t - logical, allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_L_Set - procedure, public :: Get => DimensionsWrapper0D_L_Get - procedure, public :: GetShape => DimensionsWrapper0D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_L_toString - procedure, public :: Free => DimensionsWrapper0D_L_Free - procedure, public :: Print => DimensionsWrapper0D_L_Print - final :: DimensionsWrapper0D_L_Final - end type - -public :: DimensionsWrapper0D_L_t - -contains - - - subroutine DimensionsWrapper0D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value, stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (logical) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper0D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper0D_L_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this !< Dimensions wrapper 0D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%Value) - end function DimensionsWrapper0D_L_DataSizeInBytes - - - function DimensionsWrapper0D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this !< Dimensions wrapper 0D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_L_isOfDataType - - - subroutine DimensionsWrapper0D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' - if(allocated(this%Value)) String = trim(str(n=this%Value)) - end subroutine - - - subroutine DimensionsWrapper0D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_L_t + LOGICAL, ALLOCATABLE :: VALUE +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper0D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => DimensionsWrapper0D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_L_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_L_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_L_Print + FINAL :: DimensionsWrapper0D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper0D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper0D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper0D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE, stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + VALUE = this%VALUE + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper0D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + ALLOCATE (VALUE, source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this !< Dimensions wrapper 0D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size_logical(this%VALUE) +END FUNCTION DimensionsWrapper0D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper0D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this !< Dimensions wrapper 0D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper0D_L_isOfDataType + +SUBROUTINE DimensionsWrapper0D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' + IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE)) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper0D_L_Print - - -end module DimensionsWrapper0D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper0D_L_Print + +END MODULE DimensionsWrapper0D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 index ed9329027..36a96bbb6 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 @@ -18,199 +18,190 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper0D_R4P +MODULE DimensionsWrapper0D_R4P USE DimensionsWrapper0D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R4P_t - real(R4P), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_R4P_Set - procedure, public :: Get => DimensionsWrapper0D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper0D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_R4P_toString - procedure, public :: Print => DimensionsWrapper0D_R4P_Print - procedure, public :: Free => DimensionsWrapper0D_R4P_Free - final :: DimensionsWrapper0D_R4P_Final - end type - -public :: DimensionsWrapper0D_R4P_t - -contains - - - subroutine DimensionsWrapper0D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value, stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper0D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper0D_r4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this !< Dimensions wrapper 0D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%Value) - end function DimensionsWrapper0D_R4P_DataSizeInBytes - - - function DimensionsWrapper0D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this !< Dimensions wrapper 0D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_R4P_isOfDataType - - - subroutine DimensionsWrapper0D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' - if(allocated(this%Value)) String = trim(str(n=this%Value)) - end subroutine - - - subroutine DimensionsWrapper0D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper0D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper0D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_R4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_R4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_R4P_Free + FINAL :: DimensionsWrapper0D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper0D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper0D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper0D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE, stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + VALUE = this%VALUE + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper0D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + ALLOCATE (VALUE, source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_r4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE) +END FUNCTION DimensionsWrapper0D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper0D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper0D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper0D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' + IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE)) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper0D_R4P_Print - -end module DimensionsWrapper0D_R4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper0D_R4P_Print + +END MODULE DimensionsWrapper0D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 index b93c5d148..3ef63084f 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 @@ -18,200 +18,190 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper0D_R8P +MODULE DimensionsWrapper0D_R8P USE DimensionsWrapper0D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R8P_t - real(R8P), allocatable :: Value - contains - private - procedure, public :: Set => DimensionsWrapper0D_R8P_Set - procedure, public :: Get => DimensionsWrapper0D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper0D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper0D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper0D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper0D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper0D_R8P_toString - procedure, public :: Free => DimensionsWrapper0D_R8P_Free - procedure, public :: Print => DimensionsWrapper0D_R8P_Print - final :: DimensionsWrapper0D_R8P_Final - end type - -public :: DimensionsWrapper0D_R8P_t - -contains - - - subroutine DimensionsWrapper0D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper0D - !----------------------------------------------------------------- - type(DimensionsWrapper0D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper0D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value, stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - Value = this%Value - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper0D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Return the shape of the Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper0D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper0D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value - !----------------------------------------------------------------- - allocate(Value, source = this%Value) - end subroutine - - - subroutine DimensionsWrapper0D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper0D - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper0D_R8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored value - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this !< Dimensions wrapper 0D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%Value) - end function DimensionsWrapper0D_R8P_DataSizeInBytes - - - function DimensionsWrapper0D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this !< Dimensions wrapper 0D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper0D_R8P_isOfDataType - - - subroutine DimensionsWrapper0D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' - if(allocated(this%Value)) String = trim(str(n=this%Value)) - end subroutine - - - subroutine DimensionsWrapper0D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper0D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper0D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper0D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_R8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_R8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_R8P_Print + FINAL :: DimensionsWrapper0D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper0D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper0D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper0D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper0D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE, stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + VALUE = this%VALUE + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Return the shape of the Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper0D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE + !----------------------------------------------------------------- + ALLOCATE (VALUE, source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper0D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper0D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE) +END FUNCTION DimensionsWrapper0D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper0D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper0D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper0D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' + IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE)) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper0D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper0D_R8P_Print - - -end module DimensionsWrapper0D_R8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper0D_R8P_Print + +END MODULE DimensionsWrapper0D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 index e011507fc..ec29ee82e 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 @@ -18,209 +18,198 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper1D_I4P +MODULE DimensionsWrapper1D_I4P USE DimensionsWrapper1D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I4P_t - integer(I4P), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_I4P_Set - procedure, public :: Get => DimensionsWrapper1D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper1D_I4P_GetShape - procedure, public :: GetPolymorphic => DimensionsWrapper1D_I4P_GetPolymorphic - procedure, public :: GetPointer => DimensionsWrapper1D_I4P_GetPointer - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_I4P_toString - procedure, public :: Free => DimensionsWrapper1D_I4P_Free - procedure, public :: Print => DimensionsWrapper1D_I4P_Print - final :: DimensionsWrapper1D_I4P_Final - end type - -public :: DimensionsWrapper1D_I4P_t - -contains - - - subroutine DimensionsWrapper1D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1)), stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper1D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic W2apper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper1D_I4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this !< Dimensions wrapper 1D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1))*size(this%value) - end function DimensionsWrapper1D_I4P_DataSizeInBytes - - - function DimensionsWrapper1D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this !< Dimensions wrapper 1D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_I4P_isOfDataType - - - subroutine DimensionsWrapper1D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper1D_I4P_GetPolymorphic + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_I4P_GetPointer +procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_I4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_I4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_I4P_Print + FINAL :: DimensionsWrapper1D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper1D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper1D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper1D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic W2apper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper1D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper1D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper1D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper1D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper1D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' if(allocated(this%Value)) String = trim(str(n=this%Value, separator=Separator)) - end subroutine - - - subroutine DimensionsWrapper1D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper1D_I4P_Print - -end module DimensionsWrapper1D_I4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper1D_I4P_Print + +END MODULE DimensionsWrapper1D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 index b6fa86fa3..0663892d8 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 @@ -18,218 +18,208 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper1D_L +MODULE DimensionsWrapper1D_L USE DimensionsWrapper1D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_L_t - logical, allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_L_Set - procedure, public :: Get => DimensionsWrapper1D_L_Get - procedure, public :: GetShape => DimensionsWrapper1D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_L_GetPolymorphic - procedure, public :: isOfDataType => DimensionsWrapper1D_L_isOfDataType - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_L_DataSizeInBytes - procedure, public :: toString => DimensionsWrapper1D_L_toString - procedure, public :: Free => DimensionsWrapper1D_L_Free - procedure, public :: Print => DimensionsWrapper1D_L_Print - final :: DimensionsWrapper1D_L_Final - end type - -public :: DimensionsWrapper1D_L_t - -contains - - - subroutine DimensionsWrapper1D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1)), stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (logical)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper1D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic W2apper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper1D_L_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this !< Dimensions wrapper 1D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%value(1))*size(this%value) - end function DimensionsWrapper1D_L_DataSizeInBytes - - - function DimensionsWrapper1D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this !< Dimensions wrapper 1D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_L_isOfDataType - - - subroutine DimensionsWrapper1D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx=1, size(this%Value) - String = String // trim(str(n=this%Value(idx))) // Sep - enddo - endif - end subroutine - - - subroutine DimensionsWrapper1D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper1D_L_GetPolymorphic + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_L_isOfDataType + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper1D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_L_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_L_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_L_Print + FINAL :: DimensionsWrapper1D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper1D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper1D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper1D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic W2apper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper1D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this !< Dimensions wrapper 1D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size_logical(this%VALUE(1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper1D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper1D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this !< Dimensions wrapper 1D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper1D_L_isOfDataType + +SUBROUTINE DimensionsWrapper1D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx = 1, SIZE(this%VALUE) + String = String//TRIM(str(n=this%VALUE(idx)))//Sep + END DO + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper1D_L_Print - -end module DimensionsWrapper1D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper1D_L_Print + +END MODULE DimensionsWrapper1D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 index 05f3d5c20..89d6769d6 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 @@ -18,208 +18,199 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper1D_R4P +MODULE DimensionsWrapper1D_R4P USE DimensionsWrapper1D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R4P_t - real(R4P), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_R4P_Set - procedure, public :: Get => DimensionsWrapper1D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper1D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_R4P_toString - procedure, public :: Free => DimensionsWrapper1D_R4P_Free - procedure, public :: Print => DimensionsWrapper1D_R4P_Print - final :: DimensionsWrapper1D_R4P_Final - end type - -public :: DimensionsWrapper1D_R4P_t - -contains - - - subroutine DimensionsWrapper1D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1)), stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper1D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic W2apper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper1D_R4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this !< Dimensions wrapper 1D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1))*size(this%value) - end function DimensionsWrapper1D_R4P_DataSizeInBytes - - - function DimensionsWrapper1D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this !< Dimensions wrapper 1D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_R4P_isOfDataType - - - subroutine DimensionsWrapper1D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper1D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper1D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_R4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_R4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_R4P_Print + FINAL :: DimensionsWrapper1D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper1D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper1D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper1D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic W2apper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper1D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper1D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper1D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper1D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper1D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' if(allocated(this%Value)) String = trim(str(n=this%Value, separator=Separator)) - end subroutine - - - subroutine DimensionsWrapper1D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper1D_R4P_Print - -end module DimensionsWrapper1D_R4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper1D_R4P_Print + +END MODULE DimensionsWrapper1D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 index fa590fca8..bb7aa155e 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 @@ -18,208 +18,198 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper1D_R8P - +MODULE DimensionsWrapper1D_R8P USE DimensionsWrapper1D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R8P_t - real(R8P), allocatable :: Value(:) - contains - private - procedure, public :: Set => DimensionsWrapper1D_R8P_Set - procedure, public :: Get => DimensionsWrapper1D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper1D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper1D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper1D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper1D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper1D_R8P_toString - procedure, public :: Free => DimensionsWrapper1D_R8P_Free - procedure, public :: Print => DimensionsWrapper1D_R8P_Print - final :: DimensionsWrapper1D_R8P_Final - end type - -public :: DimensionsWrapper1D_R8P_t - -contains - - - subroutine DimensionsWrapper1D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper1D - !----------------------------------------------------------------- - type(DimensionsWrapper1D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper1D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1)), stat=err) - this%Value = Value - if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn(txt='Setting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper1D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper1D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic W2apper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper1D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1)),source=this%Value) - end subroutine - - - subroutine DimensionsWrapper1D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper1D - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper1D_R8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this !< Dimensions wrapper 1D - integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1))*size(this%value) - end function DimensionsWrapper1D_R8P_DataSizeInBytes - - - function DimensionsWrapper1D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this !< Dimensions wrapper 1D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper1D_R8P_isOfDataType - - - subroutine DimensionsWrapper1D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - !----------------------------------------------------------------- - String = '' +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper1D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper1D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_R8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_R8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_R8P_Print + FINAL :: DimensionsWrapper1D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper1D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper1D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper1D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper1D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err) + this%VALUE = VALUE + IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic W2apper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper1D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper1D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper1D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 1D + INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper1D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper1D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 1D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper1D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper1D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + !----------------------------------------------------------------- + String = '' if(allocated(this%Value)) String = trim(str(n=this%Value, separator=Separator)) - end subroutine - - - subroutine DimensionsWrapper1D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper1D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix - call this%toString(strvalue) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper1D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix + CALL this%toString(strvalue) write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = '//strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper1D_R8P_Print - -end module DimensionsWrapper1D_R8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = '//strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper1D_R8P_Print + +END MODULE DimensionsWrapper1D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 index a2259c9f2..87c038a5c 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 @@ -18,223 +18,212 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper2D_I4P +MODULE DimensionsWrapper2D_I4P USE DimensionsWrapper2D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I4P_t - integer(I4P), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_I4P_Set - procedure, public :: Get => DimensionsWrapper2D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper2D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I4P_DataSizeInBytes - procedure, public :: toString => DimensionsWrapper2D_I4P_toString - procedure, public :: isOfDataType => DimensionsWrapper2D_I4P_isOfDataType - procedure, public :: Free => DimensionsWrapper2D_I4P_Free - procedure, public :: Print => DimensionsWrapper2D_I4P_Print - final :: DimensionsWrapper2D_I4P_Final - end type - -public :: DimensionsWrapper2D_I4P_t - -contains - - - subroutine DimensionsWrapper2D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper2D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper2D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper2D_I4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this !< Dimensions wrapper 2D - integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1))*size(this%value) - end function DimensionsWrapper2D_I4P_DataSizeInBytes - - - function DimensionsWrapper2D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this !< Dimensions wrapper 2D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_I4P_isOfDataType - - - subroutine DimensionsWrapper2D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx))) // Sep - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper2D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper2D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_I4P_toString + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_I4P_isOfDataType + PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_I4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_I4P_Print + FINAL :: DimensionsWrapper2D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper2D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper2D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper2D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper2D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper2D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper2D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper2D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper2D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true.,n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper2D_I4P_Print - -end module DimensionsWrapper2D_I4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper2D_I4P_Print + +END MODULE DimensionsWrapper2D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 index dec2da4ae..2543623aa 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 @@ -18,224 +18,213 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper2D_I8P +MODULE DimensionsWrapper2D_I8P USE DimensionsWrapper2D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I8P_t - integer(I8P), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_I8P_Set - procedure, public :: Get => DimensionsWrapper2D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper2D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_I8P_toString - procedure, public :: Free => DimensionsWrapper2D_I8P_Free - procedure, public :: Print => DimensionsWrapper2D_I8P_Print - final :: DimensionsWrapper2D_I8P_Final - end type - -public :: DimensionsWrapper2D_I8P_t - -contains - - - subroutine DimensionsWrapper2D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper2D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper2D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper2D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this !< Dimensions wrapper 2D - integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1))*size(this%value) - end function DimensionsWrapper2D_I8P_DataSizeInBytes - - - function DimensionsWrapper2D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this !< Dimensions wrapper 2D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_I8P_isOfDataType - - - subroutine DimensionsWrapper2D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx))) // Sep - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper2D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE(:, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper2D_I8P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_I8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_I8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_I8P_Print + FINAL :: DimensionsWrapper2D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper2D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper2D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper2D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper2D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper2D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper2D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper2D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper2D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper2D_I8P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper2D_I8P_Print -end module DimensionsWrapper2D_I8P +END MODULE DimensionsWrapper2D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 index 65389e615..7889b0391 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 @@ -18,226 +18,216 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper2D_L +MODULE DimensionsWrapper2D_L USE DimensionsWrapper2D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_L_t - logical, allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_L_Set - procedure, public :: Get => DimensionsWrapper2D_L_Get - procedure, public :: GetShape => DimensionsWrapper2D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_L_toString - procedure, public :: Free => DimensionsWrapper2D_L_Free - procedure, public :: Print => DimensionsWrapper2D_L_Print - final :: DimensionsWrapper2D_L_Final - end type - -public :: DimensionsWrapper2D_L_t - -contains - - - subroutine DimensionsWrapper2D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper2D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper2D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper2D_L_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this !< Dimensions wrapper 2D - integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%value(1,1))*size(this%value) - end function DimensionsWrapper2D_L_DataSizeInBytes - - - function DimensionsWrapper2D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this !< Dimensions wrapper 2D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_L_isOfDataType - - - subroutine DimensionsWrapper2D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx1,idx2 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx2=1, size(this%Value,2) - do idx1=1, size(this%Value,1) - String = String // trim(str(n=this%Value(idx1,idx2))) // Sep - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper2D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper2D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper2D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_L_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_L_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_L_Print + FINAL :: DimensionsWrapper2D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper2D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper2D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper2D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper2D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this !< Dimensions wrapper 2D + INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size_logical(this%VALUE(1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper2D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper2D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this !< Dimensions wrapper 2D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper2D_L_isOfDataType + +SUBROUTINE DimensionsWrapper2D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx1, idx2 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx2 = 1, SIZE(this%VALUE, 2) + DO idx1 = 1, SIZE(this%VALUE, 1) + String = String//TRIM(str(n=this%VALUE(idx1, idx2)))//Sep + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper2D_L_Print - -end module DimensionsWrapper2D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper2D_L_Print + +END MODULE DimensionsWrapper2D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 index 6b9f749f5..cf0141077 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 @@ -18,224 +18,215 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper2D_R4P +MODULE DimensionsWrapper2D_R4P USE DimensionsWrapper2D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R4P_t - real(R4P), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_R4P_Set - procedure, public :: Get => DimensionsWrapper2D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper2D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_R4P_toString - procedure, public :: Free => DimensionsWrapper2D_R4P_Free - procedure, public :: Print => DimensionsWrapper2D_R4P_Print - final :: DimensionsWrapper2D_R4P_Final - end type - -public :: DimensionsWrapper2D_R4P_t - -contains - - - subroutine DimensionsWrapper2D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper2D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper2D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper2D_R4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this !< Dimensions wrapper 2D - integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1))*size(this%value) - end function DimensionsWrapper2D_R4P_DataSizeInBytes - - - function DimensionsWrapper2D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this !< Dimensions wrapper 2D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_R4P_isOfDataType - - - subroutine DimensionsWrapper2D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx))) // Sep - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper2D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper2D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper2D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_R4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_R4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_R4P_Print + FINAL :: DimensionsWrapper2D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper2D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper2D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper2D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper2D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper2D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper2D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper2D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper2D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper2D_R4P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper2D_R4P_Print -end module DimensionsWrapper2D_R4P +END MODULE DimensionsWrapper2D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 index 9d8fbd362..82f5b24ab 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 @@ -18,224 +18,214 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper2D_R8P - +MODULE DimensionsWrapper2D_R8P USE DimensionsWrapper2D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R8P_t - real(R8P), allocatable :: Value(:,:) - contains - private - procedure, public :: Set => DimensionsWrapper2D_R8P_Set - procedure, public :: Get => DimensionsWrapper2D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper2D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper2D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper2D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper2D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper2D_R8P_toString - procedure, public :: Free => DimensionsWrapper2D_R8P_Free - procedure, public :: Print => DimensionsWrapper2D_R8P_Print - final :: DimensionsWrapper2D_R8P_Final - end type - -public :: DimensionsWrapper2D_R8P_t - -contains - - - subroutine DimensionsWrapper2D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper2D - !----------------------------------------------------------------- - type(DimensionsWrapper2D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper2D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper2D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper2D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:) - !----------------------------------------------------------------- - Value => this%value - end function - - - subroutine DimensionsWrapper2D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper2D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper2D - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper2D_R8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of stored data - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this !< Dimensions wrapper 2D - integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1))*size(this%value) - end function DimensionsWrapper2D_R8P_DataSizeInBytes - - - function DimensionsWrapper2D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this !< Dimensions wrapper 2D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper2D_R8P_isOfDataType - - - subroutine DimensionsWrapper2D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx))) // Sep - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper2D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper2D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper2D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper2D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_R8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_R8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_R8P_Print + FINAL :: DimensionsWrapper2D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper2D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper2D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper2D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper2D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper2D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper2D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper2D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper2D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper2D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper2D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper2D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper2D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper2D_R8P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper2D_R8P_Print -end module DimensionsWrapper2D_R8P +END MODULE DimensionsWrapper2D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 index 880940708..1e35d3d2f 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 @@ -18,228 +18,217 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper3D_I4P +MODULE DimensionsWrapper3D_I4P USE DimensionsWrapper3D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I4P_t - integer(I4P), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_I4P_Set - procedure, public :: Get => DimensionsWrapper3D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper3D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_I4P_toString - procedure, public :: Free => DimensionsWrapper3D_I4P_Free - procedure, public :: Print => DimensionsWrapper3D_I4P_Print - final :: DimensionsWrapper3D_I4P_Final - end type - -public :: DimensionsWrapper3D_I4P_t - -contains - - - subroutine DimensionsWrapper3D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper3D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper3D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper3D_I4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_I4P_DataSizeInBytes - - - function DimensionsWrapper3D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this !< Dimensions wrapper 3D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_I4P_isOfDataType - - - subroutine DimensionsWrapper3D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper3D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper3D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_I4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_I4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_I4P_Print + FINAL :: DimensionsWrapper3D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper3D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper3D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper3D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper3D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper3D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper3D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper3D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper3D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper3D_I4P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper3D_I4P_Print -end module DimensionsWrapper3D_I4P +END MODULE DimensionsWrapper3D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 index 385d0299e..1cc9c9958 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 @@ -18,228 +18,217 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper3D_I8P +MODULE DimensionsWrapper3D_I8P USE DimensionsWrapper3D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I8P_t - integer(I8P), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_I8P_Set - procedure, public :: Get => DimensionsWrapper3D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper3D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_I8P_toString - procedure, public :: Free => DimensionsWrapper3D_I8P_Free - procedure, public :: Print => DimensionsWrapper3D_I8P_Print - final :: DimensionsWrapper3D_I8P_Final - end type - -public :: DimensionsWrapper3D_I8P_t - -contains - - - subroutine DimensionsWrapper3D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper3D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper3D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper3D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_I8P_DataSizeInBytes - - - function DimensionsWrapper3D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this !< Dimensions wrapper 3D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_I8P_isOfDataType - - - subroutine DimensionsWrapper3D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper3D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper3D_I8P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_I8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_I8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_I8P_Print + FINAL :: DimensionsWrapper3D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper3D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper3D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper3D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper3D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper3D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper3D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper3D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper3D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper3D_I8P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper3D_I8P_Print -end module DimensionsWrapper3D_I8P +END MODULE DimensionsWrapper3D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 index dad4c1c13..3ce39f6de 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 @@ -18,230 +18,220 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper3D_L +MODULE DimensionsWrapper3D_L USE DimensionsWrapper3D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_L_t - logical, allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_L_Set - procedure, public :: Get => DimensionsWrapper3D_L_Get - procedure, public :: GetShape => DimensionsWrapper3D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_L_toString - procedure, public :: Free => DimensionsWrapper3D_L_Free - procedure, public :: Print => DimensionsWrapper3D_L_Print - final :: DimensionsWrapper3D_L_Final - end type - -public :: DimensionsWrapper3D_L_t - -contains - - - subroutine DimensionsWrapper3D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper3D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper3D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper3D_L_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_L_DataSizeInBytes - - - function DimensionsWrapper3D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this !< Dimensions wrapper 3D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_L_isOfDataType - - - subroutine DimensionsWrapper3D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx1,idx2,idx3 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - do idx1=1, size(this%Value,1) - String = String // trim(str(n=this%Value(idx1,idx2,idx3))) // Sep - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper3D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper3D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper3D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_L_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_L_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_L_Print + FINAL :: DimensionsWrapper3D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper3D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper3D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper3D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS DEFAULT + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper3D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this !< Dimensions wrapper 3D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size_logical(this%VALUE(1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper3D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper3D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this !< Dimensions wrapper 3D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper3D_L_isOfDataType + +SUBROUTINE DimensionsWrapper3D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx1, idx2, idx3 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + DO idx1 = 1, SIZE(this%VALUE, 1) + String = String//TRIM(str(n=this%VALUE(idx1, idx2, idx3)))//Sep + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper3D_L_Print - -end module DimensionsWrapper3D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper3D_L_Print + +END MODULE DimensionsWrapper3D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 index 134fc66ab..ba2345933 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 @@ -18,227 +18,217 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper3D_R4P - +MODULE DimensionsWrapper3D_R4P USE DimensionsWrapper3D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R4P_t - real(R4P), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_R4P_Set - procedure, public :: Get => DimensionsWrapper3D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper3D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_R4P_toString - procedure, public :: Free => DimensionsWrapper3D_R4P_Free - procedure, public :: Print => DimensionsWrapper3D_R4P_Print - final :: DimensionsWrapper3D_R4P_Final - end type - -public :: DimensionsWrapper3D_R4P_t - -contains - - - subroutine DimensionsWrapper3D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper3D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper3D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper3D_R4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_R4P_DataSizeInBytes - - - function DimensionsWrapper3D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this !< Dimensions wrapper 3D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_R4P_isOfDataType - - - subroutine DimensionsWrapper3D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper3D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper3D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper3D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_R4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_R4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_R4P_Print + FINAL :: DimensionsWrapper3D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper3D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper3D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper3D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper3D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper3D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper3D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper3D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper3D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper3D_R4P_Print - -end module DimensionsWrapper3D_R4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper3D_R4P_Print + +END MODULE DimensionsWrapper3D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 index c349fdf60..dce85f477 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 @@ -18,228 +18,218 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper3D_R8P - +MODULE DimensionsWrapper3D_R8P USE DimensionsWrapper3D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R8P_t - real(R8P), allocatable :: Value(:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper3D_R8P_Set - procedure, public :: Get => DimensionsWrapper3D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper3D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper3D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper3D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper3D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper3D_R8P_toString - procedure, public :: Free => DimensionsWrapper3D_R8P_Free - procedure, public :: Print => DimensionsWrapper3D_R8P_Print - final :: DimensionsWrapper3D_R8P_Final - end type - -public :: DimensionsWrapper3D_R8P_t - -contains - - - subroutine DimensionsWrapper3D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper3D - !----------------------------------------------------------------- - type(DimensionsWrapper3D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper3D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper3D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper3D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper3D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper3D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper3D - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper3D_R8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size in bytes of the stored data - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this !< Dimensions wrapper 3D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value) - end function DimensionsWrapper3D_R8P_DataSizeInBytes - - - function DimensionsWrapper3D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this !< Dimensions wrapper 3D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper3D_R8P_isOfDataType - - - subroutine DimensionsWrapper3D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper3D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper3D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper3D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper3D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_R8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_R8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_R8P_Print + FINAL :: DimensionsWrapper3D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper3D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper3D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper3D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper3D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper3D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper3D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper3D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size in bytes of the stored data + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper3D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper3D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper3D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper3D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper3D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper3D_R8P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper3D_R8P_Print -end module DimensionsWrapper3D_R8P +END MODULE DimensionsWrapper3D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 index 9b3ff11dd..c9b842649 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 @@ -18,232 +18,221 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper4D_I4P +MODULE DimensionsWrapper4D_I4P USE DimensionsWrapper4D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I4P_t - integer(I4P), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_I4P_Set - procedure, public :: Get => DimensionsWrapper4D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper4D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_I4P_toString - procedure, public :: Print => DimensionsWrapper4D_I4P_Print - procedure, public :: Free => DimensionsWrapper4D_I4P_Free - final :: DimensionsWrapper4D_I4P_Final - end type - -public :: DimensionsWrapper4D_I4P_t - -contains - - - subroutine DimensionsWrapper4D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper4D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper4D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper4D_I4P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this !< Dimensions wrapper 4D - integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value) - end function DimensionsWrapper4D_I4P_DataSizeInBytes - - - function DimensionsWrapper4D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this !< Dimensions wrapper 4D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_I4P_isOfDataType - - - subroutine DimensionsWrapper4D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper4D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper4D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_I4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_I4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_I4P_Free + FINAL :: DimensionsWrapper4D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper4D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper4D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper4D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper4D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_I4P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper4D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper4D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper4D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper4D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper4D_I4P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper4D_I4P_Print -end module DimensionsWrapper4D_I4P +END MODULE DimensionsWrapper4D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 index a14b3381d..979311a24 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 @@ -18,233 +18,221 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper4D_I8P +MODULE DimensionsWrapper4D_I8P USE DimensionsWrapper4D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I8P_t - integer(I8P), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_I8P_Set - procedure, public :: Get => DimensionsWrapper4D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper4D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_I8P_toString - procedure, public :: Print => DimensionsWrapper4D_I8P_Print - procedure, public :: Free => DimensionsWrapper4D_I8P_Free - final :: DimensionsWrapper4D_I8P_Final - end type - -public :: DimensionsWrapper4D_I8P_t - -contains - - - subroutine DimensionsWrapper4D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper4D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - - subroutine DimensionsWrapper4D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper4D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper4D_I8P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this !< Dimensions wrapper 4D - integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value) - end function DimensionsWrapper4D_I8P_DataSizeInBytes - - - function DimensionsWrapper4D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this !< Dimensions wrapper 4D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_I8P_isOfDataType - - - subroutine DimensionsWrapper4D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper4D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper4D_I8P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_I8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_I8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_I8P_Free + FINAL :: DimensionsWrapper4D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper4D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper4D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper4D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper4D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_I8P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper4D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper4D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper4D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper4D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper4D_I8P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper4D_I8P_Print -end module DimensionsWrapper4D_I8P +END MODULE DimensionsWrapper4D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 index 9699fd431..d51d22414 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 @@ -18,235 +18,225 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper4D_L +MODULE DimensionsWrapper4D_L USE DimensionsWrapper4D USE FPL_Utils -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_L_t - logical, allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_L_Set - procedure, public :: Get => DimensionsWrapper4D_L_Get - procedure, public :: GetShape => DimensionsWrapper4D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_L_toString - procedure, public :: Print => DimensionsWrapper4D_L_Print - procedure, public :: Free => DimensionsWrapper4D_L_Free - final :: DimensionsWrapper4D_L_Final - end type - -public :: DimensionsWrapper4D_L_t - -contains - - - subroutine DimensionsWrapper4D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper4D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper4D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper4D_L_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this !< Dimensions wrapper 4D - integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%value(1,1,1,1))*size(this%value) - end function DimensionsWrapper4D_L_DataSizeInBytes - - - function DimensionsWrapper4D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this !< Dimensions wrapper 4D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_L_isOfDataType - - - subroutine DimensionsWrapper4D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx1,idx2,idx3,idx4 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - do idx1=1, size(this%Value,1) - String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4))) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper4D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper4D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper4D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_L_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_L_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_L_Free + FINAL :: DimensionsWrapper4D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper4D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper4D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper4D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper4D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_L_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this !< Dimensions wrapper 4D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value + !----------------------------------------------------------------- +DataSizeInBytes = byte_size_logical(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper4D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper4D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this !< Dimensions wrapper 4D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper4D_L_isOfDataType + +SUBROUTINE DimensionsWrapper4D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx1, idx2, idx3, idx4 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + DO idx1 = 1, SIZE(this%VALUE, 1) + String = String//TRIM(str(n=this%VALUE(idx1, idx2, idx3, idx4)))//Sep + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper4D_L_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper4D_L_Print -end module DimensionsWrapper4D_L +END MODULE DimensionsWrapper4D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 index 09e494310..33f145deb 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 @@ -18,232 +18,222 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper4D_R4P - +MODULE DimensionsWrapper4D_R4P USE DimensionsWrapper4D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R4P_t - real(R4P), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_R4P_Set - procedure, public :: Get => DimensionsWrapper4D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper4D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_R4P_toString - procedure, public :: Free => DimensionsWrapper4D_R4P_Free - procedure, public :: Print => DimensionsWrapper4D_R4P_Print - final :: DimensionsWrapper4D_R4P_Final - end type - -public :: DimensionsWrapper4D_R4P_t - -contains - - - subroutine DimensionsWrapper4D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper4D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper4D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper4D_R4P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this !< Dimensions wrapper 4D - integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value) - end function DimensionsWrapper4D_R4P_DataSizeInBytes - - - function DimensionsWrapper4D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this !< Dimensions wrapper 4D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_R4P_isOfDataType - - - subroutine DimensionsWrapper4D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper4D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper4D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper4D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_R4P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_R4P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_R4P_Print + FINAL :: DimensionsWrapper4D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper4D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper4D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper4D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper4D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_R4P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper4D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper4D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper4D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper4D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper4D_R4P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper4D_R4P_Print -end module DimensionsWrapper4D_R4P +END MODULE DimensionsWrapper4D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 index 400397aed..5ef56fa1b 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 @@ -18,232 +18,222 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper4D_R8P - +MODULE DimensionsWrapper4D_R8P USE DimensionsWrapper4D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R8P_t - real(R8P), allocatable :: Value(:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper4D_R8P_Set - procedure, public :: Get => DimensionsWrapper4D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper4D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper4D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper4D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper4D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper4D_R8P_toString - procedure, public :: Free => DimensionsWrapper4D_R8P_Free - procedure, public :: Print => DimensionsWrapper4D_R8P_Print - final :: DimensionsWrapper4D_R8P_Final - end type - -public :: DimensionsWrapper4D_R8P_t - -contains - - - subroutine DimensionsWrapper4D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper4D - !----------------------------------------------------------------- - type(DimensionsWrapper4D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper4D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper4D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper4D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper4D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper4D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper4D - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper4D_R8P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the data size of the stored value in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this !< Dimensions wrapper 4D - integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value) - end function DimensionsWrapper4D_R8P_DataSizeInBytes - - - function DimensionsWrapper4D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this !< Dimensions wrapper 4D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper4D_R8P_isOfDataType - - - subroutine DimensionsWrapper4D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper4D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper4D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper4D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper4D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_R8P_toString + PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_R8P_Free + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_R8P_Print + FINAL :: DimensionsWrapper4D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper4D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper4D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper4D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper4D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper4D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper4D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper4D_R8P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the data size of the stored value in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper4D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper4D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper4D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper4D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper4D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper4D_R8P_Print + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper4D_R8P_Print -end module DimensionsWrapper4D_R8P +END MODULE DimensionsWrapper4D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 index e78e2ed6e..168d20e4c 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 @@ -18,236 +18,225 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper5D_I2P +MODULE DimensionsWrapper5D_I2P USE DimensionsWrapper5D -USE PENF, only: I2P, I4P, str, byte_size +USE PENF, ONLY: I2P, I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I2P_t - integer(I2P), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_I2P_Set - procedure, public :: Get => DimensionsWrapper5D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper5D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_I2P_toString - procedure, public :: Print => DimensionsWrapper5D_I2P_Print - procedure, public :: Free => DimensionsWrapper5D_I2P_Free - final :: DimensionsWrapper5D_I2P_Final - end type - -public :: DimensionsWrapper5D_I2P_t - -contains - - - subroutine DimensionsWrapper5D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I2P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I2P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper5D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper5D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper5D_I2P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_I2P_DataSizeInBytes - - - function DimensionsWrapper5D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this !< Dimensions wrapper 5D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_I2P_isOfDataType - - - subroutine DimensionsWrapper5D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper5D_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I2P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I2P_t + INTEGER(I2P), ALLOCATABLE :: VALUE(:, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_I2P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_I2P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_I2P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_I2P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_I2P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I2P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_I2P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_I2P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_I2P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_I2P_Free + FINAL :: DimensionsWrapper5D_I2P_Final +END TYPE + +PUBLIC :: DimensionsWrapper5D_I2P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper5D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper5D_I2P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I2P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I2P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_I2P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper5D_I2P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_I2P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper5D_I2P_DataSizeInBytes + +FUNCTION DimensionsWrapper5D_I2P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I2P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper5D_I2P_isOfDataType + +SUBROUTINE DimensionsWrapper5D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I2P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper5D_I2P_Print - -end module DimensionsWrapper5D_I2P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper5D_I2P_Print + +END MODULE DimensionsWrapper5D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 index 3fbd5a841..e2aba1e33 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 @@ -18,235 +18,224 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper5D_I4P +MODULE DimensionsWrapper5D_I4P USE DimensionsWrapper5D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I4P_t - integer(I4P), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_I4P_Set - procedure, public :: Get => DimensionsWrapper5D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper5D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_I4P_toString - procedure, public :: Print => DimensionsWrapper5D_I4P_Print - procedure, public :: Free => DimensionsWrapper5D_I4P_Free - final :: DimensionsWrapper5D_I4P_Final - end type - -public :: DimensionsWrapper5D_I4P_t - -contains - - - subroutine DimensionsWrapper5D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5)), & - source=Value, stat=err) - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper5D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper5D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper5D_I4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_I4P_DataSizeInBytes - - - function DimensionsWrapper5D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this !< Dimensions wrapper 5D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_I4P_isOfDataType - - - subroutine DimensionsWrapper5D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper5D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_I4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_I4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_I4P_Free + FINAL :: DimensionsWrapper5D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper5D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper5D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper5D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5)), & + source=VALUE, stat=err) + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper5D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper5D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper5D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper5D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper5D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper5D_I4P_Print - -end module DimensionsWrapper5D_I4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper5D_I4P_Print + +END MODULE DimensionsWrapper5D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 index af5fc8610..304c74cad 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 @@ -18,235 +18,225 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper5D_I8P +MODULE DimensionsWrapper5D_I8P USE DimensionsWrapper5D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I8P_t - integer(I8P), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_I8P_Set - procedure, public :: Get => DimensionsWrapper5D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper5D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_I8P_toString - procedure, public :: Print => DimensionsWrapper5D_I8P_Print - procedure, public :: Free => DimensionsWrapper5D_I8P_Free - final :: DimensionsWrapper5D_I8P_Final - end type - -public :: DimensionsWrapper5D_I8P_t - -contains - - - subroutine DimensionsWrapper5D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper5D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - subroutine DimensionsWrapper5D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper5D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper5D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_I8P_DataSizeInBytes - - - function DimensionsWrapper5D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this !< Dimensions wrapper 5D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_I8P_isOfDataType - - - subroutine DimensionsWrapper5D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper5D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_I8P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_I8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_I8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_I8P_Free + FINAL :: DimensionsWrapper5D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper5D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper5D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper5D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper5D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper5D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper5D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper5D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper5D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper5D_I8P_Print - -end module DimensionsWrapper5D_I8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper5D_I8P_Print + +END MODULE DimensionsWrapper5D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 index ec5e237e9..02214dca9 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 @@ -18,239 +18,229 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper5D_L +MODULE DimensionsWrapper5D_L USE DimensionsWrapper5D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_L_t - logical, allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_L_Set - procedure, public :: Get => DimensionsWrapper5D_L_Get - procedure, public :: GetShape => DimensionsWrapper5D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_L_toString - procedure, public :: Print => DimensionsWrapper5D_L_Print - procedure, public :: Free => DimensionsWrapper5D_L_Free - final :: DimensionsWrapper5D_L_Final - end type - -public :: DimensionsWrapper5D_L_t - -contains - - - subroutine DimensionsWrapper5D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper5D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper5D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper5D_L_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_L_DataSizeInBytes - - - function DimensionsWrapper5D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this !< Dimensions wrapper 5D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_L_isOfDataType - - - subroutine DimensionsWrapper5D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx1,idx2,idx3,idx4,idx5 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - do idx1=1, size(this%Value,1) - String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4,idx5))) // Sep - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper5D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper5D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_L_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_L_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_L_Free + FINAL :: DimensionsWrapper5D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper5D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper5D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper5D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper5D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this !< Dimensions wrapper 5D + INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper5D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper5D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this !< Dimensions wrapper 5D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper5D_L_isOfDataType + +SUBROUTINE DimensionsWrapper5D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx1, idx2, idx3, idx4, idx5 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + DO idx1 = 1, SIZE(this%VALUE, 1) + String = String//TRIM(str(n=this%VALUE(idx1, idx2, idx3, idx4, idx5)))//Sep + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper5D_L_Print - -end module DimensionsWrapper5D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper5D_L_Print + +END MODULE DimensionsWrapper5D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 index b340628f6..d3c382bab 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 @@ -18,236 +18,227 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper5D_R4P +MODULE DimensionsWrapper5D_R4P USE DimensionsWrapper5D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R4P_t - real(R4P), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_R4P_Set - procedure, public :: Get => DimensionsWrapper5D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper5D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_R4P_toString - procedure, public :: Print => DimensionsWrapper5D_R4P_Print - procedure, public :: Free => DimensionsWrapper5D_R4P_Free - final :: DimensionsWrapper5D_R4P_Final - end type - -public :: DimensionsWrapper5D_R4P_t - -contains - - - subroutine DimensionsWrapper5D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper5D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper5D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper5D_R4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_R4P_DataSizeInBytes - - - function DimensionsWrapper5D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this !< Dimensions wrapper 5D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_R4P_isOfDataType - - - subroutine DimensionsWrapper5D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper5D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper5D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper5D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_R4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_R4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_R4P_Free + FINAL :: DimensionsWrapper5D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper5D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper5D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper5D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper5D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper5D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper5D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper5D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper5D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper5D_R4P_Print - -end module DimensionsWrapper5D_R4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper5D_R4P_Print + +END MODULE DimensionsWrapper5D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 index 3521ff661..99d50db80 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 @@ -18,236 +18,226 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper5D_R8P - +MODULE DimensionsWrapper5D_R8P USE DimensionsWrapper5D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R8P_t - real(R8P), allocatable :: Value(:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper5D_R8P_Set - procedure, public :: Get => DimensionsWrapper5D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper5D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper5D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper5D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper5D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper5D_R8P_toString - procedure, public :: Print => DimensionsWrapper5D_R8P_Print - procedure, public :: Free => DimensionsWrapper5D_R8P_Free - final :: DimensionsWrapper5D_R8P_Final - end type - -public :: DimensionsWrapper5D_R8P_t - -contains - - - subroutine DimensionsWrapper5D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper5D - !----------------------------------------------------------------- - type(DimensionsWrapper5D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper5D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper5D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper5D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper5D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper5D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper5D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper5D - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper5D_R8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this !< Dimensions wrapper 5D - integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value) - end function DimensionsWrapper5D_R8P_DataSizeInBytes - - - function DimensionsWrapper5D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this !< Dimensions wrapper 5D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper5D_R8P_isOfDataType - - - subroutine DimensionsWrapper5D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper5D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper5D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper5D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper5D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_R8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_R8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_R8P_Free + FINAL :: DimensionsWrapper5D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper5D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper5D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper5D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper5D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper5D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper5D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper5D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper5D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper5D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper5D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper5D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper5D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper5D_R8P_Print - -end module DimensionsWrapper5D_R8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper5D_R8P_Print + +END MODULE DimensionsWrapper5D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 index 7d1841fdc..a14549ddc 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 @@ -18,240 +18,229 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper6D_I2P +MODULE DimensionsWrapper6D_I2P USE DimensionsWrapper6D -USE PENF, only: I2P, I4P, str, byte_size +USE PENF, ONLY: I2P, I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I2P_t - integer(I2P), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_I2P_Set - procedure, public :: Get => DimensionsWrapper6D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper6D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_I2P_toString - procedure, public :: Print => DimensionsWrapper6D_I2P_Print - procedure, public :: Free => DimensionsWrapper6D_I2P_Free - final :: DimensionsWrapper6D_I2P_Final - end type - -public :: DimensionsWrapper6D_I2P_t - -contains - - - subroutine DimensionsWrapper6D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I2P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I2P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper6D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper6D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper6D_I2P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_I2P_DataSizeInBytes - - - function DimensionsWrapper6D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this !< Dimensions wrapper 6D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_I2P_isOfDataType - - - subroutine DimensionsWrapper6D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper6D_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I2P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I2P_t + INTEGER(I2P), ALLOCATABLE :: VALUE(:, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_I2P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_I2P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_I2P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_I2P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_I2P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I2P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_I2P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_I2P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_I2P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_I2P_Free + FINAL :: DimensionsWrapper6D_I2P_Final +END TYPE + +PUBLIC :: DimensionsWrapper6D_I2P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper6D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper6D_I2P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I2P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I2P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_I2P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper6D_I2P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_I2P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper6D_I2P_DataSizeInBytes + +FUNCTION DimensionsWrapper6D_I2P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I2P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper6D_I2P_isOfDataType + +SUBROUTINE DimensionsWrapper6D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) +String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I2P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper6D_I2P_Print - -end module DimensionsWrapper6D_I2P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper6D_I2P_Print + +END MODULE DimensionsWrapper6D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 index c91f3141b..83de84e21 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 @@ -18,240 +18,229 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper6D_I4P +MODULE DimensionsWrapper6D_I4P USE DimensionsWrapper6D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I4P_t - integer(I4P), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_I4P_Set - procedure, public :: Get => DimensionsWrapper6D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper6D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_I4P_toString - procedure, public :: Print => DimensionsWrapper6D_I4P_Print - procedure, public :: Free => DimensionsWrapper6D_I4P_Free - final :: DimensionsWrapper6D_I4P_Final - end type - -public :: DimensionsWrapper6D_I4P_t - -contains - - - subroutine DimensionsWrapper6D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper6D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper6D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper6D_I4P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_I4P_DataSizeInBytes - - - function DimensionsWrapper6D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this !< Dimensions wrapper 6D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_I4P_isOfDataType - - - subroutine DimensionsWrapper6D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper6D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_I4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_I4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_I4P_Free + FINAL :: DimensionsWrapper6D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper6D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper6D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper6D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper6D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_I4P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper6D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper6D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper6D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper6D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) +String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper6D_I4P_Print - -end module DimensionsWrapper6D_I4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper6D_I4P_Print + +END MODULE DimensionsWrapper6D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 index 754a73cdc..2709bdb84 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 @@ -18,241 +18,229 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper6D_I8P +MODULE DimensionsWrapper6D_I8P USE DimensionsWrapper6D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages - -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I8P_t - integer(I8P), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_I8P_Set - procedure, public :: Get => DimensionsWrapper6D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper6D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_I8P_toString - procedure, public :: Print => DimensionsWrapper6D_I8P_Print - procedure, public :: Free => DimensionsWrapper6D_I8P_Free - final :: DimensionsWrapper6D_I8P_Final - end type - -public :: DimensionsWrapper6D_I8P_t - -contains - - - subroutine DimensionsWrapper6D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper6D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper6D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper6D_I8P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_I8P_DataSizeInBytes - - - function DimensionsWrapper6D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this !< Dimensions wrapper 6D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_I8P_isOfDataType - - - subroutine DimensionsWrapper6D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper6D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_I8P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_I8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_I8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_I8P_Free + FINAL :: DimensionsWrapper6D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper6D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper6D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper6D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper6D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_I8P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper6D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper6D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper6D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper6D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) +String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper6D_I8P_Print - -end module DimensionsWrapper6D_I8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper6D_I8P_Print + +END MODULE DimensionsWrapper6D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 index 657218d52..2e8c0a1b8 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 @@ -18,243 +18,233 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper6D_L +MODULE DimensionsWrapper6D_L USE DimensionsWrapper6D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_L_t - logical, allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_L_Set - procedure, public :: Get => DimensionsWrapper6D_L_Get - procedure, public :: GetShape => DimensionsWrapper6D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_L_toString - procedure, public :: Print => DimensionsWrapper6D_L_Print - procedure, public :: Free => DimensionsWrapper6D_L_Free - final :: DimensionsWrapper6D_L_Final - end type - -public :: DimensionsWrapper6D_L_t - -contains - - - subroutine DimensionsWrapper6D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper6D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper6D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper6D_L_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_L_DataSizeInBytes - - - function DimensionsWrapper6D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this !< Dimensions wrapper 6D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_L_isOfDataType - - - subroutine DimensionsWrapper6D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx1,idx2,idx3,idx4,idx5,idx6 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - do idx1=1, size(this%Value,1) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper6D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_L_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_L_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_L_Free + FINAL :: DimensionsWrapper6D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper6D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper6D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper6D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper6D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_L_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this !< Dimensions wrapper 6D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper6D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper6D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this !< Dimensions wrapper 6D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper6D_L_isOfDataType + +SUBROUTINE DimensionsWrapper6D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx1, idx2, idx3, idx4, idx5, idx6 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + DO idx1 = 1, SIZE(this%VALUE, 1) String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4,idx5,idx6))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper6D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper6D_L_Print - -end module DimensionsWrapper6D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper6D_L_Print + +END MODULE DimensionsWrapper6D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 index c5f84b200..66fb52d5f 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 @@ -18,240 +18,230 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper6D_R4P - +MODULE DimensionsWrapper6D_R4P USE DimensionsWrapper6D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R4P_t - real(R4P), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_R4P_Set - procedure, public :: Get => DimensionsWrapper6D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper6D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_R4P_toString - procedure, public :: Print => DimensionsWrapper6D_R4P_Print - procedure, public :: Free => DimensionsWrapper6D_R4P_Free - final :: DimensionsWrapper6D_R4P_Final - end type - -public :: DimensionsWrapper6D_R4P_t - -contains - - - subroutine DimensionsWrapper6D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper6D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper6D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper6D_R4P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_R4P_DataSizeInBytes - - - function DimensionsWrapper6D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this !< Dimensions wrapper 6D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_R4P_isOfDataType - - - subroutine DimensionsWrapper6D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper6D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper6D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper6D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_R4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_R4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_R4P_Free + FINAL :: DimensionsWrapper6D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper6D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper6D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper6D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper6D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_R4P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper6D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper6D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper6D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper6D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) +String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper6D_R4P_Print - -end module DimensionsWrapper6D_R4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper6D_R4P_Print + +END MODULE DimensionsWrapper6D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 index a9864c4a6..82c0130fe 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 @@ -18,240 +18,230 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper6D_R8P - +MODULE DimensionsWrapper6D_R8P USE DimensionsWrapper6D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R8P_t - real(R8P), allocatable :: Value(:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper6D_R8P_Set - procedure, public :: Get => DimensionsWrapper6D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper6D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper6D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper6D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper6D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper6D_R8P_toString - procedure, public :: Print => DimensionsWrapper6D_R8P_Print - procedure, public :: Free => DimensionsWrapper6D_R8P_Free - final :: DimensionsWrapper6D_R8P_Final - end type - -public :: DimensionsWrapper6D_R8P_t - -contains - - - subroutine DimensionsWrapper6D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper6D - !----------------------------------------------------------------- - type(DimensionsWrapper6D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper6D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - - end select - end subroutine - - - subroutine DimensionsWrapper6D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper6D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper6D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper6D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper6D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper6D - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper6D_R8P_DataSizeInBytes(this) result(DatasizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the stored data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this !< Dimensions wrapper 6D - integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper6D_R8P_DataSizeInBytes - - - function DimensionsWrapper6D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this !< Dimensions wrapper 6D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper6D_R8P_isOfDataType - - - subroutine DimensionsWrapper6D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper6D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper6D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper6D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper6D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_R8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_R8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_R8P_Free + FINAL :: DimensionsWrapper6D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper6D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper6D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper6D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper6D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper6D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper6D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper6D_R8P_DataSizeInBytes(this) RESULT(DatasizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the stored data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE) +END FUNCTION DimensionsWrapper6D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper6D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper6D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper6D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) +String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper6D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper6D_R8P_Print - -end module DimensionsWrapper6D_R8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper6D_R8P_Print + +END MODULE DimensionsWrapper6D_R8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 index 1f1bf25f4..366c8a297 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 @@ -1,6 +1,6 @@ !----------------------------------------------------------------- ! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, ! Javier Principe and Víctor Sande. ! All rights reserved. ! @@ -18,47 +18,47 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D +MODULE DimensionsWrapper7D USE DimensionsWrapper -implicit none -private +IMPLICIT NONE +PRIVATE - type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper7D_t - private - contains - procedure(DimensionsWrapper7D_Set), deferred :: Set - procedure(DimensionsWrapper7D_Get), deferred :: Get - procedure(DimensionsWrapper7D_GetPointer), deferred :: GetPointer - end type +TYPE, EXTENDS(DimensionsWrapper_t), ABSTRACT :: DimensionsWrapper7D_t + PRIVATE +CONTAINS + PROCEDURE(DimensionsWrapper7D_Set), DEFERRED :: Set + PROCEDURE(DimensionsWrapper7D_Get), DEFERRED :: Get + PROCEDURE(DimensionsWrapper7D_GetPointer), DEFERRED :: GetPointer +END TYPE - abstract interface - subroutine DimensionsWrapper7D_Set(this, Value) - import DimensionsWrapper7D_t - class(DimensionsWrapper7D_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - end subroutine +ABSTRACT INTERFACE + SUBROUTINE DimensionsWrapper7D_Set(this, VALUE) + IMPORT DimensionsWrapper7D_t + CLASS(DimensionsWrapper7D_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + END SUBROUTINE - subroutine DimensionsWrapper7D_Get(this, Value) - import DimensionsWrapper7D_t - class(DimensionsWrapper7D_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - end subroutine + SUBROUTINE DimensionsWrapper7D_Get(this, VALUE) + IMPORT DimensionsWrapper7D_t + CLASS(DimensionsWrapper7D_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + END SUBROUTINE - function DimensionsWrapper7D_GetPointer(this) result(Value) - import DimensionsWrapper7D_t - class(DimensionsWrapper7D_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - end function + FUNCTION DimensionsWrapper7D_GetPointer(this) RESULT(VALUE) + IMPORT DimensionsWrapper7D_t + CLASS(DimensionsWrapper7D_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + END FUNCTION - subroutine DimensionsWrapper7D_GetPolymorphic(this, Value) - import DimensionsWrapper7D_t - class(DimensionsWrapper7D_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - end subroutine - end interface + SUBROUTINE DimensionsWrapper7D_GetPolymorphic(this, VALUE) + IMPORT DimensionsWrapper7D_t + CLASS(DimensionsWrapper7D_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + END SUBROUTINE +END INTERFACE -public :: DimensionsWrapper7D_t +PUBLIC :: DimensionsWrapper7D_t -end module DimensionsWrapper7D +END MODULE DimensionsWrapper7D diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 index b86dc8c82..389cdf214 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 @@ -18,243 +18,232 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D_I2P +MODULE DimensionsWrapper7D_I2P USE DimensionsWrapper7D -USE PENF, only: I2P, I4P, str, byte_size +USE PENF, ONLY: I2P, I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I2P_t - integer(I2P), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_I2P_Set - procedure, public :: Get => DimensionsWrapper7D_I2P_Get - procedure, public :: GetShape => DimensionsWrapper7D_I2P_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_I2P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_I2P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I2P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_I2P_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_I2P_toString - procedure, public :: Print => DimensionsWrapper7D_I2P_Print - procedure, public :: Free => DimensionsWrapper7D_I2P_Free - final :: DimensionsWrapper7D_I2P_Final - end type - -public :: DimensionsWrapper7D_I2P_t - -contains - - - subroutine DimensionsWrapper7D_I2P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_I2P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_I2P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6), & - size(Value,dim=7)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I2P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I2P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I2P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I2P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I2P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I2P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper7D_I2P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_I2P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6), & - size(this%Value,dim=7)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper7D_I2P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper7D_i2p_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_i2p_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: DataSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_i2p_DataSizeInBytes - - - function DimensionsWrapper7D_I2P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(IN) :: this !< Dimensions wrapper 7D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I2P)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_I2P_isOfDataType - - - subroutine DimensionsWrapper7D_I2P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx7=1, size(this%Value,7) - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I2P_t + INTEGER(I2P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_I2P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_I2P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_I2P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_I2P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper7D_I2P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I2P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_I2P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_I2P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_I2P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_I2P_Free + FINAL :: DimensionsWrapper7D_I2P_Final +END TYPE + +PUBLIC :: DimensionsWrapper7D_I2P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper7D_I2P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper7D_I2P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I2P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I2P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6), & + SIZE(VALUE, dim=7)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I2P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I2P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I2P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I2P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_I2P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper7D_I2P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6), & + SIZE(this%VALUE, dim=7)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I2P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_i2p_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_i2p_t), INTENT(IN) :: this !< Dimensions wrapper 7D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper7D_i2p_DataSizeInBytes + +FUNCTION DimensionsWrapper7D_I2P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I2P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper7D_I2P_isOfDataType + +SUBROUTINE DimensionsWrapper7D_I2P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx7 = 1, SIZE(this%VALUE, 7) + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper7D_I2P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I2P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I2P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I2P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper7D_I2P_Print - -end module DimensionsWrapper7D_I2P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper7D_I2P_Print + +END MODULE DimensionsWrapper7D_I2P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 index 32f371693..bc8427e96 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 @@ -18,243 +18,232 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D_I4P +MODULE DimensionsWrapper7D_I4P USE DimensionsWrapper7D -USE PENF, only: I4P, str, byte_size +USE PENF, ONLY: I4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I4P_t - integer(I4P), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_I4P_Set - procedure, public :: Get => DimensionsWrapper7D_I4P_Get - procedure, public :: GetShape => DimensionsWrapper7D_I4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_I4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_I4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_I4P_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_I4P_toString - procedure, public :: Print => DimensionsWrapper7D_I4P_Print - procedure, public :: Free => DimensionsWrapper7D_I4P_Free - final :: DimensionsWrapper7D_I4P_Final - end type - -public :: DimensionsWrapper7D_I4P_t - -contains - - - subroutine DimensionsWrapper7D_I4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_I4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_I4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6), & - size(Value,dim=7)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper7D_I4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_I4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6), & - size(this%Value,dim=7)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper7D_I4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper7D_I4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: DataSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_I4P_DataSizeInBytes - - - function DimensionsWrapper7D_I4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this !< Dimensions wrapper 7D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_I4P_isOfDataType - - - subroutine DimensionsWrapper7D_I4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx7=1, size(this%Value,7) - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I4P_t + INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_I4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_I4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_I4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_I4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper7D_I4P_GetPolymorphic +procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_I4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_I4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_I4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_I4P_Free + FINAL :: DimensionsWrapper7D_I4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper7D_I4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper7D_I4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper7D_I4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6), & + SIZE(VALUE, dim=7)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_I4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper7D_I4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6), & + SIZE(this%VALUE, dim=7)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper7D_I4P_DataSizeInBytes + +FUNCTION DimensionsWrapper7D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper7D_I4P_isOfDataType + +SUBROUTINE DimensionsWrapper7D_I4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx7 = 1, SIZE(this%VALUE, 7) + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper7D_I4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper7D_I4P_Print - -end module DimensionsWrapper7D_I4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper7D_I4P_Print + +END MODULE DimensionsWrapper7D_I4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 index a6cbcaa18..90caf57f2 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 @@ -18,243 +18,234 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D_I8P +MODULE DimensionsWrapper7D_I8P USE DimensionsWrapper7D -USE PENF, only: I4P, I8P, str, byte_size +USE PENF, ONLY: I4P, I8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I8P_t - integer(I8P), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_I8P_Set - procedure, public :: Get => DimensionsWrapper7D_I8P_Get - procedure, public :: GetShape => DimensionsWrapper7D_I8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_I8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_I8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_I8P_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_I8P_toString - procedure, public :: Print => DimensionsWrapper7D_I8P_Print - procedure, public :: Free => DimensionsWrapper7D_I8P_Free - final :: DimensionsWrapper7D_I8P_Final - end type - -public :: DimensionsWrapper7D_I8P_t - -contains - - - subroutine DimensionsWrapper7D_I8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_I8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_I8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6), & - size(Value,dim=7)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (I8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get I8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (integer(I8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (I8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_I8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper7D_I8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_I8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6), & - size(this%Value,dim=7)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper7D_I8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper7D_I8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: DataSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_I8P_DataSizeInBytes - - - function DimensionsWrapper7D_I8P_isOfDataType(this, Mold) result(isOfDataType) - !---------------------------------------- procedure, public :: toString => DimensionsWrapper7D_R8P_toString------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this !< Dimensions wrapper 7D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (integer(I8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_I8P_isOfDataType - - - subroutine DimensionsWrapper7D_I8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx7=1, size(this%Value,7) - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I8P_t + INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_I8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_I8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_I8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_I8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper7D_I8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper7D_I8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_I8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_I8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_I8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_I8P_Free + FINAL :: DimensionsWrapper7D_I8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper7D_I8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper7D_I8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper7D_I8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6), & + SIZE(VALUE, dim=7)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get I8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (INTEGER(I8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (I8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_I8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper7D_I8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6), & + SIZE(this%VALUE, dim=7)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper7D_I8P_DataSizeInBytes + +FUNCTION DimensionsWrapper7D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !---------------------------------------- procedure, public :: toString => DimensionsWrapper7D_R8P_toString------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (INTEGER(I8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper7D_I8P_isOfDataType + +SUBROUTINE DimensionsWrapper7D_I8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx7 = 1, SIZE(this%VALUE, 7) + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper7D_I8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_I8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_I8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper7D_I8P_Print - -end module DimensionsWrapper7D_I8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper7D_I8P_Print + +END MODULE DimensionsWrapper7D_I8P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 index 08dc231a5..78da6401c 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 @@ -18,245 +18,235 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D_L - +MODULE DimensionsWrapper7D_L USE DimensionsWrapper7D USE FPL_Utils -USE PENF, only: I4P, str +USE PENF, ONLY: I4P, str USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_L_t - logical, allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_L_Set - procedure, public :: Get => DimensionsWrapper7D_L_Get - procedure, public :: GetShape => DimensionsWrapper7D_L_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_L_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_L_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_L_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_L_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_L_toString - procedure, public :: Print => DimensionsWrapper7D_L_Print - procedure, public :: Free => DimensionsWrapper7D_L_Free - final :: DimensionsWrapper7D_L_Final - end type - -public :: DimensionsWrapper7D_L_t - -contains - - - subroutine DimensionsWrapper7D_L_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_L_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_L_Set(this, Value) - !----------------------------------------------------------------- - !< Set logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (logical) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6), & - size(Value,dim=7)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (logical)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_L_Get(this, Value) - !----------------------------------------------------------------- - !< Get logical Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (logical) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (L)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_L_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - function DimensionsWrapper7D_L_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_L_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6), & - size(this%Value,dim=7)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper7D_L_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper7D_L_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: DataSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_L_t + LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_L_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_L_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_L_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_L_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper7D_L_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper7D_L_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_L_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_L_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_L_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_L_Free + FINAL :: DimensionsWrapper7D_L_Final +END TYPE + +PUBLIC :: DimensionsWrapper7D_L_t + +CONTAINS + +SUBROUTINE DimensionsWrapper7D_L_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper7D_L_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_L_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6), & + SIZE(VALUE, dim=7)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (logical)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_L_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get logical Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (LOGICAL) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (L)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_L_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_L_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper7D_L_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6), & + SIZE(this%VALUE, dim=7)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_L_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this !< Dimensions wrapper 7D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_L_DataSizeInBytes - - - function DimensionsWrapper7D_L_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this !< Dimensions wrapper 7D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (logical) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_L_isOfDataType - - - subroutine DimensionsWrapper7D_L_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx1,idx2,idx3,idx4,idx5,idx6,idx7 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx7=1, size(this%Value,7) - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) - do idx1=1, size(this%Value,1) +END FUNCTION DimensionsWrapper7D_L_DataSizeInBytes + +FUNCTION DimensionsWrapper7D_L_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this !< Dimensions wrapper 7D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (LOGICAL) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper7D_L_isOfDataType + +SUBROUTINE DimensionsWrapper7D_L_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx1, idx2, idx3, idx4, idx5, idx6, idx7 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx7 = 1, SIZE(this%VALUE, 7) + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) + DO idx1 = 1, SIZE(this%VALUE, 1) String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper7D_L_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_L_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_L_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper7D_L_Print - -end module DimensionsWrapper7D_L + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper7D_L_Print + +END MODULE DimensionsWrapper7D_L diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 index cbd5cc5a9..090b3e31f 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 @@ -18,243 +18,234 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D_R4P +MODULE DimensionsWrapper7D_R4P USE DimensionsWrapper7D -USE PENF, only: I4P, R4P, str, byte_size +USE PENF, ONLY: I4P, R4P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R4P_t - real(R4P), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_R4P_Set - procedure, public :: Get => DimensionsWrapper7D_R4P_Get - procedure, public :: GetShape => DimensionsWrapper7D_R4P_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_R4P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_R4P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_R4P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_R4P_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_R4P_toString - procedure, public :: Print => DimensionsWrapper7D_R4P_Print - procedure, public :: Free => DimensionsWrapper7D_R4P_Free - final :: DimensionsWrapper7D_R4P_Final - end type - -public :: DimensionsWrapper7D_R4P_t - -contains - - - subroutine DimensionsWrapper7D_R4P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_R4P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_R4P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6), & - size(Value,dim=7)), & - stat=err) - this%Value = Value - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R4P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_R4P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R4P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R4P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R4P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_R4P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper7D_R4P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_R4P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6), & - size(this%Value,dim=7)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper7D_R4P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper7D_R4P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: DataSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_R4P_DataSizeInBytes - - - function DimensionsWrapper7D_R4P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this !< Dimensions wrapper 7D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R4P)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_R4P_isOfDataType - - - subroutine DimensionsWrapper7D_R4P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx7=1, size(this%Value,7) - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R4P_t + REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_R4P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_R4P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_R4P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_R4P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper7D_R4P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper7D_R4P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_R4P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_R4P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_R4P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_R4P_Free + FINAL :: DimensionsWrapper7D_R4P_Final +END TYPE + +PUBLIC :: DimensionsWrapper7D_R4P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper7D_R4P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper7D_R4P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R4P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6), & + SIZE(VALUE, dim=7)), & + stat=err) + this%VALUE = VALUE + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R4P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R4P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R4P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R4P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_R4P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper7D_R4P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6), & + SIZE(this%VALUE, dim=7)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R4P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper7D_R4P_DataSizeInBytes + +FUNCTION DimensionsWrapper7D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R4P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper7D_R4P_isOfDataType + +SUBROUTINE DimensionsWrapper7D_R4P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx7 = 1, SIZE(this%VALUE, 7) + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper7D_R4P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R4P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R4P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper7D_R4P_Print - -end module DimensionsWrapper7D_R4P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper7D_R4P_Print + +END MODULE DimensionsWrapper7D_R4P diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 index 90c0581ad..2f05ffbb0 100644 --- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 +++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 @@ -18,242 +18,232 @@ ! License along with this library. !----------------------------------------------------------------- -module DimensionsWrapper7D_R8P - +MODULE DimensionsWrapper7D_R8P USE DimensionsWrapper7D -USE PENF, only: I4P, R8P, str, byte_size +USE PENF, ONLY: I4P, R8P, str, byte_size USE ErrorMessages -implicit none -private - - type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R8P_t - real(R8P), allocatable :: Value(:,:,:,:,:,:,:) - contains - private - procedure, public :: Set => DimensionsWrapper7D_R8P_Set - procedure, public :: Get => DimensionsWrapper7D_R8P_Get - procedure, public :: GetShape => DimensionsWrapper7D_R8P_GetShape - procedure, public :: GetPointer => DimensionsWrapper7D_R8P_GetPointer - procedure, public :: GetPolymorphic => DimensionsWrapper7D_R8P_GetPolymorphic - procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_R8P_DataSizeInBytes - procedure, public :: isOfDataType => DimensionsWrapper7D_R8P_isOfDataType - procedure, public :: toString => DimensionsWrapper7D_R8P_toString - procedure, public :: Print => DimensionsWrapper7D_R8P_Print - procedure, public :: Free => DimensionsWrapper7D_R8P_Free - final :: DimensionsWrapper7D_R8P_Final - end type - -public :: DimensionsWrapper7D_R8P_t - -contains - - - subroutine DimensionsWrapper7D_R8P_Final(this) - !----------------------------------------------------------------- - !< Final procedure of DimensionsWrapper7D - !----------------------------------------------------------------- - type(DimensionsWrapper7D_R8P_t), intent(INOUT) :: this - !----------------------------------------------------------------- - call this%Free() - end subroutine - - - subroutine DimensionsWrapper7D_R8P_Set(this, Value) - !----------------------------------------------------------------- - !< Set R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(INOUT) :: this - class(*), intent(IN) :: Value(:,:,:,:,:,:,:) - integer :: err - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - allocate(this%Value(size(Value,dim=1), & - size(Value,dim=2), & - size(Value,dim=3), & - size(Value,dim=4), & - size(Value,dim=5), & - size(Value,dim=6), & - size(Value,dim=7)), & - source=Value, stat=err) - if(err/=0) & - call msg%Error( txt='Setting Value: Allocation error ('//& - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - class Default - call msg%Warn( txt='Setting value: Expected data type (R8P)', & - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_R8P_Get(this, Value) - !----------------------------------------------------------------- - !< Get R8P Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this - class(*), intent(OUT) :: Value(:,:,:,:,:,:,:) - integer(I4P), allocatable :: ValueShape(:) - !----------------------------------------------------------------- - select type (Value) - type is (real(R8P)) - call this%GetShape(ValueShape) - if(all(ValueShape == shape(Value))) then - Value = this%Value - else - call msg%Warn(txt='Getting value: Wrong shape ('//& - str(no_sign=.true.,n=ValueShape)//'/='//& - str(no_sign=.true.,n=shape(Value))//')',& - file=__FILE__, line=__LINE__ ) - endif - class Default - call msg%Warn(txt='Getting value: Expected data type (R8P)',& - file=__FILE__, line=__LINE__ ) - end select - end subroutine - - - subroutine DimensionsWrapper7D_R8P_GetShape(this, ValueShape) - !----------------------------------------------------------------- - !< Get Wrapper Value Shape - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this - integer(I4P), allocatable, intent(INOUT) :: ValueShape(:) - !----------------------------------------------------------------- - if(allocated(ValueShape)) deallocate(ValueShape) - allocate(ValueShape(this%GetDimensions())) - ValueShape = shape(this%Value, kind=I4P) - end subroutine - - - function DimensionsWrapper7D_R8P_GetPointer(this) result(Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic pointer to Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), target, intent(IN) :: this - class(*), pointer :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - Value => this%Value - end function - - - subroutine DimensionsWrapper7D_R8P_GetPolymorphic(this, Value) - !----------------------------------------------------------------- - !< Get Unlimited Polymorphic Wrapper Value - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this - class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - allocate(Value(size(this%Value,dim=1), & - size(this%Value,dim=2), & - size(this%Value,dim=3), & - size(this%Value,dim=4), & - size(this%Value,dim=5), & - size(this%Value,dim=6), & - size(this%Value,dim=7)), & - source=this%Value) - end subroutine - - - subroutine DimensionsWrapper7D_R8P_Free(this) - !----------------------------------------------------------------- - !< Free a DimensionsWrapper7D - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(INOUT) :: this - integer :: err - !----------------------------------------------------------------- - if(allocated(this%Value)) then - deallocate(this%Value, stat=err) - if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// & - str(no_sign=.true.,n=err)//')', & - file=__FILE__, line=__LINE__ ) - endif - end subroutine - - - function DimensionsWrapper7D_R8P_DataSizeInBytes(this) result(DataSizeInBytes) - !----------------------------------------------------------------- - !< Return the size of the data in bytes - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this !< Dimensions wrapper 7D - integer(I4P) :: DataSizeInBytes !< Data size in bytes - !----------------------------------------------------------------- - DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) - end function DimensionsWrapper7D_R8P_DataSizeInBytes - - - function DimensionsWrapper7D_R8P_isOfDataType(this, Mold) result(isOfDataType) - !----------------------------------------------------------------- - !< Check if Mold and Value are of the same datatype - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this !< Dimensions wrapper 7D - class(*), intent(IN) :: Mold !< Mold for data type comparison - logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold - !----------------------------------------------------------------- - isOfDataType = .false. - select type (Mold) - type is (real(R8P)) - isOfDataType = .true. - end select - end function DimensionsWrapper7D_R8P_isOfDataType - - - subroutine DimensionsWrapper7D_R8P_toString(this, String, Separator) - !----------------------------------------------------------------- - !< Return the wrapper value as a string - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this - character(len=:), allocatable, intent(INOUT) :: String - character(len=1), optional, intent(IN) :: Separator - character(len=1) :: Sep - integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7 - !----------------------------------------------------------------- - String = '' - Sep = ',' - if(allocated(this%Value)) then - if(present(Separator)) Sep = Separator - do idx7=1, size(this%Value,7) - do idx6=1, size(this%Value,6) - do idx5=1, size(this%Value,5) - do idx4=1, size(this%Value,4) - do idx3=1, size(this%Value,3) - do idx2=1, size(this%Value,2) +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R8P_t + REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :) +CONTAINS + PRIVATE + PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_R8P_Set + PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_R8P_Get + PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_R8P_GetShape + PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_R8P_GetPointer + PROCEDURE, PUBLIC :: GetPolymorphic => & + DimensionsWrapper7D_R8P_GetPolymorphic + PROCEDURE, PUBLIC :: DataSizeInBytes => & + DimensionsWrapper7D_R8P_DataSizeInBytes + PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_R8P_isOfDataType + PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_R8P_toString + PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_R8P_Print + PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_R8P_Free + FINAL :: DimensionsWrapper7D_R8P_Final +END TYPE + +PUBLIC :: DimensionsWrapper7D_R8P_t + +CONTAINS + +SUBROUTINE DimensionsWrapper7D_R8P_Final(this) + !----------------------------------------------------------------- + !< Final procedure of DimensionsWrapper7D + !----------------------------------------------------------------- + TYPE(DimensionsWrapper7D_R8P_t), INTENT(INOUT) :: this + !----------------------------------------------------------------- + CALL this%Free() +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R8P_Set(this, VALUE) + !----------------------------------------------------------------- + !< Set R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :) + INTEGER :: err + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), & + SIZE(VALUE, dim=2), & + SIZE(VALUE, dim=3), & + SIZE(VALUE, dim=4), & + SIZE(VALUE, dim=5), & + SIZE(VALUE, dim=6), & + SIZE(VALUE, dim=7)), & + source=VALUE, stat=err) + IF (err /= 0) & + CALL msg%Error(txt='Setting Value: Allocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + CLASS Default + CALL msg%Warn(txt='Setting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R8P_Get(this, VALUE) + !----------------------------------------------------------------- + !< Get R8P Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this + CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + INTEGER(I4P), ALLOCATABLE :: ValueShape(:) + !----------------------------------------------------------------- + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + CALL this%GetShape(ValueShape) + IF (ALL(ValueShape == SHAPE(VALUE))) THEN + VALUE = this%VALUE + ELSE + CALL msg%Warn(txt='Getting value: Wrong shape ('// & + str(no_sign=.TRUE., n=ValueShape)//'/='// & + str(no_sign=.TRUE., n=SHAPE(VALUE))//')', & + file=__FILE__, line=__LINE__) + END IF + CLASS Default + CALL msg%Warn(txt='Getting value: Expected data type (R8P)', & + file=__FILE__, line=__LINE__) + END SELECT +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R8P_GetShape(this, ValueShape) + !----------------------------------------------------------------- + !< Get Wrapper Value Shape + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this + INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:) + !----------------------------------------------------------------- + IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape) + ALLOCATE (ValueShape(this%GetDimensions())) + ValueShape = SHAPE(this%VALUE, kind=I4P) +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_R8P_GetPointer(this) RESULT(VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic pointer to Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), TARGET, INTENT(IN) :: this + CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + VALUE => this%VALUE +END FUNCTION + +SUBROUTINE DimensionsWrapper7D_R8P_GetPolymorphic(this, VALUE) + !----------------------------------------------------------------- + !< Get Unlimited Polymorphic Wrapper Value + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this + CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), & + SIZE(this%VALUE, dim=2), & + SIZE(this%VALUE, dim=3), & + SIZE(this%VALUE, dim=4), & + SIZE(this%VALUE, dim=5), & + SIZE(this%VALUE, dim=6), & + SIZE(this%VALUE, dim=7)), & + source=this%VALUE) +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R8P_Free(this) + !----------------------------------------------------------------- + !< Free a DimensionsWrapper7D + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(INOUT) :: this + INTEGER :: err + !----------------------------------------------------------------- + IF (ALLOCATED(this%VALUE)) THEN + DEALLOCATE (this%VALUE, stat=err) + IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// & + str(no_sign=.TRUE., n=err)//')', & + file=__FILE__, line=__LINE__) + END IF +END SUBROUTINE + +FUNCTION DimensionsWrapper7D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes) + !----------------------------------------------------------------- + !< Return the size of the data in bytes + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes + !----------------------------------------------------------------- + DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value) +END FUNCTION DimensionsWrapper7D_R8P_DataSizeInBytes + +FUNCTION DimensionsWrapper7D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType) + !----------------------------------------------------------------- + !< Check if Mold and Value are of the same datatype + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D + CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison + LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold + !----------------------------------------------------------------- + isOfDataType = .FALSE. + SELECT TYPE (Mold) + TYPE is (REAL(R8P)) + isOfDataType = .TRUE. + END SELECT +END FUNCTION DimensionsWrapper7D_R8P_isOfDataType + +SUBROUTINE DimensionsWrapper7D_R8P_toString(this, String, Separator) + !----------------------------------------------------------------- + !< Return the wrapper value as a string + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this + CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String + CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator + CHARACTER(len=1) :: Sep + INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7 + !----------------------------------------------------------------- + String = '' + Sep = ',' + IF (ALLOCATED(this%VALUE)) THEN + IF (PRESENT(Separator)) Sep = Separator + DO idx7 = 1, SIZE(this%VALUE, 7) + DO idx6 = 1, SIZE(this%VALUE, 6) + DO idx5 = 1, SIZE(this%VALUE, 5) + DO idx4 = 1, SIZE(this%VALUE, 4) + DO idx3 = 1, SIZE(this%VALUE, 3) + DO idx2 = 1, SIZE(this%VALUE, 2) String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep - enddo - enddo - enddo - enddo - enddo - enddo - String = trim(adjustl(String(:len(String)-1))) - endif - end subroutine - - - subroutine DimensionsWrapper7D_R8P_Print(this, unit, prefix, iostat, iomsg) - !----------------------------------------------------------------- - !< Print Wrapper - !----------------------------------------------------------------- - class(DimensionsWrapper7D_R8P_t), intent(IN) :: this !< DimensionsWrapper - integer(I4P), intent(IN) :: unit !< Logic unit. - character(*), optional, intent(IN) :: prefix !< Prefixing string. - integer(I4P), optional, intent(OUT) :: iostat !< IO error. - character(*), optional, intent(OUT) :: iomsg !< IO error message. - character(len=:), allocatable :: prefd !< Prefixing string. - character(len=:), allocatable :: strvalue !< String value - integer(I4P) :: iostatd !< IO error. - character(500) :: iomsgd !< Temporary variable for IO error message. - !----------------------------------------------------------------- - prefd = '' ; if (present(prefix)) prefd = prefix + END DO + END DO + END DO + END DO + END DO + END DO + String = TRIM(ADJUSTL(String(:LEN(String) - 1))) + END IF +END SUBROUTINE + +SUBROUTINE DimensionsWrapper7D_R8P_Print(this, unit, prefix, iostat, iomsg) + !----------------------------------------------------------------- + !< Print Wrapper + !----------------------------------------------------------------- + CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper + INTEGER(I4P), INTENT(IN) :: unit !< Logic unit. + CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string. + INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error. + CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message. + CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string. + CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value + INTEGER(I4P) :: iostatd !< IO error. + CHARACTER(500) :: iomsgd !< Temporary variable for IO error message. + !----------------------------------------------------------------- + prefd = ''; IF (PRESENT(prefix)) prefd = prefix write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//& - ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//& - ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//& - ', Value = ' - call this%toString(strvalue) - write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue - if (present(iostat)) iostat = iostatd - if (present(iomsg)) iomsg = iomsgd - end subroutine DimensionsWrapper7D_R8P_Print - -end module DimensionsWrapper7D_R8P + ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// & + ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// & + ', Value = ' + CALL this%toString(strvalue) + WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue + IF (PRESENT(iostat)) iostat = iostatd + IF (PRESENT(iomsg)) iomsg = iomsgd +END SUBROUTINE DimensionsWrapper7D_R8P_Print + +END MODULE DimensionsWrapper7D_R8P diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 index cebb80c3f..e69979f1c 100644 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 @@ -1,6 +1,6 @@ !----------------------------------------------------------------- ! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, ! Javier Principe and Víctor Sande. ! All rights reserved. ! @@ -18,10 +18,10 @@ ! License along with this library. !----------------------------------------------------------------- -module I2PWrapperFactory +MODULE I2PWrapperFactory USE WrapperFactory -USE PENF, only: I1P, I2P +USE PENF, ONLY: I1P, I2P USE DimensionsWrapper USE DimensionsWrapper0D_I2P USE DimensionsWrapper1D_I2P @@ -32,322 +32,306 @@ module I2PWrapperFactory USE DimensionsWrapper6D_I2P USE DimensionsWrapper7D_I2P -implicit none -private - - type, extends(WrapperFactory_t) :: I2PWrapperFactory_t - private - - contains - procedure :: Wrap0D => I2PWrapperFactory_Wrap0D - procedure :: Wrap1D => I2PWrapperFactory_Wrap1D - procedure :: Wrap2D => I2PWrapperFactory_Wrap2D - procedure :: Wrap3D => I2PWrapperFactory_Wrap3D - procedure :: Wrap4D => I2PWrapperFactory_Wrap4D - procedure :: Wrap5D => I2PWrapperFactory_Wrap5D - procedure :: Wrap6D => I2PWrapperFactory_Wrap6D - procedure :: Wrap7D => I2PWrapperFactory_Wrap7D - procedure :: UnWrap0D => I2PWrapperFactory_UnWrap0D - procedure :: UnWrap1D => I2PWrapperFactory_UnWrap1D - procedure :: UnWrap2D => I2PWrapperFactory_UnWrap2D - procedure :: UnWrap3D => I2PWrapperFactory_UnWrap3D - procedure :: UnWrap4D => I2PWrapperFactory_UnWrap4D - procedure :: UnWrap5D => I2PWrapperFactory_UnWrap5D - procedure :: UnWrap6D => I2PWrapperFactory_UnWrap6D - procedure :: UnWrap7D => I2PWrapperFactory_UnWrap7D - procedure, public :: hasSameType => I2PWrapperFactory_hasSameType - end type - - type(I2PWrapperFactory_t), save, public :: WrapperFactoryI2P - !$OMP THREADPRIVATE(WrapperFactoryI2P) - -contains - - function I2PWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (integer(I2P)) - hasSameType = .true. - end select - end function I2PWrapperFactory_hasSameType - - - function I2PWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 0D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap0D - - - function I2PWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 1D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap1D - - - function I2PWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 2D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap2D - - - function I2PWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 3D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1))) then - allocate(DimensionsWrapper3D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap3D - - - function I2PWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 4D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1))) then - allocate(DimensionsWrapper4D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap4D - - - function I2PWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 5D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1))) then - allocate(DimensionsWrapper5D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap5D - - - function I2PWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 6D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1))) then - allocate(DimensionsWrapper6D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap6D - - - function I2PWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I2P 7D Wrapper - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1,1))) then - allocate(DimensionsWrapper7D_I2P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_I2P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I2PWrapperFactory_Wrap7D - - - subroutine I2PWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 0D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 1D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 2D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 3D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 4D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 5D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 6D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I2PWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I2P 7D Wrapped Value - !----------------------------------------------------------------- - class(I2PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_I2P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - -end module I2PWrapperFactory +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(WrapperFactory_t) :: I2PWrapperFactory_t + PRIVATE + +CONTAINS + PROCEDURE :: Wrap0D => I2PWrapperFactory_Wrap0D + PROCEDURE :: Wrap1D => I2PWrapperFactory_Wrap1D + PROCEDURE :: Wrap2D => I2PWrapperFactory_Wrap2D + PROCEDURE :: Wrap3D => I2PWrapperFactory_Wrap3D + PROCEDURE :: Wrap4D => I2PWrapperFactory_Wrap4D + PROCEDURE :: Wrap5D => I2PWrapperFactory_Wrap5D + PROCEDURE :: Wrap6D => I2PWrapperFactory_Wrap6D + PROCEDURE :: Wrap7D => I2PWrapperFactory_Wrap7D + PROCEDURE :: UnWrap0D => I2PWrapperFactory_UnWrap0D + PROCEDURE :: UnWrap1D => I2PWrapperFactory_UnWrap1D + PROCEDURE :: UnWrap2D => I2PWrapperFactory_UnWrap2D + PROCEDURE :: UnWrap3D => I2PWrapperFactory_UnWrap3D + PROCEDURE :: UnWrap4D => I2PWrapperFactory_UnWrap4D + PROCEDURE :: UnWrap5D => I2PWrapperFactory_UnWrap5D + PROCEDURE :: UnWrap6D => I2PWrapperFactory_UnWrap6D + PROCEDURE :: UnWrap7D => I2PWrapperFactory_UnWrap7D + PROCEDURE, PUBLIC :: hasSameType => I2PWrapperFactory_hasSameType +END TYPE + +TYPE(I2PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryI2P +!$OMP THREADPRIVATE(WrapperFactoryI2P) + +CONTAINS + +FUNCTION I2PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + LOGICAL :: hasSameType + !----------------------------------------------------------------- + hasSameType = .FALSE. + SELECT TYPE (VALUE) + TYPE is (INTEGER(I2P)) + hasSameType = .TRUE. + END SELECT +END FUNCTION I2PWrapperFactory_hasSameType + +FUNCTION I2PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 0D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE)) THEN + ALLOCATE (DimensionsWrapper0D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=0_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap0D + +FUNCTION I2PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 1D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1))) THEN + ALLOCATE (DimensionsWrapper1D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=1_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap1D + +FUNCTION I2PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 2D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1))) THEN + ALLOCATE (DimensionsWrapper2D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=2_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap2D + +FUNCTION I2PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 3D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper3D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=3_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap3D + +FUNCTION I2PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 4D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper4D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=4_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap4D + +FUNCTION I2PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 5D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper5D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=5_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap5D + +FUNCTION I2PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 6D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper6D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=6_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap6D + +FUNCTION I2PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I2P 7D Wrapper + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper7D_I2P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=7_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_I2P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I2PWrapperFactory_Wrap7D + +SUBROUTINE I2PWrapperFactory_UnWrap0D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 0D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap1D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 1D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap2D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 2D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap3D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 3D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap4D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 4D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap5D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 5D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap6D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 6D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I2PWrapperFactory_UnWrap7D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I2P 7D Wrapped Value + !----------------------------------------------------------------- + CLASS(I2PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_I2P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +END MODULE I2PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 index be2999f64..91e589e5e 100644 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 @@ -1,6 +1,6 @@ !----------------------------------------------------------------- ! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, ! Javier Principe and Víctor Sande. ! All rights reserved. ! @@ -18,10 +18,10 @@ ! License along with this library. !----------------------------------------------------------------- -module I4PWrapperFactory +MODULE I4PWrapperFactory USE WrapperFactory -USE PENF, only: I1P, I4P +USE PENF, ONLY: I1P, I4P USE DimensionsWrapper USE DimensionsWrapper0D_I4P USE DimensionsWrapper1D_I4P @@ -32,322 +32,306 @@ module I4PWrapperFactory USE DimensionsWrapper6D_I4P USE DimensionsWrapper7D_I4P -implicit none -private - - type, extends(WrapperFactory_t) :: I4PWrapperFactory_t - private - - contains - procedure :: Wrap0D => I4PWrapperFactory_Wrap0D - procedure :: Wrap1D => I4PWrapperFactory_Wrap1D - procedure :: Wrap2D => I4PWrapperFactory_Wrap2D - procedure :: Wrap3D => I4PWrapperFactory_Wrap3D - procedure :: Wrap4D => I4PWrapperFactory_Wrap4D - procedure :: Wrap5D => I4PWrapperFactory_Wrap5D - procedure :: Wrap6D => I4PWrapperFactory_Wrap6D - procedure :: Wrap7D => I4PWrapperFactory_Wrap7D - procedure :: UnWrap0D => I4PWrapperFactory_UnWrap0D - procedure :: UnWrap1D => I4PWrapperFactory_UnWrap1D - procedure :: UnWrap2D => I4PWrapperFactory_UnWrap2D - procedure :: UnWrap3D => I4PWrapperFactory_UnWrap3D - procedure :: UnWrap4D => I4PWrapperFactory_UnWrap4D - procedure :: UnWrap5D => I4PWrapperFactory_UnWrap5D - procedure :: UnWrap6D => I4PWrapperFactory_UnWrap6D - procedure :: UnWrap7D => I4PWrapperFactory_UnWrap7D - procedure, public :: hasSameType => I4PWrapperFactory_hasSameType - end type - - type(I4PWrapperFactory_t), save, public :: WrapperFactoryI4P - !$OMP THREADPRIVATE(WrapperFactoryI4P) - -contains - - function I4PWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (integer(I4P)) - hasSameType = .true. - end select - end function I4PWrapperFactory_hasSameType - - - function I4PWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 0D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap0D - - - function I4PWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 1D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap1D - - - function I4PWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 2D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap2D - - - function I4PWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 3D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1))) then - allocate(DimensionsWrapper3D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap3D - - - function I4PWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 4D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1))) then - allocate(DimensionsWrapper4D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap4D - - - function I4PWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 5D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1))) then - allocate(DimensionsWrapper5D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap5D - - - function I4PWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 6D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1))) then - allocate(DimensionsWrapper6D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap6D - - - function I4PWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create I4P 7D Wrapper - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1,1))) then - allocate(DimensionsWrapper7D_I4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_I4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function I4PWrapperFactory_Wrap7D - - - subroutine I4PWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 0D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 1D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 2D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 3D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 4D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 5D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 6D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine I4PWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the I4P 7D Wrapped Value - !----------------------------------------------------------------- - class(I4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_I4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - -end module I4PWrapperFactory +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(WrapperFactory_t) :: I4PWrapperFactory_t + PRIVATE + +CONTAINS + PROCEDURE :: Wrap0D => I4PWrapperFactory_Wrap0D + PROCEDURE :: Wrap1D => I4PWrapperFactory_Wrap1D + PROCEDURE :: Wrap2D => I4PWrapperFactory_Wrap2D + PROCEDURE :: Wrap3D => I4PWrapperFactory_Wrap3D + PROCEDURE :: Wrap4D => I4PWrapperFactory_Wrap4D + PROCEDURE :: Wrap5D => I4PWrapperFactory_Wrap5D + PROCEDURE :: Wrap6D => I4PWrapperFactory_Wrap6D + PROCEDURE :: Wrap7D => I4PWrapperFactory_Wrap7D + PROCEDURE :: UnWrap0D => I4PWrapperFactory_UnWrap0D + PROCEDURE :: UnWrap1D => I4PWrapperFactory_UnWrap1D + PROCEDURE :: UnWrap2D => I4PWrapperFactory_UnWrap2D + PROCEDURE :: UnWrap3D => I4PWrapperFactory_UnWrap3D + PROCEDURE :: UnWrap4D => I4PWrapperFactory_UnWrap4D + PROCEDURE :: UnWrap5D => I4PWrapperFactory_UnWrap5D + PROCEDURE :: UnWrap6D => I4PWrapperFactory_UnWrap6D + PROCEDURE :: UnWrap7D => I4PWrapperFactory_UnWrap7D + PROCEDURE, PUBLIC :: hasSameType => I4PWrapperFactory_hasSameType +END TYPE + +TYPE(I4PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryI4P +!$OMP THREADPRIVATE(WrapperFactoryI4P) + +CONTAINS + +FUNCTION I4PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + LOGICAL :: hasSameType + !----------------------------------------------------------------- + hasSameType = .FALSE. + SELECT TYPE (VALUE) + TYPE is (INTEGER(I4P)) + hasSameType = .TRUE. + END SELECT +END FUNCTION I4PWrapperFactory_hasSameType + +FUNCTION I4PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 0D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE)) THEN + ALLOCATE (DimensionsWrapper0D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=0_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap0D + +FUNCTION I4PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 1D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1))) THEN + ALLOCATE (DimensionsWrapper1D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=1_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap1D + +FUNCTION I4PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 2D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1))) THEN + ALLOCATE (DimensionsWrapper2D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=2_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap2D + +FUNCTION I4PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 3D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper3D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=3_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap3D + +FUNCTION I4PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 4D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper4D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=4_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap4D + +FUNCTION I4PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 5D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper5D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=5_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap5D + +FUNCTION I4PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 6D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper6D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=6_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap6D + +FUNCTION I4PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create I4P 7D Wrapper + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper7D_I4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=7_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_I4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION I4PWrapperFactory_Wrap7D + +SUBROUTINE I4PWrapperFactory_UnWrap0D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 0D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap1D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 1D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap2D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 2D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap3D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 3D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap4D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 4D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap5D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 5D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap6D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 6D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE I4PWrapperFactory_UnWrap7D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the I4P 7D Wrapped Value + !----------------------------------------------------------------- + CLASS(I4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_I4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +END MODULE I4PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 index f58934d4d..a1f125930 100644 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 @@ -1,6 +1,6 @@ !----------------------------------------------------------------- ! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, ! Javier Principe and Víctor Sande. ! All rights reserved. ! @@ -18,10 +18,10 @@ ! License along with this library. !----------------------------------------------------------------- -module R4PWrapperFactory +MODULE R4PWrapperFactory USE WrapperFactory -USE PENF, only: I1P, R4P +USE PENF, ONLY: I1P, R4P USE DimensionsWrapper USE DimensionsWrapper0D_R4P USE DimensionsWrapper1D_R4P @@ -32,322 +32,306 @@ module R4PWrapperFactory USE DimensionsWrapper6D_R4P USE DimensionsWrapper7D_R4P -implicit none -private - - type, extends(WrapperFactory_t) :: R4PWrapperFactory_t - private - - contains - procedure :: Wrap0D => R4PWrapperFactory_Wrap0D - procedure :: Wrap1D => R4PWrapperFactory_Wrap1D - procedure :: Wrap2D => R4PWrapperFactory_Wrap2D - procedure :: Wrap3D => R4PWrapperFactory_Wrap3D - procedure :: Wrap4D => R4PWrapperFactory_Wrap4D - procedure :: Wrap5D => R4PWrapperFactory_Wrap5D - procedure :: Wrap6D => R4PWrapperFactory_Wrap6D - procedure :: Wrap7D => R4PWrapperFactory_Wrap7D - procedure :: UnWrap0D => R4PWrapperFactory_UnWrap0D - procedure :: UnWrap1D => R4PWrapperFactory_UnWrap1D - procedure :: UnWrap2D => R4PWrapperFactory_UnWrap2D - procedure :: UnWrap3D => R4PWrapperFactory_UnWrap3D - procedure :: UnWrap4D => R4PWrapperFactory_UnWrap4D - procedure :: UnWrap5D => R4PWrapperFactory_UnWrap5D - procedure :: UnWrap6D => R4PWrapperFactory_UnWrap6D - procedure :: UnWrap7D => R4PWrapperFactory_UnWrap7D - procedure, public :: hasSameType => R4PWrapperFactory_hasSameType - end type - - type(R4PWrapperFactory_t), save, public :: WrapperFactoryR4P - !$OMP THREADPRIVATE(WrapperFactoryR4P) - -contains - - function R4PWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (real(R4P)) - hasSameType = .true. - end select - end function R4PWrapperFactory_hasSameType - - - function R4PWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 0D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap0D - - - function R4PWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 1D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap1D - - - function R4PWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 2D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap2D - - - function R4PWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 3D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1))) then - allocate(DimensionsWrapper3D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap3D - - - function R4PWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 4D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1))) then - allocate(DimensionsWrapper4D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap4D - - - function R4PWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 5D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1))) then - allocate(DimensionsWrapper5D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap5D - - - function R4PWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 6D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1))) then - allocate(DimensionsWrapper6D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap6D - - - function R4PWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R4P 7D Wrapper - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1,1))) then - allocate(DimensionsWrapper7D_R4P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_R4P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R4PWrapperFactory_Wrap7D - - - subroutine R4PWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 0D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 1D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 2D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 3D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 4D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 5D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 6D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R4PWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R4P 7D Wrapped Value - !----------------------------------------------------------------- - class(R4PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_R4P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - -end module R4PWrapperFactory +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(WrapperFactory_t) :: R4PWrapperFactory_t + PRIVATE + +CONTAINS + PROCEDURE :: Wrap0D => R4PWrapperFactory_Wrap0D + PROCEDURE :: Wrap1D => R4PWrapperFactory_Wrap1D + PROCEDURE :: Wrap2D => R4PWrapperFactory_Wrap2D + PROCEDURE :: Wrap3D => R4PWrapperFactory_Wrap3D + PROCEDURE :: Wrap4D => R4PWrapperFactory_Wrap4D + PROCEDURE :: Wrap5D => R4PWrapperFactory_Wrap5D + PROCEDURE :: Wrap6D => R4PWrapperFactory_Wrap6D + PROCEDURE :: Wrap7D => R4PWrapperFactory_Wrap7D + PROCEDURE :: UnWrap0D => R4PWrapperFactory_UnWrap0D + PROCEDURE :: UnWrap1D => R4PWrapperFactory_UnWrap1D + PROCEDURE :: UnWrap2D => R4PWrapperFactory_UnWrap2D + PROCEDURE :: UnWrap3D => R4PWrapperFactory_UnWrap3D + PROCEDURE :: UnWrap4D => R4PWrapperFactory_UnWrap4D + PROCEDURE :: UnWrap5D => R4PWrapperFactory_UnWrap5D + PROCEDURE :: UnWrap6D => R4PWrapperFactory_UnWrap6D + PROCEDURE :: UnWrap7D => R4PWrapperFactory_UnWrap7D + PROCEDURE, PUBLIC :: hasSameType => R4PWrapperFactory_hasSameType +END TYPE + +TYPE(R4PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryR4P +!$OMP THREADPRIVATE(WrapperFactoryR4P) + +CONTAINS + +FUNCTION R4PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + LOGICAL :: hasSameType + !----------------------------------------------------------------- + hasSameType = .FALSE. + SELECT TYPE (VALUE) + TYPE is (REAL(R4P)) + hasSameType = .TRUE. + END SELECT +END FUNCTION R4PWrapperFactory_hasSameType + +FUNCTION R4PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 0D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE)) THEN + ALLOCATE (DimensionsWrapper0D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=0_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap0D + +FUNCTION R4PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 1D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1))) THEN + ALLOCATE (DimensionsWrapper1D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=1_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap1D + +FUNCTION R4PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 2D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1))) THEN + ALLOCATE (DimensionsWrapper2D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=2_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap2D + +FUNCTION R4PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 3D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper3D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=3_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap3D + +FUNCTION R4PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 4D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper4D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=4_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap4D + +FUNCTION R4PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 5D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper5D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=5_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap5D + +FUNCTION R4PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 6D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper6D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=6_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap6D + +FUNCTION R4PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R4P 7D Wrapper + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper7D_R4P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=7_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_R4P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R4PWrapperFactory_Wrap7D + +SUBROUTINE R4PWrapperFactory_UnWrap0D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 0D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap1D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 1D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap2D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 2D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap3D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 3D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap4D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 4D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap5D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 5D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap6D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 6D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R4PWrapperFactory_UnWrap7D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R4P 7D Wrapped Value + !----------------------------------------------------------------- + CLASS(R4PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_R4P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +END MODULE R4PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 index 92bcab984..324e8731c 100644 --- a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 +++ b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 @@ -1,6 +1,6 @@ !----------------------------------------------------------------- ! FPL (Fortran Parameter List) -! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, +! Copyright (c) 2015 Santiago Badia, Alberto F. Martín, ! Javier Principe and Víctor Sande. ! All rights reserved. ! @@ -18,10 +18,10 @@ ! License along with this library. !----------------------------------------------------------------- -module R8PWrapperFactory +MODULE R8PWrapperFactory USE WrapperFactory -USE PENF, only: I1P, R8P +USE PENF, ONLY: I1P, R8P USE DimensionsWrapper USE DimensionsWrapper0D_R8P USE DimensionsWrapper1D_R8P @@ -32,322 +32,306 @@ module R8PWrapperFactory USE DimensionsWrapper6D_R8P USE DimensionsWrapper7D_R8P -implicit none -private - - type, extends(WrapperFactory_t) :: R8PWrapperFactory_t - private - - contains - procedure :: Wrap0D => R8PWrapperFactory_Wrap0D - procedure :: Wrap1D => R8PWrapperFactory_Wrap1D - procedure :: Wrap2D => R8PWrapperFactory_Wrap2D - procedure :: Wrap3D => R8PWrapperFactory_Wrap3D - procedure :: Wrap4D => R8PWrapperFactory_Wrap4D - procedure :: Wrap5D => R8PWrapperFactory_Wrap5D - procedure :: Wrap6D => R8PWrapperFactory_Wrap6D - procedure :: Wrap7D => R8PWrapperFactory_Wrap7D - procedure :: UnWrap0D => R8PWrapperFactory_UnWrap0D - procedure :: UnWrap1D => R8PWrapperFactory_UnWrap1D - procedure :: UnWrap2D => R8PWrapperFactory_UnWrap2D - procedure :: UnWrap3D => R8PWrapperFactory_UnWrap3D - procedure :: UnWrap4D => R8PWrapperFactory_UnWrap4D - procedure :: UnWrap5D => R8PWrapperFactory_UnWrap5D - procedure :: UnWrap6D => R8PWrapperFactory_UnWrap6D - procedure :: UnWrap7D => R8PWrapperFactory_UnWrap7D - procedure, public :: hasSameType => R8PWrapperFactory_hasSameType - end type - - type(R8PWrapperFactory_t), save, public :: WrapperFactoryR8P - !$OMP THREADPRIVATE(WrapperFactoryR8P) - -contains - - function R8PWrapperFactory_hasSameType(this, Value) result(hasSameType) - !----------------------------------------------------------------- - !< Check if Value type agrees with wrapper type - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - logical :: hasSameType - !----------------------------------------------------------------- - hasSameType = .false. - select type(Value) - type is (real(R8P)) - hasSameType = .true. - end select - end function R8PWrapperFactory_hasSameType - - - function R8PWrapperFactory_Wrap0D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 0D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value)) then - allocate(DimensionsWrapper0D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=0_I1P) - select type (Wrapper) - type is(DimensionsWrapper0D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap0D - - - function R8PWrapperFactory_Wrap1D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 1D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1))) then - allocate(DimensionsWrapper1D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=1_I1P) - select type (Wrapper) - type is(DimensionsWrapper1D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap1D - - - function R8PWrapperFactory_Wrap2D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 2D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1))) then - allocate(DimensionsWrapper2D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=2_I1P) - select type (Wrapper) - type is(DimensionsWrapper2D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap2D - - - function R8PWrapperFactory_Wrap3D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 3D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1))) then - allocate(DimensionsWrapper3D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=3_I1P) - select type (Wrapper) - type is(DimensionsWrapper3D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap3D - - - function R8PWrapperFactory_Wrap4D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 4D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1))) then - allocate(DimensionsWrapper4D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=4_I1P) - select type (Wrapper) - type is(DimensionsWrapper4D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap4D - - - function R8PWrapperFactory_Wrap5D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 5D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1))) then - allocate(DimensionsWrapper5D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=5_I1P) - select type (Wrapper) - type is(DimensionsWrapper5D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap5D - - - function R8PWrapperFactory_Wrap6D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 6D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1))) then - allocate(DimensionsWrapper6D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=6_I1P) - select type (Wrapper) - type is(DimensionsWrapper6D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap6D - - - function R8PWrapperFactory_Wrap7D(this, Value) result(Wrapper) - !----------------------------------------------------------------- - !< Create R8P 7D Wrapper - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:) - class(DimensionsWrapper_t), pointer :: Wrapper - !----------------------------------------------------------------- - if(this%hasSameType(Value(1,1,1,1,1,1,1))) then - allocate(DimensionsWrapper7D_R8P_t::Wrapper) - call Wrapper%SetDimensions(Dimensions=7_I1P) - select type (Wrapper) - type is(DimensionsWrapper7D_R8P_t) - call Wrapper%Set(Value=Value) - end select - endif - end function R8PWrapperFactory_Wrap7D - - - subroutine R8PWrapperFactory_UnWrap0D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 0D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper0D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap1D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 1D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper1D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap2D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 2D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper2D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap3D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 3D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper3D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap4D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 4D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper4D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap5D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 5D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper5D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap6D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 6D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper6D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - - - subroutine R8PWrapperFactory_UnWrap7D(this, Wrapper, Value) - !----------------------------------------------------------------- - !< Return the R8P 7D Wrapped Value - !----------------------------------------------------------------- - class(R8PWrapperFactory_t), intent(IN) :: this - class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper - class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:) - !----------------------------------------------------------------- - select type (Wrapper) - type is(DimensionsWrapper7D_R8P_t) - call Wrapper%Get(Value = Value) - end select - end subroutine - -end module R8PWrapperFactory +IMPLICIT NONE +PRIVATE + +TYPE, EXTENDS(WrapperFactory_t) :: R8PWrapperFactory_t + PRIVATE + +CONTAINS + PROCEDURE :: Wrap0D => R8PWrapperFactory_Wrap0D + PROCEDURE :: Wrap1D => R8PWrapperFactory_Wrap1D + PROCEDURE :: Wrap2D => R8PWrapperFactory_Wrap2D + PROCEDURE :: Wrap3D => R8PWrapperFactory_Wrap3D + PROCEDURE :: Wrap4D => R8PWrapperFactory_Wrap4D + PROCEDURE :: Wrap5D => R8PWrapperFactory_Wrap5D + PROCEDURE :: Wrap6D => R8PWrapperFactory_Wrap6D + PROCEDURE :: Wrap7D => R8PWrapperFactory_Wrap7D + PROCEDURE :: UnWrap0D => R8PWrapperFactory_UnWrap0D + PROCEDURE :: UnWrap1D => R8PWrapperFactory_UnWrap1D + PROCEDURE :: UnWrap2D => R8PWrapperFactory_UnWrap2D + PROCEDURE :: UnWrap3D => R8PWrapperFactory_UnWrap3D + PROCEDURE :: UnWrap4D => R8PWrapperFactory_UnWrap4D + PROCEDURE :: UnWrap5D => R8PWrapperFactory_UnWrap5D + PROCEDURE :: UnWrap6D => R8PWrapperFactory_UnWrap6D + PROCEDURE :: UnWrap7D => R8PWrapperFactory_UnWrap7D + PROCEDURE, PUBLIC :: hasSameType => R8PWrapperFactory_hasSameType +END TYPE + +TYPE(R8PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryR8P +!$OMP THREADPRIVATE(WrapperFactoryR8P) + +CONTAINS + +FUNCTION R8PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType) + !----------------------------------------------------------------- + !< Check if Value type agrees with wrapper type + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + LOGICAL :: hasSameType + !----------------------------------------------------------------- + hasSameType = .FALSE. + SELECT TYPE (VALUE) + TYPE is (REAL(R8P)) + hasSameType = .TRUE. + END SELECT +END FUNCTION R8PWrapperFactory_hasSameType + +FUNCTION R8PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 0D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE)) THEN + ALLOCATE (DimensionsWrapper0D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=0_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap0D + +FUNCTION R8PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 1D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1))) THEN + ALLOCATE (DimensionsWrapper1D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=1_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap1D + +FUNCTION R8PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 2D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1))) THEN + ALLOCATE (DimensionsWrapper2D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=2_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap2D + +FUNCTION R8PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 3D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper3D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=3_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap3D + +FUNCTION R8PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 4D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper4D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=4_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap4D + +FUNCTION R8PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 5D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper5D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=5_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap5D + +FUNCTION R8PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 6D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper6D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=6_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap6D + +FUNCTION R8PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper) + !----------------------------------------------------------------- + !< Create R8P 7D Wrapper + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:) + CLASS(DimensionsWrapper_t), POINTER :: Wrapper + !----------------------------------------------------------------- + IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN + ALLOCATE (DimensionsWrapper7D_R8P_t :: Wrapper) + CALL Wrapper%SetDimensions(Dimensions=7_I1P) + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_R8P_t) + CALL Wrapper%Set(VALUE=VALUE) + END SELECT + END IF +END FUNCTION R8PWrapperFactory_Wrap7D + +SUBROUTINE R8PWrapperFactory_UnWrap0D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 0D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper0D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap1D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 1D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper1D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap2D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 2D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper2D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap3D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 3D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper3D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap4D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 4D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper4D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap5D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 5D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper5D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap6D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 6D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper6D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +SUBROUTINE R8PWrapperFactory_UnWrap7D(this, Wrapper, VALUE) + !----------------------------------------------------------------- + !< Return the R8P 7D Wrapped Value + !----------------------------------------------------------------- + CLASS(R8PWrapperFactory_t), INTENT(IN) :: this + CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper + CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :) + !----------------------------------------------------------------- + SELECT TYPE (Wrapper) + TYPE is (DimensionsWrapper7D_R8P_t) + CALL Wrapper%Get(VALUE=VALUE) + END SELECT +END SUBROUTINE + +END MODULE R8PWrapperFactory diff --git a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 index 23cf3a4c6..9124acb57 100644 --- a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 +++ b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 @@ -18,7 +18,7 @@ ! License along with this library. !----------------------------------------------------------------- -module WrapperFactoryListSingleton +MODULE WrapperFactoryListSingleton USE WrapperFactoryList USE DLCAWrapperFactory @@ -30,23 +30,23 @@ module WrapperFactoryListSingleton USE R4PWrapperFactory USE R8PWrapperFactory -implicit none -private +IMPLICIT NONE +PRIVATE - type(WrapperFactoryList_t), save :: TheWrapperFactoryList - !$OMP THREADPRIVATE(TheWrapperFactoryList) +TYPE(WrapperFactoryList_t), SAVE :: TheWrapperFactoryList +!$OMP THREADPRIVATE(TheWrapperFactoryList) -public :: TheWrapperFactoryList -public :: TheWrapperFactoryList_Init +PUBLIC :: TheWrapperFactoryList +PUBLIC :: TheWrapperFactoryList_Init -contains +CONTAINS - subroutine TheWrapperFactoryList_Init() - !----------------------------------------------------------------- - !< Set the dimensions of the Value contained in the wrapper - !----------------------------------------------------------------- - ! Add some Wrapper Factories to the list - call TheWrapperFactoryList%Init() +SUBROUTINE TheWrapperFactoryList_Init() + !----------------------------------------------------------------- + !< Set the dimensions of the Value contained in the wrapper + !----------------------------------------------------------------- + ! Add some Wrapper Factories to the list + CALL TheWrapperFactoryList%Init() call TheWrapperFactoryList%AddWrapperFactory(key='I1P', WrapperFactory=WrapperFactoryI1P) call TheWrapperFactoryList%AddWrapperFactory(key='I2P', WrapperFactory=WrapperFactoryI2P) call TheWrapperFactoryList%AddWrapperFactory(key='I4P', WrapperFactory=WrapperFactoryI4P) @@ -55,6 +55,6 @@ subroutine TheWrapperFactoryList_Init() call TheWrapperFactoryList%AddWrapperFactory(key='R8P', WrapperFactory=WrapperFactoryR8P) call TheWrapperFactoryList%AddWrapperFactory(key='L', WrapperFactory=WrapperFactoryL) call TheWrapperFactoryList%AddWrapperFactory(key='DLCA', WrapperFactory=WrapperFactoryDLCA) - end subroutine TheWrapperFactoryList_Init +END SUBROUTINE TheWrapperFactoryList_Init -end module WrapperFactoryListSingleton +END MODULE WrapperFactoryListSingleton diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90 index 3e4deb1af..3cf947d31 100644 --- a/src/modules/ForceVector/src/ForceVector_Method.F90 +++ b/src/modules/ForceVector/src/ForceVector_Method.F90 @@ -16,12 +16,14 @@ ! MODULE ForceVector_Method -USE BaseType -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_, FEVariable_, FEVariableScalar_, & + FEVariableVector_, FEVariableMatrix_ IMPLICIT NONE PRIVATE PUBLIC :: ForceVector +PUBLIC :: ForceVector_ !---------------------------------------------------------------------------- ! ForceVector @@ -39,13 +41,45 @@ MODULE ForceVector_Method ! F_{I}=\int_{\Omega}N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_1(test) RESULT(ans) +INTERFACE + MODULE FUNCTION ForceVector1(test) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_1 + END FUNCTION ForceVector1 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector1 END INTERFACE ForceVector +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 4 May 2022 +! summary: Force vector +! +!# Introduction +! +! This subroutine computes the following expression: +! +! $$ +! F_{I}=\int_{\Omega}N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_1(test, ans, tsize) + CLASS(ElemshapeData_), INTENT(IN) :: test + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_1 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_1 +END INTERFACE ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -60,17 +94,21 @@ END FUNCTION ForceVector_1 ! F_{I}=\int_{\Omega}\rho N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_2b(test, c) RESULT(ans) +INTERFACE + MODULE FUNCTION ForceVector2(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test - REAL(DFP), INTENT(IN) :: c(:) - !! defined on quadrature point + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_2b + END FUNCTION ForceVector2 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector2 END INTERFACE ForceVector !---------------------------------------------------------------------------- -! ForceVector +! ForceVector_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -80,17 +118,23 @@ END FUNCTION ForceVector_2b !# Introduction ! ! $$ -! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! F_{I}=\int_{\Omega} c N^{I} d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_2(test, c, crank) RESULT(ans) +INTERFACE + MODULE SUBROUTINE ForceVector_2(test, c, crank, ans, tsize) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c + !! Scalar variables TYPE(FEVariableScalar_), INTENT(IN) :: crank - REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_2 -END INTERFACE ForceVector + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_2 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_2 +END INTERFACE ForceVector_ !---------------------------------------------------------------------------- ! ForceVector @@ -105,18 +149,52 @@ END FUNCTION ForceVector_2 ! This routine computes the following integral ! ! $$ -! F(i,I)=\int_{\Omega}v_{i}N^{I}d\Omega +! F(i,I)=\int_{\Omega}c_{i}N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_3(test, c, crank) RESULT(ans) +INTERFACE + MODULE FUNCTION ForceVector3(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableVector_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ForceVector_3 + END FUNCTION ForceVector3 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector3 END INTERFACE ForceVector +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! This routine computes the following integral +! +! $$ +! F(i,I)=\int_{\Omega}v_{i}N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_3(test, c, crank, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE ForceVector_3 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_3 +END INTERFACE ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -130,18 +208,52 @@ END FUNCTION ForceVector_3 ! This routine computes the following integral ! ! $$ -! F(i,j,I)=\int_{\Omega}k_{ij}N^{I}d\Omega +! F(i,j,I)=\int_{\Omega}c_{ij}N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_4(test, c, crank) RESULT(ans) +INTERFACE + MODULE FUNCTION ForceVector4(test, c, crank) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c TYPE(FEVariableMatrix_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION ForceVector_4 + END FUNCTION ForceVector4 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector4 END INTERFACE ForceVector +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! This routine computes the following integral +! +! $$ +! F(i,j,I)=\int_{\Omega}k_{ij}N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_4(test, c, crank, ans, dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: test + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE ForceVector_4 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_4 +END INTERFACE ForceVector_ + !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- @@ -158,20 +270,24 @@ END FUNCTION ForceVector_4 ! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_5(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) +INTERFACE + MODULE FUNCTION ForceVector5(test, c1, c1rank, c2, c2rank) & + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariableScalar_), INTENT(IN) :: c1rank TYPE(FEVariableScalar_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:) - END FUNCTION ForceVector_5 + END FUNCTION ForceVector5 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector5 END INTERFACE ForceVector !---------------------------------------------------------------------------- -! ForceVector +! ForceVector_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -180,28 +296,82 @@ END FUNCTION ForceVector_5 ! !# Introduction ! -! This routine computes the following integral. +! This routine computes the following integral ! ! $$ -! +! F_{I}=\int_{\Omega}c_{1}c_{2}N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_6(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) +INTERFACE + MODULE SUBROUTINE ForceVector_5(test, c1, c1rank, c2, c2rank, ans, & + tsize) + CLASS(ElemshapeData_), INTENT(IN) :: test + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_5 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_5 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) & + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariableScalar_), INTENT(IN) :: c1rank TYPE(FEVariableVector_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION ForceVector_6 + END FUNCTION ForceVector6 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector6 END INTERFACE ForceVector !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE SUBROUTINE ForceVector_6(test, c1, c1rank, c2, c2rank, ans, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE ForceVector_6 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_6 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector @@ -214,16 +384,363 @@ END FUNCTION ForceVector_6 ! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega ! $$ -INTERFACE ForceVector - MODULE PURE FUNCTION ForceVector_7(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) +INTERFACE + MODULE FUNCTION ForceVector7(test, c1, c1rank, c2, c2rank) & + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test TYPE(FEVariable_), INTENT(IN) :: c1 TYPE(FEVariable_), INTENT(IN) :: c2 TYPE(FEVariableScalar_), INTENT(IN) :: c1rank TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION ForceVector_7 + END FUNCTION ForceVector7 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector7 END INTERFACE ForceVector +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! This routine computes the following. +! +! $$ +! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_7(test, c1, c1rank, c2, c2rank, ans, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: test + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE ForceVector_7 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_7 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE FUNCTION ForceVector8(test, c) RESULT(ans) + CLASS(ElemshapeData_), INTENT(IN) :: test + REAL(DFP), INTENT(IN) :: c(:) + !! defined on quadrature point + REAL(DFP), ALLOCATABLE :: ans(:) + END FUNCTION ForceVector8 +END INTERFACE + +INTERFACE ForceVector + MODULE PROCEDURE ForceVector8 +END INTERFACE ForceVector + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_8(test, c, ans, tsize) + CLASS(ElemshapeData_), INTENT(IN) :: test + REAL(DFP), INTENT(IN) :: c(:) + !! defined on quadrature point + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_8 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_8 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_9( & + N, js, ws, thickness, nns, nips, c, ans, tsize) + REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips + REAL(DFP), INTENT(IN) :: c(:) + !! defined on quadrature point + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_9 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_9 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_10( & + N, js, ws, thickness, nns, nips, c, skipVertices, tVertices, ans, tsize) + REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips + REAL(DFP), INTENT(IN) :: c(:) + !! defined on quadrature point + LOGICAL(LGT), INTENT(IN) :: skipVertices + INTEGER(I4B), INTENT(IN) :: tVertices + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_10 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_10 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_11( & + spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, & + nips, nipt, c, ans, tsize) + REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:) + REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt + REAL(DFP), INTENT(IN) :: c(:, :) + !! defined on quadrature point + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Force vector is returned in DOF format + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_11 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_11 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_12( & + spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, & + nips, nipt, c, skipVertices, tSpaceVertices, tTimeVertices, ans, tsize) + REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:) + REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt + REAL(DFP), INTENT(IN) :: c(:, :) + !! defined on quadrature point + LOGICAL(LGT), INTENT(IN) :: skipVertices + INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_12 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_12 +END INTERFACE ForceVector_ + + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_13( & + N, js, ws, thickness, nns, nips, ans, tsize) + REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_13 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_13 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_14( & + N, js, ws, thickness, nns, nips, skipVertices, tVertices, ans, tsize) + REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips + LOGICAL(LGT), INTENT(IN) :: skipVertices + INTEGER(I4B), INTENT(IN) :: tVertices + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_14 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_14 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_15( & + spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, & + nips, nipt, ans, tsize) + REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:) + REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt + REAL(DFP), INTENT(INOUT) :: ans(:) + !! Force vector is returned in DOF format + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_15 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_15 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector +! +!# Introduction +! +! $$ +! F_{I}=\int_{\Omega}\rho N^{I}d\Omega +! $$ + +INTERFACE + MODULE SUBROUTINE ForceVector_16( & + spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, & + nips, nipt, skipVertices, tSpaceVertices, tTimeVertices, ans, tsize) + REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:) + REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:) + INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt + LOGICAL(LGT), INTENT(IN) :: skipVertices + INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices + REAL(DFP), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE ForceVector_16 +END INTERFACE + +INTERFACE ForceVector_ + MODULE PROCEDURE ForceVector_16 +END INTERFACE ForceVector_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE ForceVector_Method diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt index 8c398fbc6..6158cffd4 100644 --- a/src/modules/Geometry/CMakeLists.txt +++ b/src/modules/Geometry/CMakeLists.txt @@ -1,34 +1,24 @@ -# This program is a part of EASIFEM library -# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D # -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # -# You should have received a copy of the GNU General Public License -# along with this program. If not, see +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/ReferenceElement_Method.F90 - ${src_path}/ReferencePoint_Method.F90 - ${src_path}/Line_Method.F90 - ${src_path}/ReferenceLine_Method.F90 - ${src_path}/Triangle_Method.F90 - ${src_path}/Plane_Method.F90 - ${src_path}/ReferenceTriangle_Method.F90 - ${src_path}/ReferenceQuadrangle_Method.F90 - ${src_path}/ReferenceTetrahedron_Method.F90 - ${src_path}/ReferenceHexahedron_Method.F90 - ${src_path}/ReferencePrism_Method.F90 - ${src_path}/ReferencePyramid_Method.F90 - ${src_path}/Geometry_Method.F90 -) \ No newline at end of file +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferenceElement_Method.F90 + ${src_path}/Plane_Method.F90 + ${src_path}/Geometry_Method.F90) + diff --git a/src/modules/Geometry/src/Plane_Method.F90 b/src/modules/Geometry/src/Plane_Method.F90 index 2be4626c7..2cafe3fbe 100644 --- a/src/modules/Geometry/src/Plane_Method.F90 +++ b/src/modules/Geometry/src/Plane_Method.F90 @@ -19,6 +19,10 @@ MODULE Plane_Method USE GlobalData IMPLICIT NONE +PRIVATE + +PUBLIC :: plane_normal_line_exp_int_3d + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -54,16 +58,16 @@ MODULE Plane_Method ! Output, real ( kind = 8 ) PINT(3), the coordinates of a ! common point of the plane and line, when IVAL is 1 or 2. -interface - module pure subroutine plane_normal_line_exp_int_3d(pp, normal, & - & p1, p2, ival, pint) - real(dfp), intent(in) :: pp(3) - real(dfp), intent(inout) :: normal(3) - real(dfp), intent(in) :: p1(3) - real(dfp), intent(in) :: p2(3) - integer(i4b), intent(out) :: ival - real(dfp), intent(out) :: pint(3) - end subroutine -end interface +INTERFACE + MODULE PURE SUBROUTINE plane_normal_line_exp_int_3d(pp, normal, & + p1, p2, ival, pint) + REAL(dfp), INTENT(in) :: pp(3) + REAL(dfp), INTENT(inout) :: normal(3) + REAL(dfp), INTENT(in) :: p1(3) + REAL(dfp), INTENT(in) :: p2(3) + INTEGER(i4b), INTENT(out) :: ival + REAL(dfp), INTENT(out) :: pint(3) + END SUBROUTINE +END INTERFACE END MODULE Plane_Method diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90 index dae820c5f..a45ef8b15 100644 --- a/src/modules/Geometry/src/ReferenceElement_Method.F90 +++ b/src/modules/Geometry/src/ReferenceElement_Method.F90 @@ -39,7 +39,7 @@ MODULE ReferenceElement_Method PUBLIC :: ReferenceElement_Pointer PUBLIC :: GetConnectivity PUBLIC :: ElementType -PUBLIC :: Elementname +PUBLIC :: ElementName PUBLIC :: TotalNodesInElement PUBLIC :: ElementOrder PUBLIC :: OPERATOR(.order.) @@ -135,8 +135,13 @@ MODULE ReferenceElement_Method INTEGER(I4B) :: faceElemTypePrism(5) = 0 INTEGER(I4B) :: faceElemTypePyramid(5) = 0 !! TODO: add faceElemTypePrism and faceElemTypePyramid - !! element types of faces of triangle + +#ifdef MAX_QUADRANGLE_ORDER + INTEGER(I4B) :: maxOrder_Quadrangle = MAX_QUADRANGLE_ORDER +#else + INTEGER(I4B) :: maxOrder_Quadrangle = 2_I4B +#endif END TYPE ReferenceElementInfo_ TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = & @@ -162,7 +167,7 @@ END FUNCTION RefCoord END INTERFACE !---------------------------------------------------------------------------- -! +! RefCoord_@GeometryMethods !---------------------------------------------------------------------------- INTERFACE @@ -332,6 +337,32 @@ MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, & END SUBROUTINE GetFaceElemType1 END INTERFACE GetFaceElemType +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType + MODULE PURE SUBROUTINE GetFaceElemType2(elemType, localFaceNumber, & + faceElemType, opt, tFaceNodes) + INTEGER(I4B), INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Element names of faces + INTEGER(I4B), INTENT(OUT) :: tFaceNodes + !! Total number of nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType2 +END INTERFACE GetFaceElemType + !---------------------------------------------------------------------------- ! GetTotalNodes@GeometryMethods !---------------------------------------------------------------------------- @@ -690,7 +721,7 @@ END FUNCTION refelem_Getnptrs END INTERFACE GetConnectivity !---------------------------------------------------------------------------- -! ElementType@ElementnameMethods +! ElementType@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -705,7 +736,7 @@ END FUNCTION Element_Type END INTERFACE ElementType !---------------------------------------------------------------------------- -! ElementType@ElementnameMethods +! ElementType@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -720,37 +751,37 @@ END FUNCTION Element_Type_obj END INTERFACE ElementType !---------------------------------------------------------------------------- -! Elementname@ElementNameMethods +! ElementName@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 21 May 2022 ! summary: Returns element name in character from element number/type -INTERFACE Elementname +INTERFACE ElementName MODULE PURE FUNCTION Element_name(elemType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: elemType CHARACTER(:), ALLOCATABLE :: ans END FUNCTION Element_name -END INTERFACE Elementname +END INTERFACE ElementName !---------------------------------------------------------------------------- -! Elementname@ElementNameMethods +! ElementName@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 21 May 2022 ! summary: Returns element name in character from ReferenceElement -INTERFACE Elementname +INTERFACE ElementName MODULE PURE FUNCTION Element_name_obj(obj) RESULT(ans) CLASS(ReferenceElement_), INTENT(IN) :: obj CHARACTER(:), ALLOCATABLE :: ans END FUNCTION Element_name_obj -END INTERFACE Elementname +END INTERFACE ElementName !---------------------------------------------------------------------------- -! TotalNodesInElement@ElementnameMethods +! TotalNodesInElement@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -765,7 +796,7 @@ END FUNCTION Total_Nodes_In_Element END INTERFACE TotalNodesInElement !---------------------------------------------------------------------------- -! ElementOrder@ElementnameMethods +! ElementOrder@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -780,7 +811,7 @@ END FUNCTION Element_Order END INTERFACE ElementOrder !---------------------------------------------------------------------------- -! ElementOrder@ElementnameMethods +! ElementOrder@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -799,7 +830,7 @@ END FUNCTION Element_Order_refelem END INTERFACE OPERATOR(.order.) !---------------------------------------------------------------------------- -! XiDimension@ElementnameMethods +! XiDimension@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -815,7 +846,7 @@ END FUNCTION Elem_XiDimension1 END INTERFACE Xidimension !---------------------------------------------------------------------------- -! Xidimension@ElementnameMethods +! Xidimension@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1161,7 +1192,7 @@ END FUNCTION isSerendipityElement2 END INTERFACE isSerendipityElement !---------------------------------------------------------------------------- -! ElementTopology@ElementnameMethods +! ElementTopology@ElementNameMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1189,7 +1220,7 @@ END FUNCTION refelem_ElementTopology1 END INTERFACE OPERATOR(.topology.) !---------------------------------------------------------------------------- -! ElementTopology@ElementnameMethods +! ElementTopology@ElementNameMethods !---------------------------------------------------------------------------- INTERFACE ElementTopology diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90 index 2adf09ce3..6173ba735 100755 --- a/src/modules/GlobalData/src/GlobalData.F90 +++ b/src/modules/GlobalData/src/GlobalData.F90 @@ -15,8 +15,8 @@ ! along with this program. If not, see MODULE GlobalData -USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, & - OUTPUT_UNIT, ERROR_UNIT +USE ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, & + OUTPUT_UNIT, ERROR_UNIT IMPLICIT NONE PUBLIC diff --git a/src/modules/Hexahedron/CMakeLists.txt b/src/modules/Hexahedron/CMakeLists.txt new file mode 100644 index 000000000..091a2ca74 --- /dev/null +++ b/src/modules/Hexahedron/CMakeLists.txt @@ -0,0 +1,21 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} PRIVATE ${src_path}/ReferenceHexahedron_Method.F90 + ${src_path}/HexahedronInterpolationUtility.F90) diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Hexahedron/src/HexahedronInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 rename to src/modules/Hexahedron/src/HexahedronInterpolationUtility.F90 diff --git a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 b/src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90 similarity index 91% rename from src/modules/Geometry/src/ReferenceHexahedron_Method.F90 rename to src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90 index af249edaa..47774757c 100644 --- a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90 +++ b/src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90 @@ -355,9 +355,12 @@ END FUNCTION RefHexahedronCoord ! date: 2024-03-11 ! summary: Returns the element type of each face -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron(faceElemType, opt, & - & tFaceNodes, elemType) +INTERFACE GetFaceElemType_Hexahedron + MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron1(elemType, faceElemType, & + tFaceNodes, opt) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! This denotes the element type of Hexahedron + !! Default value is Hexahedron6 INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) !! Face element type INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:) @@ -366,10 +369,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron(faceElemType, opt, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! This denotes the element type of Hexahedron - !! Default value is Hexahedron6 - END SUBROUTINE GetFaceElemType_Hexahedron -END INTERFACE + END SUBROUTINE GetFaceElemType_Hexahedron1 +END INTERFACE GetFaceElemType_Hexahedron + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Hexahedron + MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron2( & + elemType, localFaceNumber, faceElemType, tFaceNodes, opt) + INTEGER(I4B), INTENT(IN) :: elemType + !! element type of Hexahedron + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Face element type + INTEGER(I4B), INTENT(OUT) :: tFaceNodes + !! total nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Hexahedron2 +END INTERFACE GetFaceElemType_Hexahedron END MODULE ReferenceHexahedron_Method diff --git a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 index d96efafe3..2b66681e4 100644 --- a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 +++ b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 @@ -43,10 +43,10 @@ MODULE IntVector_ConstructorMethod ! summary: Returns shape of the vector INTERFACE Shape - MODULE PURE FUNCTION intVec_shape(obj) RESULT(Ans) - CLASS(IntVector_), INTENT(IN) :: obj - INTEGER(I4B) :: Ans(1) - END FUNCTION intVec_shape + MODULE PURE FUNCTION obj_shape(obj) RESULT(ans) + TYPE(IntVector_), INTENT(IN) :: obj + INTEGER(I4B) :: ans(1) + END FUNCTION obj_shape END INTERFACE Shape !---------------------------------------------------------------------------- @@ -58,11 +58,11 @@ END FUNCTION intVec_shape ! summary: Returns size of the vector INTERFACE Size - MODULE PURE FUNCTION intVec_Size(obj, Dims) RESULT(Ans) + MODULE PURE FUNCTION obj_Size(obj, dims) RESULT(ans) TYPE(IntVector_), INTENT(IN) :: obj - INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims - INTEGER(I4B) :: Ans - END FUNCTION intVec_Size + INTEGER(I4B), INTENT(IN), OPTIONAL :: dims + INTEGER(I4B) :: ans + END FUNCTION obj_Size END INTERFACE Size !---------------------------------------------------------------------------- @@ -78,10 +78,10 @@ END FUNCTION intVec_Size ! This function returns the total dimension (or rank) of an array, INTERFACE GetTotalDimension - MODULE PURE FUNCTION intVec_getTotalDimension(obj) RESULT(Ans) + MODULE PURE FUNCTION obj_getTotalDimension(obj) RESULT(ans) TYPE(IntVector_), INTENT(IN) :: obj INTEGER(I4B) :: ans - END FUNCTION intVec_getTotalDimension + END FUNCTION obj_getTotalDimension END INTERFACE GetTotalDimension !---------------------------------------------------------------------------- @@ -93,10 +93,10 @@ END FUNCTION intVec_getTotalDimension ! summary: Allocate memory for the vector INTERFACE ALLOCATE - MODULE PURE SUBROUTINE intVec_AllocateData(obj, Dims) - CLASS(IntVector_), INTENT(INOUT) :: obj - INTEGER(I4B), INTENT(IN) :: Dims - END SUBROUTINE intVec_AllocateData + MODULE PURE SUBROUTINE obj_AllocateData(obj, dims) + TYPE(IntVector_), INTENT(INOUT) :: obj + INTEGER(I4B), INTENT(IN) :: dims + END SUBROUTINE obj_AllocateData END INTERFACE ALLOCATE !---------------------------------------------------------------------------- @@ -108,10 +108,10 @@ END SUBROUTINE intVec_AllocateData ! summary: Allocate memory for the vector INTERFACE Reallocate - MODULE PURE SUBROUTINE intVec_Reallocate(obj, row) + MODULE PURE SUBROUTINE obj_Reallocate(obj, row) TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) INTEGER(I4B), INTENT(IN) :: row - END SUBROUTINE intVec_Reallocate + END SUBROUTINE obj_Reallocate END INTERFACE Reallocate !---------------------------------------------------------------------------- @@ -123,9 +123,9 @@ END SUBROUTINE intVec_Reallocate ! summary: Deallocate memory occupied by IntVector INTERFACE DEALLOCATE - MODULE PURE SUBROUTINE intVec_Deallocate(obj) - CLASS(IntVector_), INTENT(INOUT) :: obj - END SUBROUTINE intVec_Deallocate + MODULE PURE SUBROUTINE obj_Deallocate(obj) + TYPE(IntVector_), INTENT(INOUT) :: obj + END SUBROUTINE obj_Deallocate END INTERFACE DEALLOCATE !---------------------------------------------------------------------------- @@ -142,10 +142,10 @@ END SUBROUTINE intVec_Deallocate ! Only the size of intvector is set. INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate1(obj, tSize) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate1(obj, tSize) + TYPE(IntVector_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: tSize - END SUBROUTINE intVec_initiate1 + END SUBROUTINE obj_initiate1 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -157,10 +157,10 @@ END SUBROUTINE intVec_initiate1 ! summary: This routine initiates the vector of [[IntVector_]] INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate2(obj, tSize) + MODULE PURE SUBROUTINE obj_initiate2(obj, tSize) TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:) INTEGER(I4B), INTENT(IN) :: tSize(:) - END SUBROUTINE intVec_initiate2 + END SUBROUTINE obj_initiate2 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -173,10 +173,10 @@ END SUBROUTINE intVec_initiate2 ! summary: Initiates an instance on [[IntVector_]] with lower & upper bounds INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate3(obj, a, b) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate3(obj, a, b) + TYPE(IntVector_), INTENT(INOUT) :: obj INTEGER(I4B), INTENT(IN) :: a, b - END SUBROUTINE intVec_initiate3 + END SUBROUTINE obj_initiate3 END INTERFACE Initiate !---------------------------------------------------------------------------- @@ -195,30 +195,30 @@ END SUBROUTINE intVec_initiate3 ! This routine also define an assignment operator, obj=val INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate4a(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate4a(obj, val) + TYPE(IntVector_), INTENT(INOUT) :: obj INTEGER(INT8), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4a + END SUBROUTINE obj_initiate4a !! - MODULE PURE SUBROUTINE intVec_initiate4b(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate4b(obj, val) + TYPE(IntVector_), INTENT(INOUT) :: obj INTEGER(INT16), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4b + END SUBROUTINE obj_initiate4b !! - MODULE PURE SUBROUTINE intVec_initiate4c(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate4c(obj, val) + TYPE(IntVector_), INTENT(INOUT) :: obj INTEGER(INT32), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4c + END SUBROUTINE obj_initiate4c !! - MODULE PURE SUBROUTINE intVec_initiate4d(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate4d(obj, val) + TYPE(IntVector_), INTENT(INOUT) :: obj INTEGER(INT64), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate4d + END SUBROUTINE obj_initiate4d END INTERFACE Initiate INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE intVec_initiate4a, intVec_initiate4b, & - & intVec_initiate4c, intVec_initiate4d + MODULE PROCEDURE obj_initiate4a, obj_initiate4b, & + obj_initiate4c, obj_initiate4d END INTERFACE ASSIGNMENT(=) !---------------------------------------------------------------------------- @@ -237,21 +237,44 @@ END SUBROUTINE intVec_initiate4d ! obj=val INTERFACE Initiate - MODULE PURE SUBROUTINE intVec_initiate5a(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate5a(obj, val) + TYPE(IntVector_), INTENT(INOUT) :: obj REAL(REAL32), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate5a + END SUBROUTINE obj_initiate5a !! - MODULE PURE SUBROUTINE intVec_initiate5b(obj, val) - CLASS(IntVector_), INTENT(INOUT) :: obj + MODULE PURE SUBROUTINE obj_initiate5b(obj, val) + TYPE(IntVector_), INTENT(INOUT) :: obj REAL(REAL64), INTENT(IN) :: val(:) - END SUBROUTINE intVec_initiate5b + END SUBROUTINE obj_initiate5b +END INTERFACE Initiate + +INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE obj_initiate5a, obj_initiate5b +END INTERFACE ASSIGNMENT(=) + +!---------------------------------------------------------------------------- +! Initiate@Constructor +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-07-25 +! summary: Initiate an instance of IntVector by copying data from other + +INTERFACE Initiate + MODULE PURE SUBROUTINE obj_initiate6(obj, obj2) + TYPE(IntVector_), INTENT(INOUT) :: obj + TYPE(IntVector_), INTENT(IN) :: obj2 + END SUBROUTINE obj_initiate6 END INTERFACE Initiate INTERFACE ASSIGNMENT(=) - MODULE PROCEDURE intVec_initiate5a, intVec_initiate5b + MODULE PROCEDURE obj_initiate6 END INTERFACE ASSIGNMENT(=) +INTERFACE COPY + MODULE PROCEDURE obj_initiate6 +END INTERFACE COPY + !---------------------------------------------------------------------------- ! IntVector@Constructor !---------------------------------------------------------------------------- @@ -262,10 +285,10 @@ END SUBROUTINE intVec_initiate5b ! summary: IntVector returns an instance of [[IntVector_]] of given size INTERFACE IntVector - MODULE PURE FUNCTION intVec_Constructor1(tSize) RESULT(obj) + MODULE PURE FUNCTION obj_Constructor1(tSize) RESULT(obj) TYPE(IntVector_) :: obj INTEGER(I4B), INTENT(IN) :: tSize - END FUNCTION intVec_Constructor1 + END FUNCTION obj_Constructor1 END INTERFACE IntVector !---------------------------------------------------------------------------- @@ -278,10 +301,10 @@ END FUNCTION intVec_Constructor1 ! summary: Convert a integer vector into [[IntVector_]] INTERFACE IntVector - MODULE PURE FUNCTION intVec_Constructor2(Val) RESULT(obj) + MODULE PURE FUNCTION obj_Constructor2(Val) RESULT(obj) TYPE(IntVector_) :: obj INTEGER(I4B), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor2 + END FUNCTION obj_Constructor2 END INTERFACE IntVector !---------------------------------------------------------------------------- @@ -297,10 +320,10 @@ END FUNCTION intVec_Constructor2 ! Real32, Real64 ! INTERFACE IntVector - MODULE PURE FUNCTION intVec_Constructor3(Val) RESULT(obj) + MODULE PURE FUNCTION obj_Constructor3(Val) RESULT(obj) TYPE(IntVector_) :: obj REAL(DFP), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor3 + END FUNCTION obj_Constructor3 END INTERFACE IntVector !---------------------------------------------------------------------------- @@ -313,10 +336,10 @@ END FUNCTION intVec_Constructor3 ! summary: Returns the pointer to an instance of [[IntVector_]] of tsize INTERFACE IntVector_Pointer - MODULE PURE FUNCTION intVec_Constructor_1(tSize) RESULT(obj) - CLASS(IntVector_), POINTER :: obj + MODULE PURE FUNCTION obj_Constructor_1(tSize) RESULT(obj) + TYPE(IntVector_), POINTER :: obj INTEGER(I4B), INTENT(IN) :: tSize - END FUNCTION intVec_Constructor_1 + END FUNCTION obj_Constructor_1 END INTERFACE IntVector_Pointer !---------------------------------------------------------------------------- @@ -329,10 +352,10 @@ END FUNCTION intVec_Constructor_1 ! summary: Converts integer vector into [[intvector_]] and returns the pointer INTERFACE IntVector_Pointer - MODULE PURE FUNCTION intVec_Constructor_2(Val) RESULT(obj) - CLASS(IntVector_), POINTER :: obj + MODULE PURE FUNCTION obj_Constructor_2(Val) RESULT(obj) + TYPE(IntVector_), POINTER :: obj INTEGER(I4B), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor_2 + END FUNCTION obj_Constructor_2 END INTERFACE IntVector_Pointer !---------------------------------------------------------------------------- @@ -345,10 +368,10 @@ END FUNCTION intVec_Constructor_2 ! summary: Converts real vector into [[intvector_]] and returns the pointer INTERFACE IntVector_Pointer - MODULE PURE FUNCTION intVec_Constructor_3(Val) RESULT(obj) - CLASS(IntVector_), POINTER :: obj + MODULE PURE FUNCTION obj_Constructor_3(Val) RESULT(obj) + TYPE(IntVector_), POINTER :: obj REAL(DFP), INTENT(IN) :: Val(:) - END FUNCTION intVec_Constructor_3 + END FUNCTION obj_Constructor_3 END INTERFACE IntVector_Pointer !---------------------------------------------------------------------------- @@ -356,10 +379,10 @@ END FUNCTION intVec_Constructor_3 !---------------------------------------------------------------------------- INTERFACE ASSIGNMENT(=) - MODULE PURE SUBROUTINE IntVec_assign_a(Val, obj) + MODULE PURE SUBROUTINE obj_assign_a(Val, obj) INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Val(:) - CLASS(IntVector_), INTENT(IN) :: obj - END SUBROUTINE IntVec_assign_a + TYPE(IntVector_), INTENT(IN) :: obj + END SUBROUTINE obj_assign_a END INTERFACE ASSIGNMENT(=) !---------------------------------------------------------------------------- @@ -368,7 +391,7 @@ END SUBROUTINE IntVec_assign_a INTERFACE Convert MODULE PURE SUBROUTINE obj_convert_int(From, To) - CLASS(IntVector_), INTENT(IN) :: From + TYPE(IntVector_), INTENT(IN) :: From INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: To(:) END SUBROUTINE obj_convert_int END INTERFACE Convert diff --git a/src/modules/Lapack/src/Lapack_Method.F90 b/src/modules/Lapack/src/Lapack_Method.F90 index bb0647fb4..ebfa0abe4 100644 --- a/src/modules/Lapack/src/Lapack_Method.F90 +++ b/src/modules/Lapack/src/Lapack_Method.F90 @@ -18,4 +18,4 @@ MODULE Lapack_Method USE GE_Lapack_Method USE Sym_Lapack_Method -END MODULE Lapack_Method \ No newline at end of file +END MODULE Lapack_Method diff --git a/src/modules/Line/CMakeLists.txt b/src/modules/Line/CMakeLists.txt new file mode 100644 index 000000000..50dd294e7 --- /dev/null +++ b/src/modules/Line/CMakeLists.txt @@ -0,0 +1,23 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/Line_Method.F90 + ${src_path}/ReferenceLine_Method.F90 + ${src_path}/LineInterpolationUtility.F90) diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90 similarity index 87% rename from src/modules/Polynomial/src/LineInterpolationUtility.F90 rename to src/modules/Line/src/LineInterpolationUtility.F90 index f7fec78cd..5c63d33ab 100644 --- a/src/modules/Polynomial/src/LineInterpolationUtility.F90 +++ b/src/modules/Line/src/LineInterpolationUtility.F90 @@ -449,9 +449,8 @@ END SUBROUTINE EquidistancePoint_Line2_ !- `layout=INCREASING` points are arranged in increasing order INTERFACE InterpolationPoint_Line - MODULE FUNCTION InterpolationPoint_Line1(order, ipType, & - layout, xij, alpha, beta, lambda) RESULT(ans) - !! + MODULE FUNCTION InterpolationPoint_Line1( & + order, ipType, layout, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of interpolation INTEGER(I4B), INTENT(IN) :: ipType @@ -483,25 +482,25 @@ END FUNCTION InterpolationPoint_Line1 !> author: Vikas Sharma, Ph. D. ! date: 2024-06-25 ! summary: Interpolation without allocation +! +!# Introduction +! +! ipType can take value from TypeInterpolationOpt INTERFACE InterpolationPoint_Line_ - MODULE SUBROUTINE InterpolationPoint_Line1_(order, ipType, ans, nrow, ncol, & - layout, xij, alpha, beta, lambda) + MODULE SUBROUTINE InterpolationPoint_Line1_( & + order, ipType, ans, nrow, ncol, layout, xij, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! Order of interpolation INTEGER(I4B), INTENT(IN) :: ipType !! Interpolation point type - !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev, - !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto REAL(DFP), INTENT(INOUT) :: ans(:, :) !! interpolation points in xij format - !! size(ans,1) = 1 - !! size(ans,2) = order+1 + !! size(ans,1) = 1, size(ans,2) = order+1 INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns written to ans CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" + !! "VEFC" or "INCREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) !! domain of interpolation REAL(DFP), OPTIONAL, INTENT(IN) :: alpha @@ -522,26 +521,16 @@ END SUBROUTINE InterpolationPoint_Line1_ ! summary: Returns the interpolation point INTERFACE InterpolationPoint_Line - MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, & - layout, alpha, beta, lambda) RESULT(ans) - !! + MODULE FUNCTION InterpolationPoint_Line2( & + order, ipType, xij, layout, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of interpolation INTEGER(I4B), INTENT(IN) :: ipType !! Interpolation point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussChebyshev, - !! GaussChebyshevLobatto - !! GaussJacobi - !! GaussJacobiLobatto REAL(DFP), INTENT(IN) :: xij(2) !! end points CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - !! "DECREASING" + !! "VEFC", "INCREASING", "DECREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -558,14 +547,12 @@ END FUNCTION InterpolationPoint_Line2 !---------------------------------------------------------------------------- INTERFACE InterpolationPoint_Line_ - MODULE SUBROUTINE InterpolationPoint_Line2_(order, ipType, ans, tsize, & - xij, layout, alpha, beta, lambda) - !! + MODULE SUBROUTINE InterpolationPoint_Line2_( & + order, ipType, ans, tsize, xij, layout, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order of interpolation INTEGER(I4B), INTENT(IN) :: ipType - !! Interpolation point type - !! See TypeInterpolationOpt + !! Interpolation point type, see TypeInterpolationOpt REAL(DFP), INTENT(INOUT) :: ans(:) !! one dimensional interpolation point INTEGER(I4B), INTENT(OUT) :: tsize @@ -573,9 +560,7 @@ MODULE SUBROUTINE InterpolationPoint_Line2_(order, ipType, ans, tsize, & REAL(DFP), INTENT(IN) :: xij(2) !! end points CHARACTER(*), INTENT(IN) :: layout - !! "VEFC" - !! "INCREASING" - !! "DECREASING" + !! "VEFC", "INCREASING", "DECREASING" REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -832,9 +817,14 @@ END FUNCTION LagrangeEvalAll_Line1 ! LagrangeEvalAll_Line_ !---------------------------------------------------------------------------- -INTERFACE LagrangeEvalAll_Line_ - MODULE SUBROUTINE LagrangeEvalAll_Line1_(order, x, xij, coeff, firstCall, & - basisType, alpha, beta, lambda, ans, tsize) +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-27 +! summary: Lagrange evall all at a single point + +INTERFACE + MODULE SUBROUTINE LagrangeEvalAll_Line1_( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda, ans, & + tsize) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x @@ -861,6 +851,10 @@ MODULE SUBROUTINE LagrangeEvalAll_Line1_(order, x, xij, coeff, firstCall, & !! Value of n+1 Lagrange polynomials at point x INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE LagrangeEvalAll_Line1_ +END INTERFACE + +INTERFACE LagrangeEvalAll_Line_ + MODULE PROCEDURE LagrangeEvalAll_Line1_ END INTERFACE LagrangeEvalAll_Line_ !---------------------------------------------------------------------------- @@ -872,8 +866,9 @@ END SUBROUTINE LagrangeEvalAll_Line1_ ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeEvalAll_Line - MODULE FUNCTION LagrangeEvalAll_Line2(order, x, xij, coeff, firstCall, & - basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Line2( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -912,12 +907,17 @@ END FUNCTION LagrangeEvalAll_Line2 END INTERFACE LagrangeEvalAll_Line !---------------------------------------------------------------------------- -! +! LagrangeEvalAll_Line_@LagrangeMethods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-27 +! summary: Lagrange eval all at several points without allocation + INTERFACE LagrangeEvalAll_Line_ - MODULE SUBROUTINE LagrangeEvalAll_Line2_(order, x, xij, ans, nrow, ncol, & - coeff, firstCall, basisType, alpha, beta, lambda) + 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(:, :) @@ -954,6 +954,65 @@ MODULE SUBROUTINE LagrangeEvalAll_Line2_(order, x, xij, ans, nrow, ncol, & END SUBROUTINE LagrangeEvalAll_Line2_ END INTERFACE LagrangeEvalAll_Line_ +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line_@LagrangeMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-27 +! summary: Lagrange eval all at several points without allocation + +INTERFACE + MODULE SUBROUTINE LagrangeEvalAll_Line3_( & + order, x, xij, ans, nrow, ncol, coeff, xx, firstCall, basisType, alpha, & + beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + !! size(xij, 1) = nsd + !! size(xij, 2) = number of points, ncol + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + !! rows of xij = nsd + !! cols of xij = ncol + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + !! ans(:, j) is the value of jth polynomial at x points + !! ans(i, :) is the value of all polynomials at x(i) point + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nubmer of rows and cols writte in ans + !! nrow = size(x, 2), number of points of evaluation + !! ncol = size(xij, 2), number of interpolation points + REAL(DFP), INTENT(INOUT) :: coeff(:, :), xx(:, :) + !! coefficient of Lagrange polynomials + !! The size should be at least ncol by ncol + !! The size of xx should be at least nrow by ncol + !! It contains the evaluation of basis functions on x + !! Size of xx is nrow by ncol + LOGICAL(LGT) :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Line3_ +END INTERFACE + +INTERFACE LagrangeEvalAll_Line_ + MODULE PROCEDURE LagrangeEvalAll_Line3_ +END INTERFACE LagrangeEvalAll_Line_ + !---------------------------------------------------------------------------- ! LagrangeGradientEvalAll_Line !---------------------------------------------------------------------------- @@ -963,8 +1022,9 @@ END SUBROUTINE 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(:, :) @@ -981,12 +1041,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Line1(order, x, xij, coeff, & !! If firstCall is False, then coeff will be used !! Default value of firstCall is True INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1003,12 +1058,13 @@ END FUNCTION LagrangeGradientEvalAll_Line1 END INTERFACE LagrangeGradientEvalAll_Line !---------------------------------------------------------------------------- -! +! LagrangeGradientEvalAll_Line_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeGradientEvalAll_Line_ - MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_(order, x, xij, ans, & - dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, lambda) +INTERFACE + MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_( & + order, x, xij, ans, dim1, dim2, dim3, coeff, firstCall, basisType, & + alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1041,6 +1097,59 @@ MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_(order, x, xij, ans, & REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter END SUBROUTINE LagrangeGradientEvalAll_Line1_ +END INTERFACE + +INTERFACE LagrangeGradientEvalAll_Line_ + MODULE PROCEDURE LagrangeGradientEvalAll_Line1_ +END INTERFACE LagrangeGradientEvalAll_Line_ + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Line_@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE SUBROUTINE LagrangeGradientEvalAll_Line2_( & + order, x, xij, ans, dim1, dim2, dim3, coeff, xx, firstCall, basisType, & + alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! point of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! interpolation points + !! xij should be present when firstCall is true. + !! It is used for computing the coeff + !! If coeff is absent then xij should be present + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! ans(SIZE(x, 2), SIZE(xij, 2), 1) + REAL(DFP), INTENT(INOUT) :: coeff(:, :) + !! coefficient of Lagrange polynomials + !! shape nrow = size(xij, 2), ncol = size(xij, 2) + REAL(DFP), INTENT(INOUT) :: xx(:, :) + !! nrow: size(x, 2), ncol: order + 1 + LOGICAL(LGT) :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), INTENT(IN) :: basisType + !! Monomial + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi polynomial parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Line2_ +END INTERFACE + +INTERFACE LagrangeGradientEvalAll_Line_ + MODULE PROCEDURE LagrangeGradientEvalAll_Line2_ END INTERFACE LagrangeGradientEvalAll_Line_ !---------------------------------------------------------------------------- @@ -1050,6 +1159,17 @@ END SUBROUTINE LagrangeGradientEvalAll_Line1_ !> author: Vikas Sharma, Ph. D. ! date: 2023-06-23 ! summary: Evaluate basis functions of order upto n +! +!# Introduction +! +! BasisType can take following values +! Monomial +! Jacobi +! Ultraspherical +! Legendre +! Chebyshev +! Lobatto +! UnscaledLobatto INTERFACE BasisEvalAll_Line MODULE FUNCTION BasisEvalAll_Line1(order, x, refLine, basisType, alpha, & @@ -1061,13 +1181,7 @@ MODULE FUNCTION BasisEvalAll_Line1(order, x, refLine, basisType, alpha, & CHARACTER(*), INTENT(IN) :: refLine !! Refline should be BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! BasisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1097,13 +1211,7 @@ MODULE SUBROUTINE BasisEvalAll_Line1_(order, x, ans, tsize, refLine, & CHARACTER(*), INTENT(IN) :: refLine !! Refline should be BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! BasisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1129,16 +1237,9 @@ MODULE FUNCTION BasisEvalAll_Line2(order, x, refLine, basisType, & REAL(DFP), INTENT(IN) :: x(:) !! point of evaluation CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT, BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! BasisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1171,16 +1272,9 @@ MODULE SUBROUTINE BasisEvalAll_Line2_(order, x, ans, nrow, ncol, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of rows and columns written to ans CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT, BIUNIT INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! basis type REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1228,9 +1322,9 @@ END FUNCTION OrthogonalBasis_Line1 ! OrthogonalBasis_Line_ !---------------------------------------------------------------------------- -INTERFACE OrthogonalBasis_Line_ - MODULE SUBROUTINE OrthogonalBasis_Line1_(order, xij, refLine, basisType, & - ans, nrow, ncol, alpha, beta, lambda) +INTERFACE + MODULE SUBROUTINE OrthogonalBasis_Line1_( & + order, xij, refLine, basisType, ans, nrow, ncol, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1256,6 +1350,10 @@ MODULE SUBROUTINE OrthogonalBasis_Line1_(order, xij, refLine, basisType, & !! nrow = size(xij, 2) !! ncol = order+1 END SUBROUTINE OrthogonalBasis_Line1_ +END INTERFACE + +INTERFACE OrthogonalBasis_Line_ + MODULE PROCEDURE OrthogonalBasis_Line1_ END INTERFACE OrthogonalBasis_Line_ !---------------------------------------------------------------------------- @@ -1266,24 +1364,18 @@ END SUBROUTINE OrthogonalBasis_Line1_ ! 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) +INTERFACE + MODULE FUNCTION OrthogonalBasisGradient_Line1( & + order, xij, refLine, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: xij(:, :) !! point of evaluation !! Number of rows in xij is 1 CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! UNIT ! BIUNIT INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + ! basisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1295,6 +1387,10 @@ MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, & !! ans(:, j) is the value of jth polynomial at x points !! ans(i, :) is the value of all polynomials at x(i) point END FUNCTION OrthogonalBasisGradient_Line1 +END INTERFACE + +INTERFACE OrthogonalBasisGradient_Line + MODULE PROCEDURE OrthogonalBasisGradient_Line1 END INTERFACE OrthogonalBasisGradient_Line !---------------------------------------------------------------------------- @@ -1304,25 +1400,26 @@ END FUNCTION OrthogonalBasisGradient_Line1 !> author: Vikas Sharma, Ph. D. ! date: 2024-09-10 ! summary: gradient of orthogonal basis without allocation +! +!# Introduction +! +! refline: Unit, Biunit +! basisType: Jacobi, Ultraspherical, Legendre, Chebyshev, Lobatto, +! UnscaledLobatto -INTERFACE OrthogonalBasisGradient_Line_ - MODULE SUBROUTINE OrthogonalBasisGradient_Line1_(order, xij, refLine, & - basisType, ans, dim1, dim2, dim3, alpha, beta, lambda) +INTERFACE + MODULE SUBROUTINE OrthogonalBasisGradient_Line1_( & + order, xij, refLine, basisType, ans, dim1, dim2, dim3, alpha, beta, & + lambda) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: xij(:, :) !! point of evaluation !! Number of rows in xij is 1 CHARACTER(*), INTENT(IN) :: refLine - !! UNIT - !! BIUNIT + !! reference line element: UNIT, BIUNIT INTEGER(I4B), INTENT(IN) :: basisType - !! Jacobi - !! Ultraspherical - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto + !! basisType REAL(DFP), OPTIONAL, INTENT(IN) :: alpha !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta @@ -1335,10 +1432,12 @@ MODULE SUBROUTINE OrthogonalBasisGradient_Line1_(order, xij, refLine, & !! ans(:, j) is the value of jth polynomial at x points !! ans(i, :) is the value of all polynomials at x(i) point INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! dim1 = size(xij,2) - !! dim2 = order+1 - !! dim3 = 1 + !! dim1 = size(xij,2) ! dim2 = order+1 ! dim3 = 1 END SUBROUTINE OrthogonalBasisGradient_Line1_ +END INTERFACE + +INTERFACE OrthogonalBasisGradient_Line_ + MODULE PROCEDURE OrthogonalBasisGradient_Line1_ END INTERFACE OrthogonalBasisGradient_Line_ !---------------------------------------------------------------------------- @@ -1349,7 +1448,7 @@ END SUBROUTINE OrthogonalBasisGradient_Line1_ ! date: 27 Oct 2022 ! summary: Evaluate all modal basis (heirarchical polynomial) on Line -INTERFACE HeirarchicalBasis_Line +INTERFACE MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation @@ -1363,15 +1462,19 @@ MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans) REAL(DFP) :: ans(SIZE(xij, 2), order + 1) !! Hierarchical basis END FUNCTION HeirarchicalBasis_Line1 +END INTERFACE + +INTERFACE HeirarchicalBasis_Line + MODULE PROCEDURE HeirarchicalBasis_Line1 END INTERFACE HeirarchicalBasis_Line !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE HeirarchicalBasis_Line_ - MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, & - nrow, ncol) +INTERFACE + MODULE SUBROUTINE HeirarchicalBasis_Line1_( & + order, xij, refLine, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1386,15 +1489,19 @@ MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! SIZE(xij, 2), order + 1 END SUBROUTINE HeirarchicalBasis_Line1_ +END INTERFACE + +INTERFACE HeirarchicalBasis_Line_ + MODULE PROCEDURE HeirarchicalBasis_Line1_ END INTERFACE HeirarchicalBasis_Line_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE HeirarchicalBasis_Line_ - MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, & - ans, nrow, ncol) +INTERFACE + MODULE SUBROUTINE HeirarchicalBasis_Line2_( & + order, xij, refLine, orient, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1411,6 +1518,10 @@ MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! SIZE(xij, 2), order + 1 END SUBROUTINE HeirarchicalBasis_Line2_ +END INTERFACE + +INTERFACE HeirarchicalBasis_Line_ + MODULE PROCEDURE HeirarchicalBasis_Line2_ END INTERFACE HeirarchicalBasis_Line_ !---------------------------------------------------------------------------- @@ -1421,7 +1532,7 @@ END SUBROUTINE HeirarchicalBasis_Line2_ ! date: 27 Oct 2022 ! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line -INTERFACE HeirarchicalBasisGradient_Line +INTERFACE MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) & RESULT(ans) INTEGER(I4B), INTENT(IN) :: order @@ -1437,15 +1548,19 @@ MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) & REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1) !! Gradient of Hierarchical basis END FUNCTION HeirarchicalGradientBasis_Line1 +END INTERFACE + +INTERFACE HeirarchicalBasisGradient_Line + MODULE PROCEDURE HeirarchicalGradientBasis_Line1 END INTERFACE HeirarchicalBasisGradient_Line !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE HeirarchicalBasisGradient_Line_ - MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, & - ans, dim1, dim2, dim3) +INTERFACE + MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_( & + order, xij, refLine, ans, dim1, dim2, dim3) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1461,15 +1576,19 @@ MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, & INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 !! SIZE(xij, 2), order + 1, 1 END SUBROUTINE HeirarchicalGradientBasis_Line1_ +END INTERFACE + +INTERFACE HeirarchicalBasisGradient_Line_ + MODULE PROCEDURE HeirarchicalGradientBasis_Line1_ END INTERFACE HeirarchicalBasisGradient_Line_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE HeirarchicalBasisGradient_Line - MODULE FUNCTION HeirarchicalGradientBasis_Line2(order, xij, refLine, & - orient) RESULT(ans) +INTERFACE + MODULE FUNCTION HeirarchicalGradientBasis_Line2( & + order, xij, refLine, orient) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1486,15 +1605,19 @@ MODULE FUNCTION HeirarchicalGradientBasis_Line2(order, xij, refLine, & !! Gradient of Hierarchical basis !! SIZE(xij, 2), order + 1, 1 END FUNCTION HeirarchicalGradientBasis_Line2 +END INTERFACE + +INTERFACE HeirarchicalBasisGradient_Line + MODULE PROCEDURE HeirarchicalGradientBasis_Line2 END INTERFACE HeirarchicalBasisGradient_Line !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE HeirarchicalBasisGradient_Line_ - MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_(order, xij, refLine, & - orient, ans, dim1, dim2, dim3) +INTERFACE + MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_( & + order, xij, refLine, orient, ans, dim1, dim2, dim3) INTEGER(I4B), INTENT(IN) :: order !! Polynomial order of interpolation REAL(DFP), INTENT(IN) :: xij(:, :) @@ -1512,6 +1635,10 @@ MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_(order, xij, refLine, & INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 !! SIZE(xij, 2), order + 1, 1 END SUBROUTINE HeirarchicalGradientBasis_Line2_ +END INTERFACE + +INTERFACE HeirarchicalBasisGradient_Line_ + MODULE PROCEDURE HeirarchicalGradientBasis_Line2_ END INTERFACE HeirarchicalBasisGradient_Line_ !---------------------------------------------------------------------------- @@ -1522,9 +1649,9 @@ END SUBROUTINE HeirarchicalGradientBasis_Line2_ ! date: 2023-06-23 ! summary: Evaluate the gradient of basis functions of order upto n -INTERFACE BasisGradientEvalAll_Line - MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, & - alpha, beta, lambda) RESULT(ans) +INTERFACE + MODULE FUNCTION BasisGradientEvalAll_Line1( & + order, x, refLine, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x @@ -1543,15 +1670,19 @@ MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, & REAL(DFP) :: ans(order + 1) !! Value of n+1 polynomials at point x END FUNCTION BasisGradientEvalAll_Line1 +END INTERFACE + +INTERFACE BasisGradientEvalAll_Line + MODULE PROCEDURE BasisGradientEvalAll_Line1 END INTERFACE BasisGradientEvalAll_Line !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE BasisGradientEvalAll_Line_ - MODULE SUBROUTINE BasisGradientEvalAll_Line1_(order, x, refLine, & - basisType, alpha, beta, lambda, ans, tsize) +INTERFACE + MODULE SUBROUTINE BasisGradientEvalAll_Line1_( & + order, x, refLine, basisType, alpha, beta, lambda, ans, tsize) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x @@ -1573,6 +1704,10 @@ MODULE SUBROUTINE BasisGradientEvalAll_Line1_(order, x, refLine, & REAL(DFP), OPTIONAL, INTENT(IN) :: lambda !! Ultraspherical parameter END SUBROUTINE BasisGradientEvalAll_Line1_ +END INTERFACE + +INTERFACE BasisGradientEvalAll_Line_ + MODULE PROCEDURE BasisGradientEvalAll_Line1_ END INTERFACE BasisGradientEvalAll_Line_ !---------------------------------------------------------------------------- @@ -1583,9 +1718,9 @@ END SUBROUTINE BasisGradientEvalAll_Line1_ ! date: 2023-06-23 ! summary: Evaluate gradient of basis functions of order upto n -INTERFACE BasisGradientEvalAll_Line - MODULE FUNCTION BasisGradientEvalAll_Line2(order, x, refLine, basisType, & - alpha, beta, lambda) RESULT(ans) +INTERFACE + MODULE FUNCTION BasisGradientEvalAll_Line2( & + order, x, refLine, basisType, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x(:) @@ -1606,6 +1741,10 @@ MODULE FUNCTION BasisGradientEvalAll_Line2(order, x, refLine, basisType, & !! ans(:, j) is the value of jth polynomial at x points !! ans(i, :) is the value of all polynomials at x(i) point END FUNCTION BasisGradientEvalAll_Line2 +END INTERFACE + +INTERFACE BasisGradientEvalAll_Line + MODULE PROCEDURE BasisGradientEvalAll_Line2 END INTERFACE BasisGradientEvalAll_Line !---------------------------------------------------------------------------- @@ -1613,9 +1752,8 @@ END FUNCTION BasisGradientEvalAll_Line2 !---------------------------------------------------------------------------- INTERFACE BasisGradientEvalAll_Line_ - MODULE SUBROUTINE BasisGradientEvalAll_Line2_(order, x, ans, nrow, ncol, & - refLine, basisType, alpha, beta, lambda) - + MODULE SUBROUTINE BasisGradientEvalAll_Line2_( & + order, x, ans, nrow, ncol, refLine, basisType, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order of polynomials REAL(DFP), INTENT(IN) :: x(:) @@ -1812,7 +1950,8 @@ END FUNCTION QuadraturePoint_Line3 INTERFACE QuadraturePoint_Line_ MODULE SUBROUTINE QuadraturePoint_Line1_(nips, quadType, layout, xij, & - alpha, beta, lambda, ans, nrow, ncol) + alpha, beta, lambda, ans, nrow, & + ncol) INTEGER(I4B), INTENT(IN) :: nips(1) !! Order of interpolation INTEGER(I4B), INTENT(IN) :: quadType diff --git a/src/modules/Geometry/src/Line_Method.F90 b/src/modules/Line/src/Line_Method.F90 similarity index 77% rename from src/modules/Geometry/src/Line_Method.F90 rename to src/modules/Line/src/Line_Method.F90 index 2c1757412..3eeb8ed22 100644 --- a/src/modules/Geometry/src/Line_Method.F90 +++ b/src/modules/Line/src/Line_Method.F90 @@ -18,6 +18,18 @@ MODULE Line_Method USE GlobalData IMPLICIT NONE +PRIVATE + +PUBLIC :: line_exp_is_degenerate_nd, & + line_exp2imp_2d, & + line_imp_is_degenerate_2d, & + lines_imp_int_2d, & + line_exp_perp_2d, & + lines_exp_int_2d, & + segment_point_dist_2d, & + segment_point_dist_3d, & + line_exp_point_dist_signed_2d, & + segment_point_near_2d !---------------------------------------------------------------------------- ! @@ -46,14 +58,14 @@ MODULE Line_Method ! line is degenerate. ! -interface - module pure function line_exp_is_degenerate_nd(dim_num, p1, p2) result(ans) +INTERFACE + MODULE PURE FUNCTION line_exp_is_degenerate_nd(dim_num, p1, p2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: dim_num - real(dfp), INTENT(IN) :: p1(dim_num) - real(dfp), INTENT(IN) :: p2(dim_num) - logical(lgt) :: ans - end function -end interface + REAL(dfp), INTENT(IN) :: p1(dim_num) + REAL(dfp), INTENT(IN) :: p2(dim_num) + LOGICAL(lgt) :: ans + END FUNCTION +END INTERFACE !---------------------------------------------------------------------------- ! @@ -80,13 +92,13 @@ module pure function line_exp_is_degenerate_nd(dim_num, p1, p2) result(ans) ! Output, real ( kind = 8 ) A, B, C, the implicit form of the line. ! -interface - module pure subroutine line_exp2imp_2d(p1, p2, a, b, c) - real(kind=8), intent(out) :: a, b, c - real(kind=8), intent(in) :: p1(:) - real(kind=8), intent(in) :: p2(:) - end subroutine -end interface +INTERFACE + MODULE PURE SUBROUTINE line_exp2imp_2d(p1, p2, a, b, c) + REAL(kind=8), INTENT(out) :: a, b, c + REAL(kind=8), INTENT(in) :: p1(:) + REAL(kind=8), INTENT(in) :: p2(:) + END SUBROUTINE +END INTERFACE !---------------------------------------------------------------------------- ! @@ -110,12 +122,12 @@ module pure subroutine line_exp2imp_2d(p1, p2, a, b, c) ! line is degenerate. ! -interface - module pure function line_imp_is_degenerate_2d(a, b, c) result(ans) - real(dfp), intent(in) :: a, b, c - logical(lgt) :: ans - end function -end interface +INTERFACE + MODULE PURE FUNCTION line_imp_is_degenerate_2d(a, b, c) RESULT(ans) + REAL(dfp), INTENT(in) :: a, b, c + LOGICAL(lgt) :: ans + END FUNCTION +END INTERFACE !---------------------------------------------------------------------------- ! @@ -151,14 +163,14 @@ module pure function line_imp_is_degenerate_2d(a, b, c) result(ans) ! the intersection point. Otherwise, P = 0. ! -interface - module pure subroutine lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) - implicit none - real(dfp), intent(in) :: a1, b1, c1, a2, b2, c2 - real(dfp), intent(out) :: p(2) - integer(i4b), intent(out) :: ival - end subroutine -end interface +INTERFACE + MODULE PURE SUBROUTINE lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) + IMPLICIT NONE + REAL(dfp), INTENT(in) :: a1, b1, c1, a2, b2, c2 + REAL(dfp), INTENT(out) :: p(2) + INTEGER(i4b), INTENT(out) :: ival + END SUBROUTINE +END INTERFACE !---------------------------------------------------------------------------- ! @@ -197,15 +209,15 @@ module pure subroutine lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) ! Output, logical ( kind = 4 ) FLAG, is TRUE if the value could ! not be computed. -interface - module pure subroutine line_exp_perp_2d(p1, p2, p3, p4, flag) - real(dfp), intent(in) :: p1(2) - real(dfp), intent(in) :: p2(2) - real(dfp), intent(in) :: p3(2) - real(dfp), intent(out) :: p4(2) - logical(lgt), intent(out) :: flag - end subroutine -end interface +INTERFACE + MODULE PURE SUBROUTINE line_exp_perp_2d(p1, p2, p3, p4, flag) + REAL(dfp), INTENT(in) :: p1(2) + REAL(dfp), INTENT(in) :: p2(2) + REAL(dfp), INTENT(in) :: p3(2) + REAL(dfp), INTENT(out) :: p4(2) + LOGICAL(lgt), INTENT(out) :: flag + END SUBROUTINE +END INTERFACE !---------------------------------------------------------------------------- ! @@ -237,16 +249,16 @@ module pure subroutine line_exp_perp_2d(p1, p2, p3, p4, flag) ! Output, real ( kind = 8 ) P(2), if IVAl = 1, P is ! the intersection point. Otherwise, P = 0. -interface - module pure subroutine lines_exp_int_2d(p1, p2, q1, q2, ival, p) - real(kind=8), intent(in) :: p1(2) - real(kind=8), intent(in) :: p2(2) - real(kind=8), intent(in) :: q1(2) - real(kind=8), intent(in) :: q2(2) - real(kind=8), intent(out) :: p(2) - integer(i4b), intent(out) :: ival - end subroutine -end interface +INTERFACE + MODULE PURE SUBROUTINE lines_exp_int_2d(p1, p2, q1, q2, ival, p) + REAL(kind=8), INTENT(in) :: p1(2) + REAL(kind=8), INTENT(in) :: p2(2) + REAL(kind=8), INTENT(in) :: q1(2) + REAL(kind=8), INTENT(in) :: q2(2) + REAL(kind=8), INTENT(out) :: p(2) + INTEGER(i4b), INTENT(out) :: ival + END SUBROUTINE +END INTERFACE !---------------------------------------------------------------------------- ! @@ -278,14 +290,14 @@ module pure subroutine lines_exp_int_2d(p1, p2, q1, q2, ival, p) ! Output, real ( kind = 8 ) DIST, the distance from the point to the ! line segment. -interface - module pure function segment_point_dist_2d(p1, p2, p) result(dist) - real(dfp), intent(in) :: p1(2) - real(dfp), intent(in) :: p2(2) - real(dfp), intent(in) :: p(2) - real(dfp) :: dist - end function -end interface +INTERFACE + MODULE PURE FUNCTION segment_point_dist_2d(p1, p2, p) RESULT(dist) + REAL(dfp), INTENT(in) :: p1(2) + REAL(dfp), INTENT(in) :: p2(2) + REAL(dfp), INTENT(in) :: p(2) + REAL(dfp) :: dist + END FUNCTION +END INTERFACE !---------------------------------------------------------------------------- ! @@ -319,14 +331,14 @@ module pure function segment_point_dist_2d(p1, p2, p) result(dist) ! line segment. ! -interface - module pure function segment_point_dist_3d(p1, p2, p) result(dist) - real(dfp), intent(in) :: p1(3) - real(dfp), intent(in) :: p2(3) - real(dfp), intent(in) :: p(3) - real(dfp) :: dist - end function -end interface +INTERFACE + MODULE PURE FUNCTION segment_point_dist_3d(p1, p2, p) RESULT(dist) + REAL(dfp), INTENT(in) :: p1(3) + REAL(dfp), INTENT(in) :: p2(3) + REAL(dfp), INTENT(in) :: p(3) + REAL(dfp) :: dist + END FUNCTION +END INTERFACE !---------------------------------------------------------------------------- ! @@ -370,15 +382,15 @@ module pure function segment_point_dist_3d(p1, p2, p) result(dist) ! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the ! point to the line. -interface - module pure function line_exp_point_dist_signed_2d(p1, p2, p) & - & result(dist_signed) - real(dfp), intent(in) :: p(2) - real(dfp), intent(in) :: p1(2) - real(dfp), intent(in) :: p2(2) - real(dfp) :: dist_signed - end function -end interface +INTERFACE + MODULE PURE FUNCTION line_exp_point_dist_signed_2d(p1, p2, p) & + & RESULT(dist_signed) + REAL(dfp), INTENT(in) :: p(2) + REAL(dfp), INTENT(in) :: p1(2) + REAL(dfp), INTENT(in) :: p2(2) + REAL(dfp) :: dist_signed + END FUNCTION +END INTERFACE !---------------------------------------------------------------------------- ! @@ -417,15 +429,15 @@ module pure function line_exp_point_dist_signed_2d(p1, p2, p) & ! to the points P1 and P2. ! -interface - module pure subroutine segment_point_near_2d(p1, p2, p, pn, dist, t) - real(dfp), intent(in) :: p1(2) - real(dfp), intent(in) :: p2(2) - real(dfp), intent(in) :: p(2) - real(dfp), intent(out) :: pn(2) - real(dfp), intent(out) :: dist - real(dfp), intent(out) :: t - end subroutine -end interface +INTERFACE + MODULE PURE SUBROUTINE segment_point_near_2d(p1, p2, p, pn, dist, t) + REAL(dfp), INTENT(in) :: p1(2) + REAL(dfp), INTENT(in) :: p2(2) + REAL(dfp), INTENT(in) :: p(2) + REAL(dfp), INTENT(out) :: pn(2) + REAL(dfp), INTENT(out) :: dist + REAL(dfp), INTENT(out) :: t + END SUBROUTINE +END INTERFACE END MODULE Line_Method diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Line/src/ReferenceLine_Method.F90 similarity index 92% rename from src/modules/Geometry/src/ReferenceLine_Method.F90 rename to src/modules/Line/src/ReferenceLine_Method.F90 index a609e48b0..8c39b8877 100644 --- a/src/modules/Geometry/src/ReferenceLine_Method.F90 +++ b/src/modules/Line/src/ReferenceLine_Method.F90 @@ -500,9 +500,9 @@ END SUBROUTINE GetEdgeConnectivity_Line ! date: 2024-04-19 ! summary: Returns the element type of each face -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Line(elemType, faceElemType, opt, & - tFaceNodes) +INTERFACE GetFaceElemType_Line + MODULE PURE SUBROUTINE GetFaceElemType_Line1(elemType, faceElemType, opt, & + tFaceNodes) INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType !! name of element INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) @@ -513,8 +513,34 @@ MODULE PURE SUBROUTINE GetFaceElemType_Line(elemType, faceElemType, opt, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - END SUBROUTINE GetFaceElemType_Line -END INTERFACE + END SUBROUTINE GetFaceElemType_Line1 +END INTERFACE GetFaceElemType_Line + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Line + MODULE PURE SUBROUTINE GetFaceElemType_Line2(elemType, localFaceNumber, & + faceElemType, opt, tFaceNodes) + INTEGER(I4B), INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(INOUT) :: faceElemType + !! Element names of faces + INTEGER(I4B), INTENT(INOUT) :: tFaceNodes + !! Total number of nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Line2 +END INTERFACE GetFaceElemType_Line !---------------------------------------------------------------------------- ! diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90 index 7b7eeafa6..d11f8467e 100644 --- a/src/modules/MassMatrix/src/MassMatrix_Method.F90 +++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90 @@ -20,9 +20,15 @@ ! summary: This module contains method to construct finite element matrices MODULE MassMatrix_Method -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemShapeData_ +USE BaseType, ONLY: FEVariable_ +USE BaseType, ONLY: FEVariableScalar_ +USE BaseType, ONLY: FEVariableVector_ +USE BaseType, ONLY: FEVariableMatrix_ +USE GlobalData, ONLY: DFP, I4B, LGT + IMPLICIT NONE + PRIVATE PUBLIC :: MassMatrix @@ -35,17 +41,9 @@ MODULE MassMatrix_Method !> author: Vikas Sharma, Ph. D. ! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain -! -!# Introduction -! -! This subroutine makes space matrix in space domain, Here Rho $\rho$ is a -! finite element variable -! -! $$\int_{\Omega } N^{I} N^{J}d\Omega$$ -! +! summary: This subroutine makes mass matrix in space domain (see below) -INTERFACE MassMatrix +INTERFACE MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function @@ -55,20 +53,44 @@ MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans) !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION MassMatrix_1 +END INTERFACE + +INTERFACE MassMatrix + MODULE PROCEDURE MassMatrix_1 END INTERFACE MassMatrix !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE MassMatrix_ +!> author: Vikas Sharma, Ph. D. +! date: 2025-11-27 +! summary: This subroutine makes mass matrix in space domain +! +!# Introduction +! +! This subroutine makes space matrix in space domain, Here mass density +! is constant and one. +! +! $$\int_{\Omega } N^{I} N^{J}d\Omega$$ + +INTERFACE MODULE PURE SUBROUTINE MassMatrix1_(test, trial, ans, nrow, ncol, opt) CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shape function data for test function CLASS(ElemshapeData_), INTENT(IN) :: trial + !! trial function data REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! mass matrix INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! size of mass matrix INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! option for ncopy END SUBROUTINE MassMatrix1_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix1_ END INTERFACE MassMatrix_ !---------------------------------------------------------------------------- @@ -77,11 +99,11 @@ END SUBROUTINE MassMatrix1_ !> author: Vikas Sharma, Ph. D. ! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain +! summary: This subroutine makes mass matrix in space domain (see below) -INTERFACE MassMatrix +INTERFACE MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) & - & RESULT(ans) + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function CLASS(ElemshapeData_), INTENT(IN) :: trial @@ -93,13 +115,28 @@ MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) & !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION MassMatrix_2 +END INTERFACE + +INTERFACE MassMatrix + MODULE PROCEDURE MassMatrix_2 END INTERFACE MassMatrix !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -INTERFACE MassMatrix_ +!> author: Vikas Sharma, Ph. D. +! date: 2025-11-27 +! summary: This subroutine makes mass matrix in space domain (see below) +! +!# Introduction +! +! This subroutine makes space matrix in space domain, Here mass density +! is a FEVariable of scalar type. +! +! ans(I,J)=\int N^{I}\rho N^{J}d\Omega + +INTERFACE MODULE PURE SUBROUTINE MassMatrix2_(test, trial, rho, rhorank, & ans, nrow, ncol, opt) CLASS(ElemshapeData_), INTENT(IN) :: test @@ -110,6 +147,10 @@ MODULE PURE SUBROUTINE MassMatrix2_(test, trial, rho, rhorank, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt END SUBROUTINE MassMatrix2_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix2_ END INTERFACE MassMatrix_ !---------------------------------------------------------------------------- @@ -118,43 +159,63 @@ END SUBROUTINE MassMatrix2_ !> author: Vikas Sharma, Ph. D. ! date: 6 March 2021 -! summary: This subroutine makes mass matrix in space domain +! summary: This subroutine makes mass matrix in space domain (see below) -INTERFACE MassMatrix +INTERFACE MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) & - & RESULT(ans) + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function CLASS(ElemshapeData_), INTENT(IN) :: trial !! Shapedata for trial function CLASS(FEVariable_), INTENT(IN) :: rho + !! rho TYPE(FEVariableVector_), INTENT(IN) :: rhorank !! Vector INTEGER(I4B), INTENT(IN) :: opt !! ncopy REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION MassMatrix_3 +END INTERFACE + +INTERFACE MassMatrix + MODULE PROCEDURE MassMatrix_3 END INTERFACE MassMatrix !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -!> author: Shion Shimizu -! date: 2025-03-02 -! summary: mass matrix in space -! notice: not implemented yet +!> author: Vikas Sharma, Ph. D. +! date: 2025-11-27 +! summary: This subroutine makes mass matrix in space domain +! +!# Introduction +! +! This subroutine makes space matrix in space domain, Here mass density +! is a FEVariable of vector type. +! Based on opt value following tasks can be perfoemd: +! +! opt=1: M_{i1}(I,J)=\int N^{I}v_{i}N^{J}d\Omega +! opt=2: M_{1i}(I,J)=\int N^{I}v_{i}N^{J}d\Omega +! opt=3: M_{ii}(I,J)=\int N^{I}v_{i}N^{J}d\Omega +! opt=4: M_{ij}(I,J)=\int N^{I}v_{i}v_{j}N^{J}d\Omega -INTERFACE MassMatrix_ - MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, & - opt, nrow, ncol, ans) +INTERFACE + MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, rhorank, opt, & + nrow, ncol, ans) CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial CLASS(FEVariable_), INTENT(IN) :: rho + TYPE(FEVariableVector_), INTENT(IN) :: rhorank INTEGER(I4B), INTENT(IN) :: opt INTEGER(I4B), INTENT(OUT) :: nrow, ncol REAL(DFP), INTENT(INOUT) :: ans(:, :) END SUBROUTINE MassMatrix3_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix3_ END INTERFACE MassMatrix_ !---------------------------------------------------------------------------- @@ -165,18 +226,23 @@ END SUBROUTINE MassMatrix3_ ! date: 6 March 2021 ! summary: This subroutine makes mass matrix in space domain -INTERFACE MassMatrix +INTERFACE MODULE PURE FUNCTION MassMatrix_4(test, trial, rho, rhorank) & - & RESULT(ans) + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function CLASS(ElemshapeData_), INTENT(IN) :: trial !! Shapedata for trial function CLASS(FEVariable_), INTENT(IN) :: rho + !! coefficient TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank - !! Matrix + !! coefficient is a matrix REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION MassMatrix_4 +END INTERFACE + +INTERFACE MassMatrix + MODULE PROCEDURE MassMatrix_4 END INTERFACE MassMatrix !---------------------------------------------------------------------------- @@ -188,16 +254,27 @@ END FUNCTION MassMatrix_4 ! summary: mass matrix in space ! notice: not implemented yet -INTERFACE MassMatrix_ - MODULE PURE SUBROUTINE MassMatrix4_(test, trial, rho, rhorank, & - nrow, ncol, ans) +INTERFACE + MODULE PURE SUBROUTINE MassMatrix4_( & + test, trial, rho, rhorank, m4, ans, nrow, ncol) CLASS(ElemshapeData_), INTENT(IN) :: test CLASS(ElemshapeData_), INTENT(IN) :: trial CLASS(FEVariable_), INTENT(IN) :: rho + !! FEVariable TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank - INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Matrix FEVariable + REAL(DFP), INTENT(INOUT) :: m4(:, :, :, :) + !! These matrix is needed internally, + !! size of m4: nns, nns, size(rho,1), size(rho,2) REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! result + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Data written in ans END SUBROUTINE MassMatrix4_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix4_ END INTERFACE MassMatrix_ !---------------------------------------------------------------------------- @@ -208,9 +285,10 @@ END SUBROUTINE MassMatrix4_ ! date: 2024-01-15 ! summary: This subroutine makes mass matrix used for viscous boundary -INTERFACE ViscousBoundaryMassMatrix - MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & - & RESULT(ans) +INTERFACE + MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho, & + lambdaRank, muRank, rhoRank) & + RESULT(ans) CLASS(ElemshapeData_), INTENT(IN) :: test !! Shapedata for test function CLASS(ElemshapeData_), INTENT(IN) :: trial @@ -221,10 +299,200 @@ MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) & !! Lame parameter CLASS(FEVariable_), INTENT(IN) :: rho !! Mass Density + TYPE(FEVariableScalar_), INTENT(IN) :: lambdaRank, muRank, rhoRank REAL(DFP), ALLOCATABLE :: ans(:, :) END FUNCTION MassMatrix_5 +END INTERFACE + +INTERFACE MassMatrix + MODULE PROCEDURE MassMatrix_5 +END INTERFACE MassMatrix + +INTERFACE ViscousBoundaryMassMatrix + MODULE PROCEDURE MassMatrix_5 END INTERFACE ViscousBoundaryMassMatrix +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-01-15 +! summary: This subroutine makes mass matrix used for viscous boundary + +INTERFACE + MODULE PURE SUBROUTINE MassMatrix5_( & + test, trial, lambda, mu, rho, lambdaRank, muRank, rhoRank, ans, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: test + !! Shapedata for test function + CLASS(ElemshapeData_), INTENT(IN) :: trial + !! Shapedata for trial function + CLASS(FEVariable_), INTENT(IN) :: lambda + !! Lame parameter + CLASS(FEVariable_), INTENT(IN) :: mu + !! Lame parameter + CLASS(FEVariable_), INTENT(IN) :: rho + !! Mass Density + TYPE(FEVariableScalar_), INTENT(IN) :: lambdaRank, muRank, rhoRank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MassMatrix5_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix5_ +END INTERFACE MassMatrix_ + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-01-15 +! summary: This subroutine makes mass matrix mass routine + +INTERFACE + MODULE PURE SUBROUTINE MassMatrix6_( & + N, M, js, ws, thickness, nips, nns1, nns2, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: N(:, :) + !! test function data + REAL(DFP), INTENT(IN) :: M(:, :) + !! trial function data + REAL(DFP), INTENT(IN) :: js(:) + !! Jacobian determinant at integration points + REAL(DFP), INTENT(IN) :: ws(:) + !! Weights at integration points + REAL(DFP), INTENT(IN) :: thickness(:) + !! thickness at integration points + INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2 + !! number of integration points + !! number of shape functions for test function + !! number of shape functions for trial function + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MassMatrix6_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix6_ +END INTERFACE MassMatrix_ + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-01-15 +! summary: This subroutine makes mass matrix mass routine + +INTERFACE + MODULE PURE SUBROUTINE MassMatrix7_( & + N, M, js, ws, thickness, nips, nns1, nns2, skipVertices, tVertices, & + ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: N(:, :) + !! test function data + REAL(DFP), INTENT(IN) :: M(:, :) + !! trial function data + REAL(DFP), INTENT(IN) :: js(:) + !! Jacobian determinant at integration points + REAL(DFP), INTENT(IN) :: ws(:) + !! Weights at integration points + REAL(DFP), INTENT(IN) :: thickness(:) + !! thickness at integration points + INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2 + !! number of integration points + !! number of shape functions for test function + !! number of shape functions for trial function + LOGICAL(LGT), INTENT(IN) :: skipVertices + !! If true then we skip 1:tVertices rows and columns + INTEGER(I4B), INTENT(IN) :: tVertices + !! total number of vertex shape functions to be skipped + !! Used when skipVertices is true + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MassMatrix7_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix7_ +END INTERFACE MassMatrix_ + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-01-15 +! summary: This subroutine makes space time mass matrix in DOF format + +INTERFACE + MODULE PURE SUBROUTINE MassMatrix8_( & + spaceN, spaceM, timeN, timeM, js, ws, jt, wt, spaceThickness, & + timeThickness, nips, nns1, nns2, nipt, nnt1, nnt2, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: spaceN(:, :), spaceM(:, :) + !! test and trial function data in space + REAL(DFP), INTENT(IN) :: timeN(:, :), timeM(:, :) + !! test and trial function data in time + REAL(DFP), INTENT(IN) :: js(:), jt(:) + !! Jacobian determinant at integration points + REAL(DFP), INTENT(IN) :: ws(:), wt(:) + !! Weights at integration points + REAL(DFP), INTENT(IN) :: spaceThickness(:), timeThickness(:) + !! thickness at integration points + INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2, nipt, nnt1, nnt2 + !! number of integration points + !! number of shape functions for test function + !! number of shape functions for trial function + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MassMatrix8_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix8_ +END INTERFACE MassMatrix_ + +!---------------------------------------------------------------------------- +! MassMatrix@MassMatrixMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-01-15 +! summary: This subroutine makes space time mass matrix in DOF format + +INTERFACE + MODULE PURE SUBROUTINE MassMatrix9_( & + spaceN, spaceM, timeN, timeM, js, ws, jt, wt, spaceThickness, & + timeThickness, nips, nns1, nns2, nipt, nnt1, nnt2, & + skipVertices, tSpaceVertices, tTimeVertices, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: spaceN(:, :), spaceM(:, :) + !! test and trial function data in space + REAL(DFP), INTENT(IN) :: timeN(:, :), timeM(:, :) + !! test and trial function data in time + REAL(DFP), INTENT(IN) :: js(:), jt(:) + !! Jacobian determinant at integration points + REAL(DFP), INTENT(IN) :: ws(:), wt(:) + !! Weights at integration points + REAL(DFP), INTENT(IN) :: spaceThickness(:), timeThickness(:) + !! thickness at integration points + INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2, nipt, nnt1, nnt2 + !! number of integration points + !! number of shape functions for test function + !! number of shape functions for trial function + LOGICAL(LGT), INTENT(IN) :: skipVertices + !! If true then we skip 1:tSpaceVertices rows and columns + INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices + !! total number of vertex shape functions to be skipped + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MassMatrix9_ +END INTERFACE + +INTERFACE MassMatrix_ + MODULE PROCEDURE MassMatrix9_ +END INTERFACE MassMatrix_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/PENF/src/penf_stringify.F90 b/src/modules/PENF/src/penf_stringify.F90 index e34edeedc..9360c656b 100644 --- a/src/modules/PENF/src/penf_stringify.F90 +++ b/src/modules/PENF/src/penf_stringify.F90 @@ -77,19 +77,10 @@ MODULE PENF_STRINGIFY INTERFACE STR MODULE PROCEDURE & - & strf_R8P, str_R8P, & - & strf_R4P, str_R4P, & - & strf_I8P, str_I8P, & - & strf_I4P, str_I4P, & - & strf_I2P, str_I2P, & - & strf_I1P, str_I1P, & - & str_bol, & - & str_a_R8P, & - & str_a_R4P, & - & str_a_I8P, & - & str_a_I4P, & - & str_a_I2P, & - & str_a_I1P + strf_R8P, str_R8P, strf_R4P, str_R4P, strf_I8P, str_I8P, & + strf_I4P, str_I4P, strf_I2P, str_I2P, strf_I1P, str_I1P, & + str_bol, str_a_R8P, str_a_R4P, str_a_I8P, str_a_I4P, & + str_a_I2P, str_a_I1P #ifdef _R16P MODULE PROCEDURE strf_R16P, str_R16P, str_a_R16P #endif diff --git a/src/modules/Point/CMakeLists.txt b/src/modules/Point/CMakeLists.txt new file mode 100644 index 000000000..dbba7b180 --- /dev/null +++ b/src/modules/Point/CMakeLists.txt @@ -0,0 +1,19 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} PRIVATE ${src_path}/ReferencePoint_Method.F90) diff --git a/src/modules/Geometry/src/ReferencePoint_Method.F90 b/src/modules/Point/src/ReferencePoint_Method.F90 similarity index 100% rename from src/modules/Geometry/src/ReferencePoint_Method.F90 rename to src/modules/Point/src/ReferencePoint_Method.F90 diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt index e5c71feed..2404014d2 100644 --- a/src/modules/Polynomial/CMakeLists.txt +++ b/src/modules/Polynomial/CMakeLists.txt @@ -28,13 +28,6 @@ target_sources( ${src_path}/LobattoPolynomialUtility.F90 ${src_path}/UnscaledLobattoPolynomialUtility.F90 ${src_path}/Chebyshev1PolynomialUtility.F90 - ${src_path}/LineInterpolationUtility.F90 - ${src_path}/TriangleInterpolationUtility.F90 - ${src_path}/QuadrangleInterpolationUtility.F90 - ${src_path}/TetrahedronInterpolationUtility.F90 - ${src_path}/HexahedronInterpolationUtility.F90 - ${src_path}/PrismInterpolationUtility.F90 - ${src_path}/PyramidInterpolationUtility.F90 ${src_path}/RecursiveNodesUtility.F90 ${src_path}/PolynomialUtility.F90) diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 index dde8431a2..1398c5d4d 100644 --- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 +++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 @@ -153,9 +153,9 @@ END FUNCTION LagrangeVandermonde ! date: 12 Aug 2022 ! summary: Returns the Vandermonde matrix -INTERFACE - MODULE PURE SUBROUTINE LagrangeVandermonde_(xij, order, elemType, ans, & - nrow, ncol) +INTERFACE LagrangeVandermonde_ + MODULE PURE SUBROUTINE LagrangeVandermonde1_(xij, order, elemType, ans, & + nrow, ncol) REAL(DFP), INTENT(IN) :: xij(:, :) !! points in $x_{iJ}$ format INTEGER(I4B), INTENT(IN) :: order @@ -167,8 +167,32 @@ MODULE PURE SUBROUTINE LagrangeVandermonde_(xij, order, elemType, ans, & !! nrows := number of points !! ncols := number of dof INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeVandermonde_ -END INTERFACE + END SUBROUTINE LagrangeVandermonde1_ +END INTERFACE LagrangeVandermonde_ + +!---------------------------------------------------------------------------- +! LagrangeVandermonde +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 12 Aug 2022 +! summary: Returns the Vandermonde matrix + +INTERFACE LagrangeVandermonde_ + MODULE PURE SUBROUTINE LagrangeVandermonde2_(xij, degree, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in $x_{iJ}$ format + INTEGER(I4B), INTENT(IN) :: degree(:, :) + !! degree of monomials + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! vandermonde matrix + !! nrows := number of points + !! ncols := number of dof + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xij, 2) + !! ncol = SIZE(degree, 1) + END SUBROUTINE LagrangeVandermonde2_ +END INTERFACE LagrangeVandermonde_ !---------------------------------------------------------------------------- ! EquidistancePoint diff --git a/src/modules/Prism/CMakeLists.txt b/src/modules/Prism/CMakeLists.txt new file mode 100644 index 000000000..8290684d9 --- /dev/null +++ b/src/modules/Prism/CMakeLists.txt @@ -0,0 +1,21 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} PRIVATE ${src_path}/ReferencePrism_Method.F90 + ${src_path}/PrismInterpolationUtility.F90) diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Prism/src/PrismInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/PrismInterpolationUtility.F90 rename to src/modules/Prism/src/PrismInterpolationUtility.F90 diff --git a/src/modules/Geometry/src/ReferencePrism_Method.F90 b/src/modules/Prism/src/ReferencePrism_Method.F90 similarity index 91% rename from src/modules/Geometry/src/ReferencePrism_Method.F90 rename to src/modules/Prism/src/ReferencePrism_Method.F90 index 486e6237e..9a9eda535 100644 --- a/src/modules/Geometry/src/ReferencePrism_Method.F90 +++ b/src/modules/Prism/src/ReferencePrism_Method.F90 @@ -387,9 +387,12 @@ END FUNCTION RefCoord_Prism ! date: 2024-03-11 ! summary: Returns the element type of each face -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Prism(faceElemType, opt, & - & tFaceNodes, elemType) +INTERFACE GetFaceElemType_Prism + MODULE PURE SUBROUTINE GetFaceElemType_Prism1(elemType, faceElemType, & + tFaceNodes, opt) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! elemType for prism + !! default is Prism INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) !! Face element type INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:) @@ -398,10 +401,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Prism(faceElemType, opt, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! elemType for prism - !! default is Prism - END SUBROUTINE GetFaceElemType_Prism -END INTERFACE + END SUBROUTINE GetFaceElemType_Prism1 +END INTERFACE GetFaceElemType_Prism + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Prism + MODULE PURE SUBROUTINE GetFaceElemType_Prism2( & + elemType, localFaceNumber, faceElemType, tFaceNodes, opt) + INTEGER(I4B), INTENT(IN) :: elemType + !! element type for prism + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Face element type + INTEGER(I4B), INTENT(OUT) :: tFaceNodes + !! total nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Prism2 +END INTERFACE GetFaceElemType_Prism END MODULE ReferencePrism_Method diff --git a/src/modules/Projection/CMakeLists.txt b/src/modules/Projection/CMakeLists.txt new file mode 100644 index 000000000..4a3f0dd7c --- /dev/null +++ b/src/modules/Projection/CMakeLists.txt @@ -0,0 +1,19 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} PRIVATE ${src_path}/Projection_Method.F90) diff --git a/src/modules/Projection/src/Projection_Method.F90 b/src/modules/Projection/src/Projection_Method.F90 new file mode 100644 index 000000000..f9baf2490 --- /dev/null +++ b/src/modules/Projection/src/Projection_Method.F90 @@ -0,0 +1,201 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +!> author: Vikas Sharma, Ph. D. +! date: 2025-12-01 +! summary: This module contains projection methods for getting DOF values +! This module uses ElemshapeData, various matrix and forceVector +! modules + +MODULE Projection_Method +USE GlobalData, ONLY: DFP, I4B, LGT +USE BaseType, ONLY: ElemShapeData_ + +IMPLICIT NONE + +PRIVATE + +PUBLIC :: GetL2ProjectionDOFValueFromQuadrature + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-12-01 +! summary: L2 Projection method to get DOF values + +INTERFACE + MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1( & + elemsd, func, ans, tsize, massMat, ipiv, skipVertices, tVertices) + TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd + !! shape function defined on the face of element + REAL(DFP), INTENT(INOUT) :: func(:) + !! user defined functions + !! quadrature values of function + REAL(DFP), INTENT(INOUT) :: ans(:) + !! nodal coordinates of interpolation points + INTEGER(I4B), INTENT(OUT) :: tsize + !! data written in xij + REAL(DFP), INTENT(INOUT) :: massMat(:, :) + !! mass matrix + INTEGER(I4B), INTENT(INOUT) :: ipiv(:) + !! pivot indices for LU decomposition of mass matrix + LOGICAL(LGT), INTENT(IN) :: skipVertices + !! if true then we include only face bubble, that is, + !! only include internal face bubble. + INTEGER(I4B), INTENT(IN) :: tVertices + !! tVertices are needed when onlyFaceBubble is true + !! tVertices are total number of vertex degree of + !! freedom + END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1 +END INTERFACE + +INTERFACE GetL2ProjectionDOFValueFromQuadrature + MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 +END INTERFACE GetL2ProjectionDOFValueFromQuadrature + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-12-01 +! summary: L2 Projection method to get DOF values + +INTERFACE + MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2( & + elemsd, timeElemsd, func, ans, tsize, massMat, ipiv, & + skipVertices, tSpaceVertices, tTimeVertices) + TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd, timeElemsd + !! shape function defined on the face of space element + !! timeElemsd is shape function data for time element + REAL(DFP), INTENT(INOUT) :: func(:, :) + !! user defined functions quadrature values of function + !! Each column contains value at a given time quadrature points + !! Each row contains value at a given space quadrature points + !! Size should be atleast elemsd%nips by timeElemsd%nips + REAL(DFP), INTENT(INOUT) :: ans(:) + !! nodal coordinates of interpolation points + !! These are in DOF Format + INTEGER(I4B), INTENT(OUT) :: tsize + !! data written in ans + REAL(DFP), INTENT(INOUT) :: massMat(:, :) + !! mass matrix, the size should be atleast nns * nnt by nns * nnt + !! We will make space time mass matrix here + INTEGER(I4B), INTENT(INOUT) :: ipiv(:) + !! pivot indices for LU decomposition of mass matrix + !! the size should be atleast nns * nnt + LOGICAL(LGT), INTENT(IN) :: skipVertices + !! if true then we include only face bubble, that is, + !! only include internal face bubble. + INTEGER(I4B), INTENT(IN) :: tSpaceVertices + !! tSpaceVertices are needed when onlyFaceBubble is true + !! tSpaceVertices are total number of vertex degree of + !! freedom in space + INTEGER(I4B), INTENT(IN) :: tTimeVertices + !! tTimeVertices are needed when onlyFaceBubble is true + !! tTimeVertices are total number of vertex degree of + !! freedom in Time + END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2 +END INTERFACE + +INTERFACE GetL2ProjectionDOFValueFromQuadrature + MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2 +END INTERFACE GetL2ProjectionDOFValueFromQuadrature + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-12-01 +! summary: L2 Projection of constant function + +INTERFACE + MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature3( & + elemsd, ans, tsize, massMat, ipiv, skipVertices, tVertices) + TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd + !! shape function defined on the face of element + REAL(DFP), INTENT(INOUT) :: ans(:) + !! nodal coordinates of interpolation points + INTEGER(I4B), INTENT(OUT) :: tsize + !! data written in xij + REAL(DFP), INTENT(INOUT) :: massMat(:, :) + !! mass matrix + INTEGER(I4B), INTENT(INOUT) :: ipiv(:) + !! pivot indices for LU decomposition of mass matrix + LOGICAL(LGT), INTENT(IN) :: skipVertices + !! if true then we include only face bubble, that is, + !! only include internal face bubble. + INTEGER(I4B), INTENT(IN) :: tVertices + !! tVertices are needed when onlyFaceBubble is true + !! tVertices are total number of vertex degree of + !! freedom + END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature3 +END INTERFACE + +INTERFACE GetL2ProjectionDOFValueFromQuadrature + MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature3 +END INTERFACE GetL2ProjectionDOFValueFromQuadrature + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValue +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-12-01 +! summary: L2 Projection method to get DOF values + +INTERFACE + MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature4( & + elemsd, timeElemsd, ans, tsize, massMat, ipiv, & + skipVertices, tSpaceVertices, tTimeVertices) + TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd, timeElemsd + !! shape function defined on the face of space element + !! timeElemsd is shape function data for time element + REAL(DFP), INTENT(INOUT) :: ans(:) + !! nodal coordinates of interpolation points + !! These are in DOF Format + INTEGER(I4B), INTENT(OUT) :: tsize + !! data written in ans + REAL(DFP), INTENT(INOUT) :: massMat(:, :) + !! mass matrix, the size should be atleast nns * nnt by nns * nnt + !! We will make space time mass matrix here + INTEGER(I4B), INTENT(INOUT) :: ipiv(:) + !! pivot indices for LU decomposition of mass matrix + !! the size should be atleast nns * nnt + LOGICAL(LGT), INTENT(IN) :: skipVertices + !! if true then we include only face bubble, that is, + !! only include internal face bubble. + INTEGER(I4B), INTENT(IN) :: tSpaceVertices + !! tSpaceVertices are needed when onlyFaceBubble is true + !! tSpaceVertices are total number of vertex degree of + !! freedom in space + INTEGER(I4B), INTENT(IN) :: tTimeVertices + !! tTimeVertices are needed when onlyFaceBubble is true + !! tTimeVertices are total number of vertex degree of + !! freedom in Time + END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature4 +END INTERFACE + +INTERFACE GetL2ProjectionDOFValueFromQuadrature + MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature4 +END INTERFACE GetL2ProjectionDOFValueFromQuadrature + +END MODULE Projection_Method diff --git a/src/modules/Pyramid/CMakeLists.txt b/src/modules/Pyramid/CMakeLists.txt new file mode 100644 index 000000000..6d28594e0 --- /dev/null +++ b/src/modules/Pyramid/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferencePyramid_Method.F90 + PRIVATE ${src_path}/PyramidInterpolationUtility.F90) diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Pyramid/src/PyramidInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/PyramidInterpolationUtility.F90 rename to src/modules/Pyramid/src/PyramidInterpolationUtility.F90 diff --git a/src/modules/Geometry/src/ReferencePyramid_Method.F90 b/src/modules/Pyramid/src/ReferencePyramid_Method.F90 similarity index 90% rename from src/modules/Geometry/src/ReferencePyramid_Method.F90 rename to src/modules/Pyramid/src/ReferencePyramid_Method.F90 index 64e15d10c..f468e75cb 100644 --- a/src/modules/Geometry/src/ReferencePyramid_Method.F90 +++ b/src/modules/Pyramid/src/ReferencePyramid_Method.F90 @@ -335,9 +335,11 @@ END FUNCTION RefCoord_Pyramid ! date: 2024-03-11 ! summary: Returns the element type of each face -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Pyramid(faceElemType, opt, & - & tFaceNodes, elemType) +INTERFACE GetFaceElemType_Pyramid + MODULE PURE SUBROUTINE GetFaceElemType_Pyramid1(elemType, faceElemType, & + tFaceNodes, opt) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! Element type INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) !! Face element type INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:) @@ -346,9 +348,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Pyramid(faceElemType, opt, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType - !! Element type - END SUBROUTINE GetFaceElemType_Pyramid -END INTERFACE + END SUBROUTINE GetFaceElemType_Pyramid1 +END INTERFACE GetFaceElemType_Pyramid + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Pyramid + MODULE PURE SUBROUTINE GetFaceElemType_Pyramid2( & + elemType, localFaceNumber, faceElemType, tFaceNodes, opt) + INTEGER(I4B), INTENT(IN) :: elemType + !! element type for prism + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Face element type + INTEGER(I4B), INTENT(OUT) :: tFaceNodes + !! total nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Pyramid2 +END INTERFACE GetFaceElemType_Pyramid END MODULE ReferencePyramid_Method diff --git a/src/modules/Quadrangle/CMakeLists.txt b/src/modules/Quadrangle/CMakeLists.txt new file mode 100644 index 000000000..4f74c0af2 --- /dev/null +++ b/src/modules/Quadrangle/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferenceQuadrangle_Method.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility.F90) diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 similarity index 87% rename from src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 rename to src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 index 05a408880..c344df87a 100644 --- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 +++ b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90 @@ -15,8 +15,12 @@ ! MODULE QuadrangleInterpolationUtility -USE GlobalData +USE GlobalData, ONLY: I4B, DFP, LGT, stderr USE String_Class, ONLY: String +USE BaseType, ONLY: TypeInterpolationOpt, & + TypeQuadratureOpt, & + TypeElemNameOpt, & + TypePolynomialOpt IMPLICIT NONE @@ -86,8 +90,35 @@ MODULE QuadrangleInterpolationUtility PUBLIC :: GetTotalDOF_Quadrangle PUBLIC :: GetTotalInDOF_Quadrangle +PUBLIC :: GetHierarchicalDOF_Quadrangle + +!---------------------------------------------------------------------------- +! GetHierarchicalDOF_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-18 +! summary: Get the Hierarchical DOF for Quadrangle + +! order, pe1, pe2, pe3 +INTERFACE + MODULE PURE FUNCTION GetHierarchicalDOF_Quadrangle( & + pb, qb, pe3, pe4, qe1, qe2, opt) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb, qb + !! cell order + INTEGER(I4B), INTENT(IN) :: qe1, qe2, pe3, pe4 + !! face order + CHARACTER(1), INTENT(IN) :: opt + !! 'V' - vertex + !! 'E' - edge + !! 'C' - cell + !! 'H' - total hierarchical dof + INTEGER(I4B) :: ans + END FUNCTION GetHierarchicalDOF_Quadrangle +END INTERFACE + !---------------------------------------------------------------------------- -! GetTotalDOF_Quadrangle +! GetTotalDOF_Quadrangle@DOFMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -106,7 +137,7 @@ END FUNCTION GetTotalDOF_Quadrangle END INTERFACE !---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle +! LagrangeInDOF_Quadrangle@DOFMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -131,7 +162,7 @@ END FUNCTION GetTotalInDOF_Quadrangle1 END INTERFACE GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -! +! GetTotalInDOF_Quadrangle@DOFMethods !---------------------------------------------------------------------------- INTERFACE GetTotalInDOF_Quadrangle @@ -145,120 +176,7 @@ END FUNCTION GetTotalInDOF_Quadrangle2 END INTERFACE GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -! RefElemDomain_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-07-03 -! summary: Returns the coordinate of reference element - -INTERFACE - MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) & - RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseContinuity - !! Cointinuity (conformity) of basis functions - !! "H1", "HDiv", "HCurl", "DG" - CHARACTER(*), INTENT(IN) :: baseInterpol - !! Basis function family for Interpolation - !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal - TYPE(String) :: ans - END FUNCTION RefElemDomain_Quadrangle -END INTERFACE - -!---------------------------------------------------------------------------- -! FacetConnectivity_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 2023-08-10 -! summary: This function returns the edge connectivity of Quadrangle - -INTERFACE - MODULE FUNCTION FacetConnectivity_Quadrangle(baseInterpol, baseContinuity) & - RESULT(ans) - CHARACTER(*), 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 SUBROUTINE LagrangeDegree_Quadrangle1_(order, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: order - INTEGER(I4B), INTENT(INOUT) :: ans(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeDegree_Quadrangle1_ -END INTERFACE LagrangeDegree_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Returns the degree of monomials for Lagrange polynomials - -INTERFACE LagrangeDegree_Quadrangle - MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), ALLOCATABLE :: ans(:, :) - END FUNCTION LagrangeDegree_Quadrangle2 -END INTERFACE LagrangeDegree_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -INTERFACE LagrangeDegree_Quadrangle_ - MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(INOUT) :: ans(:, :) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE LagrangeDegree_Quadrangle2_ -END INTERFACE LagrangeDegree_Quadrangle_ - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle +! LagrangeDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -274,7 +192,7 @@ END FUNCTION LagrangeDOF_Quadrangle1 END INTERFACE LagrangeDOF_Quadrangle !---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle +! LagrangeDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -291,7 +209,7 @@ END FUNCTION LagrangeDOF_Quadrangle2 END INTERFACE LagrangeDOF_Quadrangle !---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle +! LagrangeInDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -313,7 +231,7 @@ END FUNCTION LagrangeInDOF_Quadrangle1 END INTERFACE LagrangeInDOF_Quadrangle !---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle +! LagrangeInDOF_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -335,2029 +253,1988 @@ END FUNCTION LagrangeInDOF_Quadrangle2 END INTERFACE LagrangeInDOF_Quadrangle !---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle +! LagrangeDegree_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Quadrangle element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Quadrangle element -!- The coordinates are distributed uniformly -!- These coordinates can be used to construct lagrange polynomials -!- The returned coordinates are in $x_{iJ}$ format. -!- The node numbering is according to Gmsh convention. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials -INTERFACE EquidistancePoint_Quadrangle - MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle1(order, xij) & - RESULT(ans) +INTERFACE LagrangeDegree_Quadrangle + MODULE PURE FUNCTION LagrangeDegree_Quadrangle1(order) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistancePoint_Quadrangle1 -END INTERFACE EquidistancePoint_Quadrangle + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Quadrangle1 +END INTERFACE LagrangeDegree_Quadrangle !---------------------------------------------------------------------------- -! +! LagrangeDegree_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE EquidistancePoint_Quadrangle_ - MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle1_(order, & - ans, nrow, ncol, xij) +!> author: Vikas Sharma, Ph. D. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials + +INTERFACE LagrangeDegree_Quadrangle_ + MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle1_(order, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns in ans - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 - !! number of cols = 4 - END SUBROUTINE EquidistancePoint_Quadrangle1_ -END INTERFACE EquidistancePoint_Quadrangle_ + END SUBROUTINE LagrangeDegree_Quadrangle1_ +END INTERFACE LagrangeDegree_Quadrangle_ !---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle +! LagrangeDegree_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 12 Aug 2022 -! summary: Returns the nodal coordinates of higher order Quadrangle element -! -!# Introduction -! -!- This function returns the nodal coordinates of higher order -! Quadrangle element -!- The coordinates are distributed uniformly -!- These coordinates can be used to construct lagrange polynomials -!- The returned coordinates are in $x_{iJ}$ format. -!- The node numbering is according to Gmsh convention. +! date: 18 Aug 2022 +! summary: Returns the degree of monomials for Lagrange polynomials -INTERFACE EquidistancePoint_Quadrangle - MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, & - xij) RESULT(ans) +INTERFACE LagrangeDegree_Quadrangle + MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p - !! order in x direction INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistancePoint_Quadrangle2 -END INTERFACE EquidistancePoint_Quadrangle + INTEGER(I4B), ALLOCATABLE :: ans(:, :) + END FUNCTION LagrangeDegree_Quadrangle2 +END INTERFACE LagrangeDegree_Quadrangle !---------------------------------------------------------------------------- -! +! LagrangeDegree_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE EquidistancePoint_Quadrangle_ - MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle2_(p, q, ans, & - nrow, ncol, xij) +INTERFACE LagrangeDegree_Quadrangle_ + MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: p - !! order in x direction INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points + INTEGER(I4B), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE EquidistancePoint_Quadrangle2_ -END INTERFACE EquidistancePoint_Quadrangle_ + END SUBROUTINE LagrangeDegree_Quadrangle2_ +END INTERFACE LagrangeDegree_Quadrangle_ !---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle +! MonomialBasis_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Quadrangle -! -!# Introduction -! -!- This function returns the equidistance points in Quadrangle -!- All points are inside the Quadrangle +INTERFACE + MODULE PURE SUBROUTINE MonomialBasis_Quadrangle_( & + p, q, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2) -> Number of points of evaluation + !! ncol = (p + 1) * (q + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE MonomialBasis_Quadrangle_ +END INTERFACE -INTERFACE EquidistanceInPoint_Quadrangle - MODULE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & - RESULT(ans) +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistanceInPoint_Quadrangle1 -END INTERFACE EquidistanceInPoint_Quadrangle + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP) :: ans(SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle1 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 14 Aug 2022 -! summary: Returns equidistance points in Quadrangle -! -!# Introduction -! -!- This function returns the equidistance points in Quadrangle -!- All points are inside the Quadrangle +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle1_(order, i, xij, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Quadrangle1_ +END INTERFACE LagrangeCoeff_Quadrangle_ -INTERFACE EquidistanceInPoint_Quadrangle - MODULE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & RESULT(ans) - INTEGER(I4B), INTENT(IN) :: p - !! order in x direction - INTEGER(I4B), INTENT(IN) :: q - !! order in y direction - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! Nodal coordinates of quadrangle - !! number of rows = 2 or 3 - !! number of cols = 4 - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! returned coordinates of interpolation points in $x_{iJ}$ format. - !! Number of rows in ans is equal to the 2 - !! Number of columns in ans is equal to the number of points - END FUNCTION EquidistanceInPoint_Quadrangle2 -END INTERFACE EquidistanceInPoint_Quadrangle + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + !! This is just to resolve interface issue + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle2 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point -! -!# Introduction -! -! In this case order is same in both x1 and x2 direction. Therefore, -! (N+1)**2 grid points are returned. -! -! Also in both x1 and x2 same type of grid family will be used. -! -!- This routine returns the interplation points on quad -!- `xij` contains nodal coordinates of quad in xij format. -!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4 -!- If xij is absent then biunit quad is used -!- `ipType` is interpolation point type, it can take following values -!- `Equidistance`, uniformly/evenly distributed points -!- `GaussLegendreLobatto -!- `GaussChebyshevLobatto -! -!- `layout` specifies the arrangement of points. The nodes are always -! returned in VEFC format (vertex, edge, face, cell). 1:3 are are -! vertex points, then edge, and then internal nodes. The internal nodes -! also follow the same convention. Please read Gmsh manual on this topic. +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle2_(order, i, v, isVandermonde, & + ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(v,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! coefficient for ith lagrange polynomial + REAL(DFP), INTENT(IN) :: v(:, :) + !! vandermonde matrix size should be (order+1,order+1) + LOGICAL(LGT), INTENT(IN) :: isVandermonde + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Quadrangle2_ +END INTERFACE LagrangeCoeff_Quadrangle_ -INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, & - xij, alpha, beta, lambda) RESULT(ans) +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order of element - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - !! Equidistance - !! GaussLegendre - !! GaussLegendreLobatto - !! GaussLegendreRadauLeft - !! GaussLegendreRadauRight - !! GaussChebyshev1 - !! GaussChebyshev1Lobatto - !! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight - !! GaussUltraspherical - !! GaussUltrasphericalLobatto - !! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight - !! GaussJacobi - !! GaussJacobiLobatto - !! GaussJacobiRadauLeft - !! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: layout - !! VEFC, INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP) :: ans(SIZE(v, 1)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle3 +END INTERFACE LagrangeCoeff_Quadrangle + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle_@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle3_(order, i, v, ipiv, ans, tsize) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial, it should be SIZE(x,2)-1 + INTEGER(I4B), INTENT(IN) :: i + !! ith coefficients for lagrange polynomial + REAL(DFP), INTENT(INOUT) :: v(:, :) + !! LU decomposition of vandermonde matrix + INTEGER(I4B), INTENT(IN) :: ipiv(:) + !! inverse pivoting mapping, compes from LU decomposition + REAL(DFP), INTENT(INOUT) :: ans(:) + !! ans(SIZE(v, 1)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: tsize + END SUBROUTINE LagrangeCoeff_Quadrangle3_ +END INTERFACE LagrangeCoeff_Quadrangle_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle@LagrangeMethods +!---------------------------------------------------------------------------- + +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle4(order, xij, basisType, alpha, & + beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials + !! Jacobi + !! Legendre + !! Chebyshev + !! Ultraspherical + !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION InterpolationPoint_Quadrangle1 -END INTERFACE InterpolationPoint_Quadrangle + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle4 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle_ +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE InterpolationPoint_Quadrangle_ - MODULE SUBROUTINE InterpolationPoint_Quadrangle1_(order, ipType, ans, & - nrow, ncol, layout, xij, alpha, beta, lambda) +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, & + alpha, beta, lambda, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order - !! order of element - INTEGER(I4B), INTENT(IN) :: ipType - !! interpolation point type - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - CHARACTER(*), INTENT(IN) :: layout - !! VEFC, INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - END SUBROUTINE InterpolationPoint_Quadrangle1_ -END INTERFACE InterpolationPoint_Quadrangle_ + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Quadrangle4_ +END INTERFACE LagrangeCoeff_Quadrangle_ !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle +! LagrangeCoeff_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 18 Aug 2022 -! summary: Interpolation point -! -!# Introduction -! -! In this case order is same in both x1 and x2 direction. Therefore, -! (N+1)**2 grid points are returned. -! -! Also in both x1 and x2 same type of grid family will be used. -! -!- This routine returns the interplation points on quad -!- `xij` contains nodal coordinates of quad in xij format. -!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4 -!- If xij is absent then biunit quad is used -!- `ipType` is interpolation point type, it can take following values -!- `Equidistance`, uniformly/evenly distributed points -!- `GaussLegendreLobatto -!- `GaussChebyshevLobatto -! -!- `layout` specifies the arrangement of points. The nodes are always -! returned in VEFC format (vertex, edge, face, cell). 1:3 are are -! vertex points, then edge, and then internal nodes. The internal nodes -! also follow the same convention. Please read Gmsh manual on this topic. - -INTERFACE InterpolationPoint_Quadrangle - MODULE FUNCTION InterpolationPoint_Quadrangle2(p, q, ipType1, ipType2, & - layout, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) +INTERFACE LagrangeCoeff_Quadrangle + MODULE FUNCTION LagrangeCoeff_Quadrangle5(p, q, xij, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) INTEGER(I4B), INTENT(IN) :: p - !! order of element in x direction + !! order of polynomial in x direction INTEGER(I4B), INTENT(IN) :: q - !! order of element in y direction - INTEGER(I4B), INTENT(IN) :: ipType1 - !! interpolation point type in x direction - INTEGER(I4B), INTENT(IN) :: ipType2 - !! interpolation point type in y direction - CHARACTER(*), INTENT(IN) :: layout - !! VEFC, INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format + !! order of polynomial in y direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basisType in x direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basisType in y direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter + !! This parameter is needed when basisType is Ultraspherical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION InterpolationPoint_Quadrangle2 -END INTERFACE InterpolationPoint_Quadrangle + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + END FUNCTION LagrangeCoeff_Quadrangle5 +END INTERFACE LagrangeCoeff_Quadrangle !---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle_ +! LagrangeCoeff_Quadrangle_@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE InterpolationPoint_Quadrangle_ - MODULE SUBROUTINE InterpolationPoint_Quadrangle2_(p, q, ipType1, ipType2, & - ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, & - alpha2, beta2, lambda2) +INTERFACE LagrangeCoeff_Quadrangle_ + MODULE SUBROUTINE LagrangeCoeff_Quadrangle5_(p, q, xij, basisType1, & + basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2, & + ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: p - !! order of element in x direction + !! order of polynomial in x direction INTEGER(I4B), INTENT(IN) :: q - !! order of element in y direction - INTEGER(I4B), INTENT(IN) :: ipType1 - !! interpolation point type in x direction - INTEGER(I4B), INTENT(IN) :: ipType2 - !! interpolation point type in y direction - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! - CHARACTER(*), INTENT(IN) :: layout - !! VEFC, INCREASING - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format + !! order of polynomial in y direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType1 + !! basisType in x direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical + INTEGER(I4B), INTENT(IN) :: basisType2 + !! basisType in y direction + !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical + !! Heirarchical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter + !! This parameter is needed when basisType is Ultraspherical REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter + !! This parameter is needed when basisType is Jacobi REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - END SUBROUTINE InterpolationPoint_Quadrangle2_ -END INTERFACE InterpolationPoint_Quadrangle_ - -!---------------------------------------------------------------------------- -! 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 + !! This parameter is needed when basisType is Ultraspherical + REAL(DFP), INTENT(INOUT) :: ans(:, :) + ! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Quadrangle5_ +END INTERFACE LagrangeCoeff_Quadrangle_ !---------------------------------------------------------------------------- -! +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-07-17 -! summary: Convert format from IJ to VEFC - -INTERFACE - MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, & - temp, p, q, startNode) - REAL(DFP), INTENT(IN) :: xi(:, :) - REAL(DFP), INTENT(IN) :: eta(:, :) - REAL(DFP), INTENT(OUT) :: temp(:, :) - INTEGER(I4B), INTENT(IN) :: p - INTEGER(I4B), INTENT(IN) :: q - INTEGER(I4B), INTENT(IN) :: startNode - END SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise -END INTERFACE - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- +! date: 2023-07-04 +! summary: Evaluate all Lagrange polynomial of order n at single points -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans) +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 polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) + !! 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)) - !! coefficients - END FUNCTION LagrangeCoeff_Quadrangle1 -END INTERFACE LagrangeCoeff_Quadrangle + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Quadrangle1 +END INTERFACE LagrangeEvalAll_Quadrangle !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle_ +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle1_(order, i, xij, ans, tsize) +INTERFACE LagrangeEvalAll_Quadrangle_ + MODULE SUBROUTINE LagrangeEvalAll_Quadrangle1_( & + order, x, xij, ans, tsize, coeff, firstCall, basisType, alpha, beta, & + lambda) INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - INTEGER(I4B), INTENT(IN) :: i - !! ith coefficients for lagrange polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) + !! 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)) - !! coefficients + !! Value of n+1 Lagrange polynomials at point x INTEGER(I4B), INTENT(OUT) :: tsize - END SUBROUTINE LagrangeCoeff_Quadrangle1_ -END INTERFACE LagrangeCoeff_Quadrangle_ + !! 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_ !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) & +!> 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 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 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_ + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + END FUNCTION LagrangeEvalAll_Quadrangle2 +END INTERFACE LagrangeEvalAll_Quadrangle !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) RESULT(ans) +INTERFACE LagrangeEvalAll_Quadrangle_ + MODULE SUBROUTINE LagrangeEvalAll_Quadrangle2_( & + order, x, xij, ans, nrow, ncol, coeff, firstCall, basisType, alpha, & + beta, lambda) INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial, 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 + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation + !! x(1, :) is x coord + !! x(2, :) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT), OPTIONAL :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default + !! Jacobi=Dubiner + !! Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Quadrangle2_ +END INTERFACE LagrangeEvalAll_Quadrangle_ !---------------------------------------------------------------------------- -! +! LagrangeEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle3_(order, i, v, ipiv, ans, tsize) +INTERFACE LagrangeEvalAll_Quadrangle_ + MODULE SUBROUTINE LagrangeEvalAll_Quadrangle3_( & + order, x, xij, ans, nrow, ncol, coeff, xx, firstCall, basisType, alpha, & + beta, lambda) INTEGER(I4B), INTENT(IN) :: order - !! order of 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_ + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation, x(1, :) is x coord, x(2, :) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + !! nrow = number of points of evaluation + !! ncol = number of degrees of freedom + REAL(DFP), INTENT(INOUT) :: coeff(:, :), xx(:, :) + !! Coefficient of Lagrange polynomials, The size is ncol by ncol + !! The size of xx is nrow by ncol (it is used internally) + !! nrow is number of points of evaluation + !! ncol is number of degrees of freedom + LOGICAL(LGT) :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType + !! Monomials *Default, Jacobi=Dubiner, Heirarchical + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE LagrangeEvalAll_Quadrangle3_ +END INTERFACE LagrangeEvalAll_Quadrangle_ !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! LagrangeGradientEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle - MODULE FUNCTION LagrangeCoeff_Quadrangle4(order, xij, basisType, alpha, & - beta, lambda) RESULT(ans) +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-23 +! summary: Evaluate Lagrange polynomials of n at several points + +INTERFACE LagrangeGradientEvalAll_Quadrangle + MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( & + order, x, xij, coeff, firstCall, basisType, alpha, beta, lambda) & + RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) + !! 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 - !! Monomials - !! Jacobi - !! Legendre - !! Chebyshev - !! Ultraspherical - !! Heirarchical + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! This parameter is needed when basisType is Jacobi + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! This parameter is needed when basisType is Jacobi + !! Jacobi polynomial parameter 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 + !! Ultraspherical parameter + REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 2) + !! Value of gradient of nth order Lagrange polynomials at point x + !! The first index denotes point of evaluation + !! the second index denotes Lagrange polynomial number + !! The third index denotes the spatial dimension in which gradient is + !! computed + END FUNCTION LagrangeGradientEvalAll_Quadrangle1 +END INTERFACE LagrangeGradientEvalAll_Quadrangle !---------------------------------------------------------------------------- -! +! LagrangeGradientEvalAll_Quadrangle@LagrangeMethods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, & - alpha, beta, lambda, ans, nrow, ncol) +INTERFACE LagrangeGradientEvalAll_Quadrangle_ + MODULE SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_( & + order, x, xij, ans, dim1, dim2, dim3, coeff, firstCall, basisType, & + alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in xij format, size(xij,2) + !! 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 - !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical - !! Heirarchical + !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! This parameter is needed when basisType is Jacobi + !! Jacobi polynomial parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! This parameter is needed when basisType is Jacobi + !! Jacobi polynomial parameter 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_ + !! Ultraspherical parameter + END SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_ +END INTERFACE LagrangeGradientEvalAll_Quadrangle_ !---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle +! RefElemDomain_Quadrangle@Methods !---------------------------------------------------------------------------- -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 +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-03 +! summary: Returns the coordinate of reference element + +INTERFACE + MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) & + RESULT(ans) + CHARACTER(*), INTENT(IN) :: baseContinuity + !! Cointinuity (conformity) of basis functions + !! "H1", "HDiv", "HCurl", "DG" + CHARACTER(*), INTENT(IN) :: baseInterpol + !! Basis function family for Interpolation + !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal + TYPE(String) :: ans + END FUNCTION RefElemDomain_Quadrangle +END INTERFACE !---------------------------------------------------------------------------- -! +! FacetConnectivity_Quadrangle@Methods !---------------------------------------------------------------------------- -INTERFACE LagrangeCoeff_Quadrangle_ - MODULE SUBROUTINE LagrangeCoeff_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_ +!> author: Vikas Sharma, Ph. D. +! date: 2023-08-10 +! summary: This function returns the edge connectivity of Quadrangle + +INTERFACE + MODULE FUNCTION FacetConnectivity_Quadrangle(baseInterpol, baseContinuity) & + RESULT(ans) + CHARACTER(*), OPTIONAL, INTENT(IN) :: baseInterpol + CHARACTER(*), OPTIONAL, INTENT(IN) :: baseContinuity + INTEGER(I4B) :: ans(2, 4) + !! rows represents the end points of an edges + !! columns denote the edge (facet) + END FUNCTION FacetConnectivity_Quadrangle +END INTERFACE !---------------------------------------------------------------------------- -! DubinerPolynomial +! EquidistancePoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Quadrangle element ! !# 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} -!$$ +!- 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 Dubiner_Quadrangle - MODULE PURE FUNCTION Dubiner_Quadrangle1(order, xij) RESULT(ans) +INTERFACE EquidistancePoint_Quadrangle + MODULE RECURSIVE FUNCTION EquidistancePoint_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 + !! 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 !---------------------------------------------------------------------------- -! DubinerPolynomial +! EquidistancePoint_Quadrangle_@InterpolationPointMethods !---------------------------------------------------------------------------- -!> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain -! -!# Introduction -! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is 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) +INTERFACE EquidistancePoint_Quadrangle_ + MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle1_(order, ans, & + nrow, ncol, xij) INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in biunit quadrangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points + !! order 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 + !! 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 Dubiner_Quadrangle1_ -END INTERFACE Dubiner_Quadrangle_ + !! number of rows and columns in ans + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 + !! number of cols = 4 + END SUBROUTINE EquidistancePoint_Quadrangle1_ +END INTERFACE EquidistancePoint_Quadrangle_ !---------------------------------------------------------------------------- -! DubinerPolynomial +! EquidistancePoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 12 Aug 2022 +! summary: Returns the nodal coordinates of higher order Quadrangle element ! !# 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`. +!- 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 Dubiner_Quadrangle - MODULE PURE FUNCTION Dubiner_Quadrangle2(order, x, y) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: x(:) - !! x coordinate on line - REAL(DFP), INTENT(IN) :: y(:) - !! y coordinate on line - REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) - !! shape functions - !! ans(:, j), jth shape functions at all points - !! ans(j, :), all shape functions at jth point - END FUNCTION Dubiner_Quadrangle2 -END INTERFACE Dubiner_Quadrangle +INTERFACE EquidistancePoint_Quadrangle + MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, & + xij) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + END FUNCTION EquidistancePoint_Quadrangle2 +END INTERFACE EquidistancePoint_Quadrangle + +!---------------------------------------------------------------------------- +! EquidistancePoint_Quadrangle_@InterpolationPointMethods +!---------------------------------------------------------------------------- + +INTERFACE EquidistancePoint_Quadrangle_ + MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle2_(p, q, ans, & + nrow, ncol, xij) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE EquidistancePoint_Quadrangle2_ +END INTERFACE EquidistancePoint_Quadrangle_ !---------------------------------------------------------------------------- -! DubinerPolynomial +! EquidistanceInPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 14 Aug 2022 +! summary: Returns equidistance points in Quadrangle ! !# Introduction ! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is same as Dubiner_Quadrangle1 -! The only difference is that xij are given by outerproduct of x and y. -! This function calls `Dubiner_Quadrangle1`. +!- This function returns the equidistance points in Quadrangle +!- All points are inside the Quadrangle -INTERFACE Dubiner_Quadrangle_ - MODULE PURE SUBROUTINE Dubiner_Quadrangle2_(order, x, y, ans, nrow, ncol) +INTERFACE EquidistanceInPoint_Quadrangle + MODULE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) & + 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), 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_ + !! 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 !---------------------------------------------------------------------------- -! DubinerGradient +! EquidistanceInPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 14 Aug 2022 +! summary: Returns equidistance points in Quadrangle ! !# Introduction ! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is called while forming dubiner basis on triangle domain -! -! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) -! N = 0.5*(order+1)*(order+2). -! -! In this way, ans(j,:) denotes the values of all polynomial at jth point -! -! Polynomials are returned in following way: -! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ -! -! 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} -!$$ +!- This function returns the equidistance points in Quadrangle +!- All points are inside the Quadrangle -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 +INTERFACE EquidistanceInPoint_Quadrangle + MODULE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order in y direction + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! Nodal coordinates of quadrangle + !! number of rows = 2 or 3 + !! number of cols = 4 + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! returned coordinates of interpolation points in $x_{iJ}$ format. + !! Number of rows in ans is equal to the 2 + !! Number of columns in ans is equal to the number of points + END FUNCTION EquidistanceInPoint_Quadrangle2 +END INTERFACE EquidistanceInPoint_Quadrangle !---------------------------------------------------------------------------- -! DubinerGradient +! InterpolationPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Dubiner (1991) polynomials on biunit domain +! date: 18 Aug 2022 +! summary: Interpolation point ! !# Introduction ! -! Forms Dubiner basis on biunit quadrangle domain. -! This routine is called while forming dubiner basis on triangle domain -! -! 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 +! In this case order is same in both x1 and x2 direction. Therefore, +! (N+1)**2 grid points are returned. ! -! Polynomials are returned in following way: +! Also in both x1 and x2 same type of grid family will be used. ! -!$$ -! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ -! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ -! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ -! \cdots -! P_{order,0} -!$$ +!- This 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 ! -! For example for order=3, the polynomials are arranged as: +!- `layout` specifies the arrangement of points. The nodes are always +! returned in VEFC format (vertex, edge, face, cell). 1:3 are are +! vertex points, then edge, and then internal nodes. The internal nodes +! also follow the same convention. Please read Gmsh manual on this topic. ! -!$$ -! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ -! P_{1,0}, P_{1,1}, P_{1,2} \\ -! P_{2,0}, P_{2,1} \\ -! P_{3,0} -!$$ +! interpolation point type +! Equidistance +! GaussLegendre +! GaussLegendreLobatto +! GaussLegendreRadauLeft +! GaussLegendreRadauRight +! GaussChebyshev1 +! GaussChebyshev1Lobatto +! GaussChebyshev1RadauLeft +! GaussChebyshev1RadauRight +! GaussUltraspherical +! GaussUltrasphericalLobatto +! GaussUltrasphericalRadauLeft +! GaussUltrasphericalRadauRight +! GaussJacobi +! GaussJacobiLobatto +! GaussJacobiRadauLeft +! GaussJacobiRadauRight -INTERFACE DubinerGradient_Quadrangle_ - MODULE PURE SUBROUTINE DubinerGradient_Quadrangle1_(order, xij, ans, & - tsize1, tsize2, tsize3) +INTERFACE InterpolationPoint_Quadrangle + MODULE FUNCTION InterpolationPoint_Quadrangle1( & + order, ipType, layout, xij, alpha, beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order - !! order of polynomial space - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points in biunit quadrangle, shape functions will be evaluated - !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points - 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_ + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION InterpolationPoint_Quadrangle1 +END INTERFACE InterpolationPoint_Quadrangle + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle_@InterpolationPointMethods +!---------------------------------------------------------------------------- + +INTERFACE InterpolationPoint_Quadrangle_ + MODULE SUBROUTINE InterpolationPoint_Quadrangle1_( & + order, ipType, ans, nrow, ncol, layout, xij, alpha, beta, lambda) + INTEGER(I4B), INTENT(IN) :: order + !! order of element + INTEGER(I4B), INTENT(IN) :: ipType + !! interpolation point type + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Quadrangle1_ +END INTERFACE InterpolationPoint_Quadrangle_ !---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle +! InterpolationPoint_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 27 Oct 2022 -! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle +! date: 18 Aug 2022 +! summary: Interpolation point ! !# Introduction ! -! This function returns the tensor product expansion of orthogonal -! polynomial on biunit quadrangle. +! 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 TensorProdBasis_Quadrangle - MODULE FUNCTION TensorProdBasis_Quadrangle1(p, q, xij, basisType1, & - basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans) +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 - !! highest order in x1 direction + !! order of element in x 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 + !! order of element in y direction + INTEGER(I4B), INTENT(IN) :: ipType1 + !! interpolation point type in x direction + INTEGER(I4B), INTENT(IN) :: ipType2 + !! interpolation point type in y direction + CHARACTER(*), INTENT(IN) :: layout + !! VEFC, INCREASING + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" + !! Ultraspherical parameter REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) - !! - END FUNCTION TensorProdBasis_Quadrangle1 -END INTERFACE TensorProdBasis_Quadrangle - -INTERFACE OrthogonalBasis_Quadrangle - MODULE PROCEDURE TensorProdBasis_Quadrangle1 -END INTERFACE OrthogonalBasis_Quadrangle + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION InterpolationPoint_Quadrangle2 +END INTERFACE InterpolationPoint_Quadrangle !---------------------------------------------------------------------------- -! +! InterpolationPoint_Quadrangle_@InterpolationPointMethods !---------------------------------------------------------------------------- -INTERFACE TensorProdBasis_Quadrangle_ - MODULE SUBROUTINE TensorProdBasis_Quadrangle1_(p, q, xij, ans, nrow, & - ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, & - beta2, lambda2) +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 - !! highest order in x1 direction + !! order of element in x direction INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - REAL(DFP), INTENT(IN) :: xij(:, :) - !! points of evaluation in xij format + !! 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(:, :) - !! 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 + !! + 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 - !! alpha1 needed when basisType1 "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" + !! Ultraspherical parameter REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" + !! Jacobi parameter REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - END SUBROUTINE TensorProdBasis_Quadrangle1_ -END INTERFACE TensorProdBasis_Quadrangle_ - -INTERFACE OrthogonalBasis_Quadrangle_ - MODULE PROCEDURE TensorProdBasis_Quadrangle1_ -END INTERFACE OrthogonalBasis_Quadrangle_ + !! Ultraspherical parameter + END SUBROUTINE InterpolationPoint_Quadrangle2_ +END INTERFACE InterpolationPoint_Quadrangle_ !---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle +! IJ2VEFC_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- +! date: 2023-07-17 +! summary: Convert interpolation point format from IJ to VEFC -INTERFACE TensorProdBasis_Quadrangle_ - MODULE SUBROUTINE TensorProdBasis_Quadrangle2_(p, q, x, y, ans, nrow, & - ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, beta2, & - lambda2) +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 - !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q - !! highest order in x2 direction - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! points of evaluation in xij format - REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1)) - !! nrow = SIZE(x) * SIZE(y) - !! ncol = (p + 1) * (q + 1) - !! Tensor basis - !! The number of rows corresponds to the - !! total number of points - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written in ans - INTEGER(I4B), INTENT(IN) :: basisType1 - !! Orthogonal polynomial family in x1 direction - INTEGER(I4B), INTENT(IN) :: basisType2 - !! Orthogonal poly family in x2 direction - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! alpha1 needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! beta1 is needed when basisType1 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! alpha2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! beta2 needed when basisType2 is "Jacobi" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! lambda1 is needed when basisType1 is "Ultraspherical" - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! lambda2 is needed when basisType2 is "Ultraspherical" - END SUBROUTINE TensorProdBasis_Quadrangle2_ -END INTERFACE TensorProdBasis_Quadrangle_ - -INTERFACE OrthogonalBasis_Quadrangle_ - MODULE PROCEDURE TensorProdBasis_Quadrangle2_ -END INTERFACE OrthogonalBasis_Quadrangle_ + END SUBROUTINE IJ2VEFC_Quadrangle +END INTERFACE !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! IJ2VEFC_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> 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 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- +! date: 2023-07-17 +! summary: Convert format from IJ to VEFC -INTERFACE VertexBasis_Quadrangle_ - MODULE PURE SUBROUTINE VertexBasis_Quadrangle1_(x, y, ans, nrow, ncol) - REAL(DFP), INTENT(IN) :: x(:), y(:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(x), 4) - !! ans(:,v1) basis function of vertex v1 at all points - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE VertexBasis_Quadrangle1_ -END INTERFACE VertexBasis_Quadrangle_ +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 !---------------------------------------------------------------------------- -! VertexBasis_Quadrangle +! IJ2VEFC_Quadrangle@InterpolationPointMethods !---------------------------------------------------------------------------- !> 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_Quadrangle2(xij) RESULT(ans) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - REAL(DFP) :: ans(SIZE(xij, 2), 4) - !! ans(:,v1) basis function of vertex v1 at all points - END FUNCTION VertexBasis_Quadrangle2 -END INTERFACE VertexBasis_Quadrangle - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- +! date: 2023-07-17 +! summary: Convert format from IJ to VEFC -INTERFACE VertexBasis_Quadrangle_ - MODULE PURE SUBROUTINE VertexBasis_Quadrangle2_(xij, ans, nrow, ncol) - REAL(DFP), INTENT(IN) :: xij(:, :) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(xij, 2), 4) - !! ans(:,v1) basis function of vertex v1 at all points - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE VertexBasis_Quadrangle2_ -END INTERFACE VertexBasis_Quadrangle_ +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 !---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle +! DubinerPolynomial@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on left, right edge of biunit quadrangle +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on biunit domain ! !# Introduction ! -! Evaluate basis functions on left and right edge of biunit quadrangle +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is called while forming dubiner basis on triangle domain ! -! qe1 and qe2 should be greater than or equal to 2 +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+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 - -!---------------------------------------------------------------------------- +! In this way, ans(j,:) denotes the values of all polynomial at jth point ! -!---------------------------------------------------------------------------- +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ -INTERFACE - MODULE PURE 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 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 !---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle +! DubinerPolynomial@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on bottom and top edge of biunit quadrangle +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on biunit domain ! !# Introduction ! -! Evaluate basis functions on bottom and top edge of biunit quadrangle +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is called while forming dubiner basis on triangle domain ! -! 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 - -!---------------------------------------------------------------------------- +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+2). ! -!---------------------------------------------------------------------------- +! In this way, ans(j,:) denotes the values of all polynomial at jth point +! +! Polynomials are returned in following way: +! +!$$ +! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\ +! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\ +! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\ +! \cdots +! P_{order,0} +!$$ +! +! For example for order=3, the polynomials are arranged as: +! +!$$ +! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\ +! P_{1,0}, P_{1,1}, P_{1,2} \\ +! P_{2,0}, P_{2,1} \\ +! P_{3,0} +!$$ -INTERFACE - MODULE PURE 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 +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(x), pe3 + pe4 - 2) + ! 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 HorizontalEdgeBasis_Quadrangle_ -END INTERFACE + END SUBROUTINE Dubiner_Quadrangle1_ +END INTERFACE Dubiner_Quadrangle_ !---------------------------------------------------------------------------- -! CellBasis_Quadrangle +! DubinerPolynomial@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis in the cell of biunit quadrangle +! date: 27 Oct 2022 +! summary: Dubiner (1991) polynomials on biunit domain ! !# Introduction ! -! Evaluate basis functions in the cell of biunit quadrangle +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is same as Dubiner_Quadrangle1 +! The only difference is that xij are given by outerproduct of x and y. +! This function calls `Dubiner_Quadrangle1`. -INTERFACE - MODULE PURE FUNCTION 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 +INTERFACE Dubiner_Quadrangle + MODULE PURE FUNCTION Dubiner_Quadrangle2(order, x, y) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial space + REAL(DFP), INTENT(IN) :: x(:) + !! x coordinate on line + REAL(DFP), INTENT(IN) :: y(:) + !! y coordinate on line + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (order + 1) * (order + 2) / 2) + !! shape functions + !! ans(:, j), jth shape functions at all points + !! ans(j, :), all shape functions at jth point + END FUNCTION Dubiner_Quadrangle2 +END INTERFACE Dubiner_Quadrangle !---------------------------------------------------------------------------- -! +! DubinerPolynomial@DubinerMethods !---------------------------------------------------------------------------- -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 +!> 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), (pb - 1) * (qb - 1)) + ! 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 CellBasis_Quadrangle_ -END INTERFACE + END SUBROUTINE Dubiner_Quadrangle2_ +END INTERFACE Dubiner_Quadrangle_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! DubinerGradient@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! summary: Dubiner (1991) polynomials on biunit domain ! !# 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. +! Forms Dubiner basis on biunit quadrangle domain. +! This routine is called while forming dubiner basis on triangle domain ! -! 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. +! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points) +! N = 0.5*(order+1)*(order+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 - -!---------------------------------------------------------------------------- +! In this way, ans(j,:) denotes the values of all polynomial at jth point ! -!---------------------------------------------------------------------------- - -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 +! 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 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_ + !! 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 !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! DubinerGradient@DubinerMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 27 Oct 2022 -! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! summary: Dubiner (1991) polynomials on biunit domain ! !# Introduction ! -! This function is identical to `HeirarchicalBasis_Quadrangle1` -! with qe1=qe2=qb=q, and pe3=pe4=pb=p. +! 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 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 +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 of evaluation in xij format - REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1)) - END FUNCTION HeirarchicalBasis_Quadrangle2 -END INTERFACE HeirarchicalBasis_Quadrangle + !! 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@TensorProdMethods !---------------------------------------------------------------------------- -INTERFACE HeirarchicalBasis_Quadrangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle2_(p, q, xij, ans, & - nrow, ncol) +!> 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 - !! order of interpolation inside the quadrangle in x1 direction + !! highest order in x1 direction INTEGER(I4B), INTENT(IN) :: q - !! order of interpolation inside the quadrangle in x2 direction + !! 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 - END SUBROUTINE HeirarchicalBasis_Quadrangle2_ -END INTERFACE HeirarchicalBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- + 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 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 OrthogonalBasis_Quadrangle + MODULE PROCEDURE TensorProdBasis_Quadrangle1 +END INTERFACE OrthogonalBasis_Quadrangle !---------------------------------------------------------------------------- -! +! TensorProdBasis_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- -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 +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 - 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) + !! nrow = SIZE(xij, 2) + !! ncol = (p + 1) * (q + 1) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE HeirarchicalBasis_Quadrangle3_ -END INTERFACE HeirarchicalBasis_Quadrangle_ + !! 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_ !---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle +! TensorProdBasis_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- !> 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 - -!---------------------------------------------------------------------------- +! 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 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 +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 - !! Lobatto !! 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) :: 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_ + 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 + +!---------------------------------------------------------------------------- +! TensorProdBasis_Quadrangle@TensorProdMethods +!---------------------------------------------------------------------------- + +INTERFACE TensorProdBasis_Quadrangle_ + MODULE SUBROUTINE TensorProdBasis_Quadrangle2_(p, q, x, y, ans, nrow, & + ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2) + INTEGER(I4B), INTENT(IN) :: p + !! highest order in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! highest order in x2 direction + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! points of evaluation in xij format + REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1)) + !! nrow = SIZE(x) * SIZE(y) + !! ncol = (p + 1) * (q + 1) + !! Tensor basis + !! The number of rows corresponds to the + !! total number of points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + INTEGER(I4B), INTENT(IN) :: basisType1 + !! Orthogonal polynomial family in x1 direction + INTEGER(I4B), INTENT(IN) :: basisType2 + !! Orthogonal poly family in x2 direction + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! alpha1 needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! beta1 is needed when basisType1 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! alpha2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! beta2 needed when basisType2 is "Jacobi" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! lambda1 is needed when basisType1 is "Ultraspherical" + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! lambda2 is needed when basisType2 is "Ultraspherical" + END SUBROUTINE TensorProdBasis_Quadrangle2_ +END INTERFACE TensorProdBasis_Quadrangle_ + +INTERFACE OrthogonalBasis_Quadrangle_ + MODULE PROCEDURE TensorProdBasis_Quadrangle2_ +END INTERFACE OrthogonalBasis_Quadrangle_ !---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-07-04 -! summary: Evaluate all Lagrange polynomials of order n at several points +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle -INTERFACE LagrangeEvalAll_Quadrangle - MODULE FUNCTION LagrangeEvalAll_Quadrangle2(order, x, xij, coeff, & - firstCall, basisType, alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! Order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! Point of evaluation - !! x(1, :) is x coord - !! x(2, :) is y coord - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! Interpolation points - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! Coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials *Default - !! Jacobi=Dubiner - !! Heirarchical - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x - END FUNCTION LagrangeEvalAll_Quadrangle2 -END INTERFACE LagrangeEvalAll_Quadrangle +INTERFACE 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@HierarchicalMethods !---------------------------------------------------------------------------- -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 +INTERFACE VertexBasis_Quadrangle_ + MODULE PURE SUBROUTINE VertexBasis_Quadrangle1_(x, y, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: x(:), y(:) + !! point of evaluation REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(x, 2), SIZE(xij, 2)) - !! Value of n+1 Lagrange polynomials at point x + !! ans(SIZE(x), 4) + !! ans(:,v1) basis function of vertex v1 at all points 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_ + END SUBROUTINE VertexBasis_Quadrangle1_ +END INTERFACE VertexBasis_Quadrangle_ !---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points on reference quadrangle +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit 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 +INTERFACE VertexBasis_Quadrangle + MODULE PURE FUNCTION VertexBasis_Quadrangle2(xij) RESULT(ans) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + REAL(DFP) :: ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + END FUNCTION VertexBasis_Quadrangle2 +END INTERFACE VertexBasis_Quadrangle !---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle +! VertexBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- -INTERFACE QuadraturePoint_Quadrangle - MODULE FUNCTION QuadraturePoint_Quadrangle2(p, q, quadType1, quadType2, & - refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) & +INTERFACE VertexBasis_Quadrangle_ + MODULE PURE SUBROUTINE VertexBasis_Quadrangle2_(xij, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), 4) + !! ans(:,v1) basis function of vertex v1 at all points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE VertexBasis_Quadrangle2_ +END INTERFACE VertexBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle@HierarchicalMethods +!---------------------------------------------------------------------------- + +!> 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) :: 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 + 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 !---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle +! VerticalEdgeBasis_Quadrangle@HierarchicalMethods +!---------------------------------------------------------------------------- + +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 + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-07-19 -! summary: Returns quadrature points on reference quadrangle +! 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 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 +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 !---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle +! !---------------------------------------------------------------------------- -INTERFACE QuadraturePoint_Quadrangle - MODULE FUNCTION QuadraturePoint_Quadrangle4(nipsx, nipsy, quadType1, & - quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, & - lambda2) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: nipsx(1) - !! order of integrand in x direction - INTEGER(I4B), INTENT(IN) :: nipsy(1) - !! order of integrand in y direction - INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 - !! interpolation point type in x direction - !! Equidistance ! GaussLegendre ! GaussLegendreLobatto - !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 - !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft - !! GaussChebyshev1RadauRight ! GaussUltraspherical - !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft - !! GaussUltrasphericalRadauRight ! GaussJacobi - !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight - CHARACTER(*), INTENT(IN) :: refQuadrangle - !! Reference quadrangle ! UNIT ! BIUNIT - REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) - !! four vertices of quadrangle in xij format - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 - !! Ultraspherical parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 - !! Jacobi parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 - !! Ultraspherical parameter - REAL(DFP), ALLOCATABLE :: ans(:, :) - !! interpolation points in xij format - END FUNCTION QuadraturePoint_Quadrangle4 -END INTERFACE QuadraturePoint_Quadrangle +INTERFACE + 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 !---------------------------------------------------------------------------- +! CellBasis_Quadrangle@HierarchicalMethods +!---------------------------------------------------------------------------- + +!> 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@HierarchicalMethods !---------------------------------------------------------------------------- -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 +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(:, :) - !! interpolation points in xij format + !! ans(SIZE(x), (pb - 1) * (qb - 1)) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written in ans - END SUBROUTINE QuadraturePoint_Quadrangle1_ -END INTERFACE QuadraturePoint_Quadrangle_ + END SUBROUTINE CellBasis_Quadrangle_ +END INTERFACE !---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle +! HeirarchicalBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-06-23 -! summary: Evaluate Lagrange polynomials of n at several points +! date: 27 Oct 2022 +! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle +! +!# Introduction +! +! This function returns the modal basis on orthogonal polynomial +! The modal function in 1D is given by scaled Lobatto polynomial. +! These modal functions are orthogonal with respect to H1 seminorm. +! However, these modal function are not orthogonal withrespect to L2 norm. +! +! Bubble function in 1D is proportional to Jacobi polynomial with +! alpha=beta=1. Equivalently, these bubble functions are proportional to +! Ultraspherical polynomials with lambda = 3/2. +! -INTERFACE LagrangeGradientEvalAll_Quadrangle - MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1(order, x, xij, coeff, & - firstCall, basisType, alpha, beta, lambda) RESULT(ans) - INTEGER(I4B), INTENT(IN) :: order - !! order of Lagrange polynomials - REAL(DFP), INTENT(IN) :: x(:, :) - !! point of evaluation in xij format - REAL(DFP), INTENT(INOUT) :: xij(:, :) - !! interpolation points - !! xij should be present when firstCall is true. - !! It is used for computing the coeff - !! If coeff is absent then xij should be present - REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2)) - !! coefficient of Lagrange polynomials - LOGICAL(LGT), OPTIONAL :: firstCall - !! If firstCall is true, then coeff will be made - !! If firstCall is False, then coeff will be used - !! Default value of firstCall is True - INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomial - !! Jacobi - !! Legendre - !! Chebyshev - !! Lobatto - !! UnscaledLobatto - REAL(DFP), OPTIONAL, INTENT(IN) :: alpha - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: beta - !! Jacobi polynomial parameter - REAL(DFP), OPTIONAL, INTENT(IN) :: lambda - !! Ultraspherical parameter - REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 2) - !! Value of gradient of nth order Lagrange polynomials at point x - !! The first index denotes point of evaluation - !! the second index denotes Lagrange polynomial number - !! The third index denotes the spatial dimension in which gradient is - !! computed - END FUNCTION LagrangeGradientEvalAll_Quadrangle1 -END INTERFACE LagrangeGradientEvalAll_Quadrangle +INTERFACE 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@HierarchicalMethods +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Quadrangle_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle1_( & + pb, qb, pe3, pe4, qe1, qe2, xij, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2), & + !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Quadrangle1_ +END INTERFACE HeirarchicalBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle@HierarchicalMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! 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 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- -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_ +INTERFACE HeirarchicalBasis_Quadrangle_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle2_(p, q, xij, ans, & + nrow, ncol) + INTEGER(I4B), INTENT(IN) :: p + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: q + !! order of interpolation inside the quadrangle in x2 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2) + !! ncol = (p + 1) * (q + 1)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Quadrangle2_ +END INTERFACE HeirarchicalBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle@HierarchicalMethods +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Quadrangle + MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle3( & + pb, qb, pe3, pe4, qe1, qe2, xij, pe3Orient, pe4Orient, qe1Orient, & + qe2Orient, faceOrient) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: pe3Orient + !! orientation of edge 1 + INTEGER(I4B), INTENT(IN) :: pe4Orient + !! orientation of edge 2 + INTEGER(I4B), INTENT(IN) :: qe1Orient + !! orientation of edge 3 + INTEGER(I4B), INTENT(IN) :: qe2Orient + !! orientation of edge 4 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! orientation of face + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! nrow = SIZE(xij, 2) + !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + END FUNCTION HeirarchicalBasis_Quadrangle3 +END INTERFACE HeirarchicalBasis_Quadrangle + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle@HierarchicalMethods +!---------------------------------------------------------------------------- + +INTERFACE HeirarchicalBasis_Quadrangle_ + MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle3_( & + pb, qb, pe3, pe4, qe1, qe2, xij, pe3Orient, pe4Orient, qe1Orient, & + qe2Orient, faceOrient, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: pb + !! order of interpolation inside the quadrangle in x1 direction + INTEGER(I4B), INTENT(IN) :: qb + !! order of interpolation inside the quadrangle in x2 direction + INTEGER(I4B), INTENT(IN) :: pe3 + !! order of interpolation on edge e3 (bottom) in x1 direction + INTEGER(I4B), INTENT(IN) :: pe4 + !! order of interpolation on edge e4 (top) in x1 direction + INTEGER(I4B), INTENT(IN) :: qe1 + !! order of interpolation on edge e1 (left) in y1 direction + INTEGER(I4B), INTENT(IN) :: qe2 + !! order of interpolation on edge e2 (right) in y1 direction + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points of evaluation in xij format + INTEGER(I4B), INTENT(IN) :: pe3Orient + !! orientation of edge 1 + INTEGER(I4B), INTENT(IN) :: pe4Orient + !! orientation of edge 2 + INTEGER(I4B), INTENT(IN) :: qe1Orient + !! orientation of edge 3 + INTEGER(I4B), INTENT(IN) :: qe2Orient + !! orientation of edge 4 + INTEGER(I4B), INTENT(IN) :: faceOrient(:) + !! orientation of face + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! nrow = SIZE(xij, 2), & + !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE HeirarchicalBasis_Quadrangle3_ +END INTERFACE HeirarchicalBasis_Quadrangle_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2398,7 +2275,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle1 END INTERFACE HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Quadrangle_ @@ -2427,7 +2304,7 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle1_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2447,7 +2324,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle2 END INTERFACE HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Quadrangle_ @@ -2468,7 +2345,7 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- -! +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2508,7 +2385,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle3 END INTERFACE HeirarchicalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle +! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Quadrangle_ @@ -2548,7 +2425,7 @@ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle3_ END INTERFACE HeirarchicalBasisGradient_Quadrangle_ !---------------------------------------------------------------------------- -! TensorProdBasisGradient_Quadrangle +! TensorProdBasisGradient_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -2595,7 +2472,7 @@ END FUNCTION TensorProdBasisGradient_Quadrangle1 END INTERFACE OrthogonalBasisGradient_Quadrangle !---------------------------------------------------------------------------- -! +! TensorProdBasisGradient_Quadrangle@TensorProdMethods !---------------------------------------------------------------------------- INTERFACE TensorProdBasisGradient_Quadrangle_ @@ -2641,4 +2518,223 @@ END SUBROUTINE TensorProdBasisGradient_Quadrangle1_ MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ END INTERFACE OrthogonalBasisGradient_Quadrangle_ +!---------------------------------------------------------------------------- +! QuadratureNumber_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE FUNCTION QuadratureNumber_Quadrangle(p, q, quadType1, & + quadType2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p, q + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 + INTEGER(I4B) :: ans(2) + END FUNCTION QuadratureNumber_Quadrangle +END INTERFACE + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points on reference quadrangle +! +!# Introduction +! +! quadType can take the following values: +! +! GaussLegendre +! GaussLegendreLobatto +! GaussLegendreRadauLeft +! GaussLegendreRadauRight +! GaussChebyshev1 +! GaussChebyshev1Lobatto +! GaussChebyshev1RadauLeft +! GaussChebyshev1RadauRight +! GaussUltraspherical +! GaussUltrasphericalLobatto +! GaussUltrasphericalRadauLeft +! GaussUltrasphericalRadauRight +! GaussJacobi +! GaussJacobiLobatto +! GaussJacobiRadauLeft +! GaussJacobiRadauRight + +INTERFACE QuadraturePoint_Quadrangle + MODULE FUNCTION QuadraturePoint_Quadrangle1(order, quadType, & + refQuadrangle, xij, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! Order of integrand in x and y direction + INTEGER(I4B), INTENT(IN) :: quadType + !! Quadrature point type + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Quadrangle1 +END INTERFACE QuadraturePoint_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Quadrangle + MODULE FUNCTION QuadraturePoint_Quadrangle2(p, q, quadType1, quadType2, & + refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) & + RESULT(ans) + INTEGER(I4B), INTENT(IN) :: p + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: q + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 + !! quadrature point type in x direction, see above + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Quadrangle2 +END INTERFACE QuadraturePoint_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-07-19 +! summary: Returns quadrature points on reference quadrangle + +INTERFACE QuadraturePoint_Quadrangle + MODULE FUNCTION QuadraturePoint_Quadrangle3(nips, quadType, & + refQuadrangle, xij, alpha, beta, lambda) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nips(1) + !! number of integration points in x and y direction + INTEGER(I4B), INTENT(IN) :: quadType + !! interpolation point type, see above + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Quadrangle3 +END INTERFACE QuadraturePoint_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Quadrangle + MODULE FUNCTION QuadraturePoint_Quadrangle4(nipsx, nipsy, quadType1, & + quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, & + lambda2) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 + !! interpolation point type in x direction + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), ALLOCATABLE :: ans(:, :) + !! interpolation points in xij format + END FUNCTION QuadraturePoint_Quadrangle4 +END INTERFACE QuadraturePoint_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle@QuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE QuadraturePoint_Quadrangle_ + MODULE SUBROUTINE QuadraturePoint_Quadrangle1_( & + nipsx, nipsy, quadType1, quadType2, refQuadrangle, xij, alpha1, beta1, & + lambda1, alpha2, beta2, lambda2, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! order of integrand in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! order of integrand in y direction + INTEGER(I4B), INTENT(IN) :: quadType1, quadType2 + !! interpolation point type in x direction + !! Equidistance ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1 + !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft + !! GaussChebyshev1RadauRight ! GaussUltraspherical + !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft + !! GaussUltrasphericalRadauRight ! GaussJacobi + !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight + CHARACTER(*), INTENT(IN) :: refQuadrangle + !! Reference quadrangle ! UNIT ! BIUNIT + REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :) + !! four vertices of quadrangle in xij format + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta1 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1 + !! Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta2 + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2 + !! Ultraspherical parameter + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! interpolation points in xij format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written in ans + END SUBROUTINE QuadraturePoint_Quadrangle1_ +END INTERFACE QuadraturePoint_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + END MODULE QuadrangleInterpolationUtility diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90 similarity index 91% rename from src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 rename to src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90 index 4756e86b4..fa8360e5f 100644 --- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 +++ b/src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90 @@ -21,7 +21,6 @@ MODULE ReferenceQuadrangle_Method USE GlobalData, ONLY: DFP, I4B, LGT - USE BaseType, ONLY: ReferenceQuadrangle_, ReferenceElement_, & ReferenceTopology_ @@ -61,13 +60,13 @@ MODULE ReferenceQuadrangle_Method INTEGER(I4B), PARAMETER :: MaxOrder_Quadrangle = 2_I4B #endif -INTEGER(I4B), PUBLIC, PARAMETER :: HelpFaceData_Quadrangle(3, 4) = & - & RESHAPE([ & - & 2, 3, 4, & - & 3, 4, 1, & - & 4, 1, 2, & - & 1, 2, 3 & - & ], [3, 4]) +INTEGER(I4B), PUBLIC, PARAMETER :: HelpFaceData_Quadrangle(3, 4) = & + RESHAPE([ & + 2, 3, 4, & + 3, 4, 1, & + 4, 1, 2, & + 1, 2, 3 & + ], [3, 4]) #ifdef QUADRANGLE_EDGE_CON_DEFAULT_OPT_1 INTEGER(I4B), PARAMETER :: DEFAULT_OPT_QUADRANGLE_EDGE_CON = 1_I4B @@ -469,9 +468,9 @@ END SUBROUTINE FaceShapeMetaData_Quadrangle ! date: 2024-04-19 ! summary: Returns the element type of each face -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, & - opt, tFaceNodes) +INTERFACE GetFaceElemType_Quadrangle + MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle1(elemType, faceElemType, & + opt, tFaceNodes) INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType !! name of element INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) @@ -482,7 +481,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - END SUBROUTINE GetFaceElemType_Quadrangle -END INTERFACE + END SUBROUTINE GetFaceElemType_Quadrangle1 +END INTERFACE GetFaceElemType_Quadrangle + +!---------------------------------------------------------------------------- +! GetFaceElemType_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Quadrangle + MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle2( & + elemType, localFaceNumber, faceElemType, opt, tFaceNodes) + INTEGER(I4B), INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Element names of faces + INTEGER(I4B), INTENT(INOUT) :: tFaceNodes + !! Total number of nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Quadrangle2 +END INTERFACE GetFaceElemType_Quadrangle END MODULE ReferenceQuadrangle_Method diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 index 2d288dd6d..103ff5612 100755 --- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 +++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 @@ -27,7 +27,9 @@ MODULE QuadraturePoint_Method PRIVATE +PUBLIC :: Set PUBLIC :: Initiate +PUBLIC :: InitiateFacetQuadrature PUBLIC :: Copy PUBLIC :: ASSIGNMENT(=) PUBLIC :: QuadraturePoint @@ -45,6 +47,7 @@ MODULE QuadraturePoint_Method ! PUBLIC :: QuadraturePoint_MdEncode PUBLIC :: QuadraturePointIdToName PUBLIC :: QuadraturePoint_ToChar +PUBLIC :: QuadraturePoint_ToInteger PUBLIC :: QuadraturePointNameToId PUBLIC :: MdEncode @@ -56,12 +59,12 @@ MODULE QuadraturePoint_Method ! date: 2023-08-06 ! summary: Quadrature point name to quadrature point id -INTERFACE +INTERFACE QuadraturePoint_ToInteger MODULE FUNCTION QuadraturePointNameToId(name) RESULT(ans) CHARACTER(*), INTENT(IN) :: name INTEGER(I4B) :: ans END FUNCTION QuadraturePointNameToId -END INTERFACE +END INTERFACE QuadraturePoint_ToInteger !---------------------------------------------------------------------------- ! QuadratuePointIdToName@ConstructorMethods @@ -314,6 +317,7 @@ MODULE SUBROUTINE obj_Initiate6(obj, refElem, nips, quadratureType, & !! Ultraspherical parameter END SUBROUTINE obj_Initiate6 END INTERFACE Initiate + !---------------------------------------------------------------------------- ! Initiate@ConstructorMethods !---------------------------------------------------------------------------- @@ -324,8 +328,10 @@ END SUBROUTINE obj_Initiate6 INTERFACE Initiate MODULE SUBROUTINE obj_Initiate7(obj, refElem, p, q, r, quadratureType1, & - quadratureType2, quadratureType3, alpha1, beta1, lambda1, alpha2, & - beta2, lambda2, alpha3, beta3, lambda3) + quadratureType2, quadratureType3, & + alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, & + alpha3, beta3, lambda3) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -364,8 +370,10 @@ END SUBROUTINE obj_Initiate7 INTERFACE Initiate MODULE SUBROUTINE obj_Initiate8(obj, refElem, nipsx, nipsy, nipsz, & - quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & - lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3) + quadratureType1, quadratureType2, & + quadratureType3, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, & + alpha3, beta3, lambda3) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension CLASS(ReferenceElement_), INTENT(IN) :: refElem @@ -483,13 +491,15 @@ END SUBROUTINE obj_Initiate10 END INTERFACE Initiate !---------------------------------------------------------------------------- -! +! Initiate@ConstructorMethods !---------------------------------------------------------------------------- INTERFACE Initiate MODULE SUBROUTINE obj_Initiate11(obj, elemType, domainName, p, q, r, & - quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & - lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, xij) + 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 @@ -527,8 +537,10 @@ END SUBROUTINE obj_Initiate11 INTERFACE Initiate MODULE SUBROUTINE obj_Initiate12(obj, elemType, domainName, nipsx, nipsy, & - nipsz, quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, & - lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, xij) + nipsz, quadratureType1, quadratureType2, & + quadratureType3, alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, & + alpha3, beta3, lambda3, xij) TYPE(QuadraturePoint_), INTENT(INOUT) :: obj !! Total number of xidimension INTEGER(I4B), INTENT(IN) :: elemType @@ -631,12 +643,42 @@ END FUNCTION obj_Size ! summary: This routine returns total number of quadrature points INTERFACE GetTotalQuadraturepoints - MODULE PURE FUNCTION obj_GetTotalQuadraturePoints(obj) RESULT(ans) + MODULE PURE FUNCTION obj_GetTotalQuadraturePoints1(obj) RESULT(ans) TYPE(QuadraturePoint_), INTENT(IN) :: obj INTEGER(I4B) :: ans - END FUNCTION obj_GetTotalQuadraturePoints + END FUNCTION obj_GetTotalQuadraturePoints1 END INTERFACE GetTotalQuadraturepoints +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE GetTotalQuadraturePoints + MODULE FUNCTION obj_GetTotalQuadraturePoints2(elemType, p, q, r, & + quadratureType1, & + quadratureType2, & + quadratureType3) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: elemtype + !! Reference-element + INTEGER(I4B), INTENT(IN) :: p + !! order of integrand in x + INTEGER(I4B), INTENT(IN) :: q + !! order of integrand in y + INTEGER(I4B), INTENT(IN) :: r + !! order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadratureType1 + !! Type of quadrature points: GaussLegendre, GaussLegendreLobatto + !! GaussLegendreRadau, GaussLegendreRadauLeft, GaussLegendreRadauRight + !! GaussChebyshev, GaussChebyshevLobatto, GaussChebyshevRadau + !! GaussChebyshevRadauLeft, GaussChebyshevRadauRight + INTEGER(I4B), INTENT(IN) :: quadratureType2 + !! Type of quadrature points + INTEGER(I4B), INTENT(IN) :: quadratureType3 + !! Type of quadrature points + INTEGER(I4B) :: ans + END FUNCTION obj_GetTotalQuadraturePoints2 +END INTERFACE GetTotalQuadraturePoints + !---------------------------------------------------------------------------- ! GetQuadraturePoint@GetMethods !---------------------------------------------------------------------------- @@ -997,6 +1039,223 @@ END FUNCTION obj_MdEncode ! END FUNCTION getGaussLegendreRadauRightQP3 ! END INTERFACE GaussLegendreRadauRightQuadrature +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature@FacetQuadratureMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-05-21 +! summary: This routine Initiates the quadrature points +! +!# Introduction +! +! This routine is used to initiate the quadrature points from order of +! of integrand. +! This subroutine does not require formation of reference element. +! This routine calls obj_Initiate11 method. + +INTERFACE InitiateFacetQuadrature + MODULE SUBROUTINE obj_InitiateFacetQuadrature1(obj, facetQuad, & + localFaceNumber, elemType, & + domainName, order, & + quadratureType, & + alpha, beta, lambda, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Quadrature point in the cell + TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad + !! Quadrature point on the local face + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(IN) :: elemType + !! element name + CHARACTER(*), INTENT(IN) :: domainName + !! domain name for reference element + !! unit or biunit + INTEGER(I4B), INTENT(IN) :: order + !! order of integrand + INTEGER(I4B), INTENT(IN) :: quadratureType + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(IN) :: xij(:, :) + END SUBROUTINE obj_InitiateFacetQuadrature1 +END INTERFACE InitiateFacetQuadrature + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature@FacetQuadratureMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-05-21 +! summary: This routine Initiates the quadrature points + +INTERFACE InitiateFacetQuadrature + MODULE SUBROUTINE obj_InitiateFacetQuadrature2(obj, facetQuad, & + localFaceNumber, elemType, & + domainName, nips, & + quadratureType, alpha, & + beta, lambda, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Quadrature point in the cell + TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad + !! Quadrature point on the local facet + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(IN) :: elemType + !! element name + CHARACTER(*), INTENT(IN) :: domainName + !! domain name, reference element + !! unit or biunit + INTEGER(I4B), INTENT(IN) :: nips(1) + !! Number of integration points + !! in the case of quadrangle element nips(1) denotes the + !! number of quadrature points in the x and y direction + !! so the total number of quadrature points are nips(1)*nips(1) + INTEGER(I4B), INTENT(IN) :: quadratureType + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: beta + !! Jacobi parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: lambda + !! Ultraspherical parameter + REAL(DFP), INTENT(IN) :: xij(:, :) + END SUBROUTINE obj_InitiateFacetQuadrature2 +END INTERFACE InitiateFacetQuadrature + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature@FacetQuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE InitiateFacetQuadrature + MODULE SUBROUTINE obj_InitiateFacetQuadrature3(obj, facetQuad, & + localFaceNumber, elemType, & + domainName, p, q, r, & + quadratureType1, & + quadratureType2, & + quadratureType3, & + alpha1, beta1, lambda1, & + alpha2, beta2, lambda2, & + alpha3, beta3, lambda3, & + xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Quadrature point in the cell + TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad + !! Quadrature point on the local face element + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local facet number + INTEGER(I4B), INTENT(IN) :: elemtype + !! Reference-element + CHARACTER(*), INTENT(IN) :: domainName + !! domain name + INTEGER(I4B), INTENT(IN) :: p + !! order of integrand in x + INTEGER(I4B), INTENT(IN) :: q + !! order of integrand in y + INTEGER(I4B), INTENT(IN) :: r + !! order of integrand in z direction + INTEGER(I4B), INTENT(IN) :: quadratureType1 + !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto + !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight + !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau + !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight + INTEGER(I4B), INTENT(IN) :: quadratureType2 + !! Type of quadrature points + INTEGER(I4B), INTENT(IN) :: quadratureType3 + !! Type of quadrature points + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi parameter and Ultraspherical parameters + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi parameter and Ultraspherical parameters + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi parameter and Ultraspherical parameters + REAL(DFP), INTENT(IN) :: xij(:, :) + END SUBROUTINE obj_InitiateFacetQuadrature3 +END INTERFACE InitiateFacetQuadrature + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature@FacetQuadratureMethods +!---------------------------------------------------------------------------- + +INTERFACE InitiateFacetQuadrature + MODULE SUBROUTINE obj_InitiateFacetQuadrature4(obj, facetQuad, & + localFaceNumber, & + elemType, domainName, & + nipsx, nipsy, nipsz, & + quadratureType1, & + quadratureType2, & + quadratureType3, & + alpha1, beta1, & + lambda1, & + alpha2, beta2, lambda2, & + alpha3, beta3, lambda3, xij) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + !! Total number of xidimension + TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad + !! Quadrature point on the local face element + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local facet number + INTEGER(I4B), INTENT(IN) :: elemType + !! element type + CHARACTER(*), INTENT(IN) :: domainName + !! domain name + INTEGER(I4B), INTENT(IN) :: nipsx(1) + !! number of integration points in x direction + INTEGER(I4B), INTENT(IN) :: nipsy(1) + !! number of integration points in y direction + INTEGER(I4B), INTENT(IN) :: nipsz(1) + !! number of integration points in z direction + INTEGER(I4B), INTENT(IN) :: quadratureType1 + !! Type of quadrature points + !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau + !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev + !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft + !! GaussChebyshevRadauRight + INTEGER(I4B), INTENT(IN) :: quadratureType2 + !! Type of quadrature points + INTEGER(I4B), INTENT(IN) :: quadratureType3 + !! Type of quadrature points + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3 + !! Jacobi parameter and Ultraspherical parameter + REAL(DFP), INTENT(IN) :: xij(:, :) + !! coordinates of reference element + END SUBROUTINE obj_InitiateFacetQuadrature4 +END INTERFACE InitiateFacetQuadrature + +!---------------------------------------------------------------------------- +! Set@SetMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-29 +! summary: This routine sets the quadrature points +! We do not allocate anything here + +INTERFACE Set + MODULE PURE SUBROUTINE obj_Set1(obj, points) + TYPE(QuadraturePoint_), INTENT(INOUT) :: obj + REAL(DFP), INTENT(IN) :: points(:, :) + !! points contains the quadrature points and weights + !! points( :, ipoint ) contains quadrature points and weights of ipoint + !! quadrature point. The last row contains the weight. The rest of the + !! rows contains the coordinates of quadrature. + END SUBROUTINE obj_Set1 +END INTERFACE Set + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/Random/src/Random_Method.F90 b/src/modules/Random/src/Random_Method.F90 index c1bc307e0..7c45cc0c7 100644 --- a/src/modules/Random/src/Random_Method.F90 +++ b/src/modules/Random/src/Random_Method.F90 @@ -21,6 +21,16 @@ MODULE Random_Method IMPLICIT NONE PRIVATE +PUBLIC :: Initiate +PUBLIC :: RandomValue +PUBLIC :: SaveRandom +PUBLIC :: uniformRandom +PUBLIC :: rvec_uniform_01 +PUBLIC :: rvec_uniform_ab +PUBLIC :: rvec_uniform_unit +PUBLIC :: rvec_normal_01 +PUBLIC :: r8_uniform_01 + !---------------------------------------------------------------------------- ! Initiate@Constructor !---------------------------------------------------------------------------- @@ -35,8 +45,6 @@ END SUBROUTINE initRandom MODULE PROCEDURE initRandom END INTERFACE Initiate -PUBLIC :: Initiate - !---------------------------------------------------------------------------- ! getRandom !---------------------------------------------------------------------------- @@ -53,8 +61,6 @@ END FUNCTION getRandom MODULE PROCEDURE getRandom END INTERFACE RandomValue -PUBLIC :: RandomValue - !---------------------------------------------------------------------------- ! SaveRandom !---------------------------------------------------------------------------- @@ -65,8 +71,6 @@ MODULE SUBROUTINE SaveRandom(obj) END SUBROUTINE SaveRandom END INTERFACE -PUBLIC :: SaveRandom - !---------------------------------------------------------------------------- ! UniformRandom !---------------------------------------------------------------------------- @@ -79,8 +83,6 @@ MODULE FUNCTION uniformRandom(obj, From, To) RESULT(Ans) END FUNCTION uniformRandom END INTERFACE -PUBLIC :: uniformRandom - INTERFACE RandomValue MODULE PROCEDURE uniformRandom END INTERFACE RandomValue @@ -175,8 +177,6 @@ MODULE PURE FUNCTION rvec_uniform_01(n, seed) RESULT(r) END FUNCTION rvec_uniform_01 END INTERFACE -PUBLIC :: rvec_uniform_01 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -195,8 +195,6 @@ MODULE PURE FUNCTION rvec_uniform_ab(n, a, b, seed) RESULT(r) END FUNCTION rvec_uniform_ab END INTERFACE -PUBLIC :: rvec_uniform_ab - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -213,8 +211,6 @@ MODULE PURE FUNCTION rvec_uniform_unit(m, seed) RESULT(w) END FUNCTION rvec_uniform_unit END INTERFACE -PUBLIC :: rvec_uniform_unit - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -281,8 +277,6 @@ MODULE PURE FUNCTION rvec_normal_01(n, seed) RESULT(x) END FUNCTION rvec_normal_01 END INTERFACE -PUBLIC :: rvec_normal_01 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -329,8 +323,6 @@ MODULE PURE FUNCTION r8_uniform_01(seed) RESULT(ans) END FUNCTION r8_uniform_01 END INTERFACE -PUBLIC :: r8_uniform_01 - !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90 index ca9504944..eb434cf46 100644 --- a/src/modules/STForceVector/src/STForceVector_Method.F90 +++ b/src/modules/STForceVector/src/STForceVector_Method.F90 @@ -16,12 +16,14 @@ ! MODULE STForceVector_Method -USE BaseType -USE GlobalData +USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_ +USE BaseType, ONLY: FEVariableScalar_, FEVariableVector_, FEVariableMatrix_ +USE GlobalData, ONLY: I4B, DFP, LGT IMPLICIT NONE PRIVATE PUBLIC :: STForceVector +PUBLIC :: STForceVector_ !---------------------------------------------------------------------------- ! STForceVector @@ -32,16 +34,58 @@ MODULE STForceVector_Method ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_1(test) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) + MODULE PURE FUNCTION obj_STForceVector1(test) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_1 + END FUNCTION obj_STForceVector1 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_1 + MODULE PROCEDURE obj_STForceVector1 END INTERFACE STForceVector +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_1(test, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_1 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_1 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_22(testSpace, testTime, ans, & + nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: testSpace + CLASS(ElemshapeData_), INTENT(IN) :: testTime + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_22 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_22 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -51,137 +95,320 @@ END FUNCTION STForceVector_1 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_2(test, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableScalar_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector2(test, c, crank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_2 + END FUNCTION obj_STForceVector2 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_2 + MODULE PROCEDURE obj_STForceVector2 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_2(test, c, crank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_2 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_2 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_23( & + testSpace, testTime, c, crank, ans, nrow, ncol) + CLASS(ElemshapeData_), INTENT(IN) :: testSpace + CLASS(ElemshapeData_), INTENT(IN) :: testTime + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_23 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_23 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_3(test, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableVector_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector3(test, c, crank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_3 + END FUNCTION obj_STForceVector3 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_3 + MODULE PROCEDURE obj_STForceVector3 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_3( & + test, c, crank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE obj_STForceVector_3 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_3 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_24( & + testSpace, testTime, c, crank, ans, & + dim1, dim2, dim3) + CLASS(ElemshapeData_), INTENT(IN) :: testSpace + CLASS(ElemshapeData_), INTENT(IN) :: testTime + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE obj_STForceVector_24 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_24 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_4(test, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableMatrix_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector4(test, c, crank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_4 + END FUNCTION obj_STForceVector4 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_4 + MODULE PROCEDURE obj_STForceVector4 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_4( & + test, c, crank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE obj_STForceVector_4 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_4 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_5(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector5(test, c1, c1rank, c2, c2rank) & + RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_5 + END FUNCTION obj_STForceVector5 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_5 + MODULE PROCEDURE obj_STForceVector5 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_5( & + test, c1, c1rank, c2, c2rank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_5 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_5 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_6(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector6(test, c1, c1rank, c2, c2rank) & + RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_6 + END FUNCTION obj_STForceVector6 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_6 + MODULE PROCEDURE obj_STForceVector6 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_6( & + test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE obj_STForceVector_6 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_6 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_7(test, c1, c1rank, c2, c2rank) & - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector7(test, c1, c1rank, c2, c2rank) & + RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_7 + END FUNCTION obj_STForceVector7 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_7 + MODULE PROCEDURE obj_STForceVector7 END INTERFACE STForceVector +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_7( & + test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE obj_STForceVector_7 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_7 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -191,17 +418,38 @@ END FUNCTION STForceVector_7 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_8(test, term1) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 + MODULE PURE FUNCTION obj_STForceVector8(test, term1) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_8 + END FUNCTION obj_STForceVector8 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_8 + MODULE PROCEDURE obj_STForceVector8 END INTERFACE STForceVector +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_8(test, term1, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_8 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_8 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -211,143 +459,287 @@ END FUNCTION STForceVector_8 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_9(test, term1, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableScalar_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector9(test, term1, c, crank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_9 + END FUNCTION obj_STForceVector9 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_9 + MODULE PROCEDURE obj_STForceVector9 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_9( & + test, term1, c, crank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_9 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_9 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_10(test, term1, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableVector_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector10(test, term1, c, crank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_10 + END FUNCTION obj_STForceVector10 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_10 + MODULE PROCEDURE obj_STForceVector10 END INTERFACE STForceVector !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_10( & + test, term1, c, crank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE obj_STForceVector_10 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_10 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_11(test, term1, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableMatrix_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector11(test, term1, c, crank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_11 + END FUNCTION obj_STForceVector11 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_11 + MODULE PROCEDURE obj_STForceVector11 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_11( & + test, term1, c, crank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE obj_STForceVector_11 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_11 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_12(test, term1, c1, c1rank, c2, c2rank)& - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector12( & + test, term1, c1, c1rank, c2, c2rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_12 + END FUNCTION obj_STForceVector12 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_12 + MODULE PROCEDURE obj_STForceVector12 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_12( & + test, term1, c1, c1rank, c2, c2rank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE obj_STForceVector_12 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_12 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_13(test, term1, c1, c1rank, c2, c2rank)& - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector13( & + test, term1, c1, c1rank, c2, c2rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_13 + END FUNCTION obj_STForceVector13 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_13 + MODULE PROCEDURE obj_STForceVector13 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_13( & + test, term1, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE obj_STForceVector_13 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_13 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_14(test, term1, c1, c1rank, c2, c2rank)& - & RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - INTEGER( I4B ), INTENT( IN ) :: term1 - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector14( & + test, term1, c1, c1rank, c2, c2rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_14 + END FUNCTION obj_STForceVector14 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_14 + MODULE PROCEDURE obj_STForceVector14 END INTERFACE STForceVector +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_14( & + test, term1, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE obj_STForceVector_14 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_14 +END INTERFACE STForceVector_ !---------------------------------------------------------------------------- ! STForceVector @@ -358,19 +750,48 @@ END FUNCTION STForceVector_14 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_15(test, projecton, c, crank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c - TYPE(FEVariableVector_), INTENT( IN ) :: crank + MODULE PURE FUNCTION obj_STForceVector15(test, projection, c, crank) & + RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_15 + END FUNCTION obj_STForceVector15 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_15 + MODULE PROCEDURE obj_STForceVector15 END INTERFACE STForceVector +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Space time force vector +! + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_15( & + test, projection, c, crank, ans, nrow, ncol, temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(INOUT) :: temp(:, :) + !! temp array to keep projection data at ips and ipt + !! size should be at least (nns x nnt) + END SUBROUTINE obj_STForceVector_15 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_15 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -380,22 +801,51 @@ END FUNCTION STForceVector_15 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_16(test, projecton, c1, c1rank, & - & c2, c2rank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector16( & + test, projection, c1, c1rank, c2, c2rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_16 + END FUNCTION obj_STForceVector16 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_16 + MODULE PROCEDURE obj_STForceVector16 END INTERFACE STForceVector +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_16( & + test, projection, c1, c1rank, c2, c2rank, ans, nrow, ncol, temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(INOUT) :: temp(:, :) + !! temp array to keep projection data at ips and ipt + !! size should be at least (nns x nnt) + END SUBROUTINE obj_STForceVector_16 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_16 +END INTERFACE STForceVector_ + !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- @@ -405,20 +855,22 @@ END FUNCTION STForceVector_16 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_17(test, projecton, & - & c1, c1rank, c2, c2rank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableVector_), INTENT( IN ) :: c2rank + MODULE PURE FUNCTION obj_STForceVector17( & + test, projection, c1, c1rank, c2, c2rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + !! projection is made on c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + !! + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_17 + END FUNCTION obj_STForceVector17 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_17 + MODULE PROCEDURE obj_STForceVector17 END INTERFACE STForceVector !---------------------------------------------------------------------------- @@ -430,104 +882,255 @@ END FUNCTION STForceVector_17 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_18(test, projecton, & - & c1, c1rank, c2, c2rank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank + MODULE PURE SUBROUTINE obj_STForceVector_17( & + test, projection, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + !! projection is made on c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + !! c2 force vector + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(INOUT) :: temp(:, :) + END SUBROUTINE obj_STForceVector_17 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_17 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE FUNCTION obj_STForceVector18( & + test, projection, c1, c1rank, c2, c2rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_18 + END FUNCTION obj_STForceVector18 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_18 + MODULE PROCEDURE obj_STForceVector18 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_18( & + test, projection, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4, & + temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + !! projection vector + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + REAL(DFP), INTENT(INOUT) :: temp(:, :) + END SUBROUTINE obj_STForceVector_18 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_18 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_19(test, projecton, & - & c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariable_), INTENT( IN ) :: c3 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c3rank + MODULE PURE FUNCTION obj_STForceVector19( & + test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariable_), INTENT(IN) :: c3 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + TYPE(FEVariableScalar_), INTENT(IN) :: c3rank REAL(DFP), ALLOCATABLE :: ans(:, :) - END FUNCTION STForceVector_19 + END FUNCTION obj_STForceVector19 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_19 + MODULE PROCEDURE obj_STForceVector19 END INTERFACE STForceVector !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_19( & + test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, nrow, ncol, & + temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariable_), INTENT(IN) :: c3 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + TYPE(FEVariableScalar_), INTENT(IN) :: c3rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(INOUT) :: temp(:, :) + END SUBROUTINE obj_STForceVector_19 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_19 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_20(test, projecton, c1, c1rank, c2, & - & c2rank, c3, c3rank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariable_), INTENT( IN ) :: c3 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - TYPE(FEVariableVector_), INTENT( IN ) :: c3rank + MODULE PURE FUNCTION obj_STForceVector20( & + test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariable_), INTENT(IN) :: c3 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + TYPE(FEVariableVector_), INTENT(IN) :: c3rank REAL(DFP), ALLOCATABLE :: ans(:, :, :) - END FUNCTION STForceVector_20 + END FUNCTION obj_STForceVector20 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_20 + MODULE PROCEDURE obj_STForceVector20 END INTERFACE STForceVector !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_20( & + test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, & + dim1, dim2, dim3, temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariable_), INTENT(IN) :: c3 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + !! projection on c1 + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + TYPE(FEVariableVector_), INTENT(IN) :: c3rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(INOUT) :: temp(:, :) + END SUBROUTINE obj_STForceVector_20 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_20 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 20 Jan 2022 ! summary: Force vector INTERFACE - MODULE PURE FUNCTION STForceVector_21(test, projecton, c1, c1rank, c2, & - & c2rank, c3, c3rank) RESULT(ans) - CLASS(STElemshapeData_), INTENT(IN) :: test( : ) - CHARACTER( LEN = * ), INTENT( IN ) :: projecton - TYPE(FEVariable_), INTENT( IN ) :: c1 - TYPE(FEVariable_), INTENT( IN ) :: c2 - TYPE(FEVariable_), INTENT( IN ) :: c3 - TYPE(FEVariableVector_), INTENT( IN ) :: c1rank - TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank - TYPE(FEVariableMatrix_), INTENT( IN ) :: c3rank + MODULE PURE FUNCTION obj_STForceVector21( & + test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariable_), INTENT(IN) :: c3 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c3rank REAL(DFP), ALLOCATABLE :: ans(:, :, :, :) - END FUNCTION STForceVector_21 + END FUNCTION obj_STForceVector21 END INTERFACE INTERFACE STForceVector - MODULE PROCEDURE STForceVector_21 + MODULE PROCEDURE obj_STForceVector21 END INTERFACE STForceVector -END MODULE STForceVector_Method \ No newline at end of file +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 20 Jan 2022 +! summary: Force vector + +INTERFACE + MODULE PURE SUBROUTINE obj_STForceVector_21( & + test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, dim1, dim2, & + dim3, dim4, temp) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + CHARACTER(LEN=*), INTENT(IN) :: projection + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariable_), INTENT(IN) :: c3 + TYPE(FEVariableVector_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c3rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + REAL(DFP), INTENT(INOUT) :: temp(:, :) + END SUBROUTINE obj_STForceVector_21 +END INTERFACE + +INTERFACE STForceVector_ + MODULE PROCEDURE obj_STForceVector_21 +END INTERFACE STForceVector_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE STForceVector_Method + diff --git a/src/modules/String/src/String_Class.F90 b/src/modules/String/src/String_Class.F90 index 49f90a65c..cc89858e7 100644 --- a/src/modules/String/src/String_Class.F90 +++ b/src/modules/String/src/String_Class.F90 @@ -3178,7 +3178,7 @@ ELEMENTAL FUNCTION to_logical_1(self, kind) RESULT(ans) !! Mold parameter for kind detection. LOGICAL :: ans !! The number into the string. - + ans = self%to_logical() END FUNCTION to_logical_1 diff --git a/src/modules/Tetrahedron/CMakeLists.txt b/src/modules/Tetrahedron/CMakeLists.txt new file mode 100644 index 000000000..4aabd5814 --- /dev/null +++ b/src/modules/Tetrahedron/CMakeLists.txt @@ -0,0 +1,21 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} PRIVATE ${src_path}/ReferenceTetrahedron_Method.F90 + ${src_path}/TetrahedronInterpolationUtility.F90) diff --git a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 b/src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90 similarity index 90% rename from src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 rename to src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90 index 6dd64c981..dfc18fc24 100644 --- a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 +++ b/src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90 @@ -341,16 +341,19 @@ END FUNCTION RefCoord_Tetrahedron END INTERFACE !---------------------------------------------------------------------------- -! GetFaceElemType@GeometryMethods +! GetFaceElemType@GeometryMethods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2024-03-11 ! summary: Returns the element type of each face -INTERFACE - MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron(faceElemType, opt, & - & tFaceNodes, elemType) +INTERFACE GetFaceElemType_Tetrahedron + MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron1(elemType, faceElemType, & + tFaceNodes, opt) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! element type for Tetrahedron + !! default is Tetrahedron4 INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) !! Face element type INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:) @@ -359,10 +362,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron(faceElemType, opt, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + END SUBROUTINE GetFaceElemType_Tetrahedron1 +END INTERFACE GetFaceElemType_Tetrahedron + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-03-11 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Tetrahedron + MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron2( & + elemType, localFaceNumber, faceElemType, tFaceNodes, opt) + INTEGER(I4B), INTENT(IN) :: elemType !! element type for Tetrahedron - !! default is Tetrahedron4 - END SUBROUTINE GetFaceElemType_Tetrahedron -END INTERFACE + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Face element type + INTEGER(I4B), INTENT(OUT) :: tFaceNodes + !! total nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Tetrahedron2 +END INTERFACE GetFaceElemType_Tetrahedron END MODULE ReferenceTetrahedron_Method diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Tetrahedron/src/TetrahedronInterpolationUtility.F90 similarity index 100% rename from src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 rename to src/modules/Tetrahedron/src/TetrahedronInterpolationUtility.F90 diff --git a/src/modules/Triangle/CMakeLists.txt b/src/modules/Triangle/CMakeLists.txt new file mode 100644 index 000000000..cfaca3bbf --- /dev/null +++ b/src/modules/Triangle/CMakeLists.txt @@ -0,0 +1,23 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/Triangle_Method.F90 + ${src_path}/ReferenceTriangle_Method.F90 + ${src_path}/TriangleInterpolationUtility.F90) diff --git a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 b/src/modules/Triangle/src/ReferenceTriangle_Method.F90 similarity index 95% rename from src/modules/Geometry/src/ReferenceTriangle_Method.F90 rename to src/modules/Triangle/src/ReferenceTriangle_Method.F90 index 2e71a0e39..83e9ddf94 100644 --- a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 +++ b/src/modules/Triangle/src/ReferenceTriangle_Method.F90 @@ -802,9 +802,9 @@ END SUBROUTINE FaceShapeMetaData_Triangle ! date: 2024-04-19 ! summary: Returns the element type of each face -INTERFACE -MODULE PURE SUBROUTINE GetFaceElemType_Triangle(elemType, faceElemType, opt, & - tFaceNodes) +INTERFACE GetFaceElemType_Triangle +MODULE PURE SUBROUTINE GetFaceElemType_Triangle1(elemType, faceElemType, opt, & + tFaceNodes) INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType !! name of element INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:) @@ -815,8 +815,34 @@ MODULE PURE SUBROUTINE GetFaceElemType_Triangle(elemType, faceElemType, opt, & !! If opt = 1, then edge connectivity for hierarchial approximation !! If opt = 2, then edge connectivity for Lagrangian approximation !! opt = 1 is default - END SUBROUTINE GetFaceElemType_Triangle -END INTERFACE + END SUBROUTINE GetFaceElemType_Triangle1 +END INTERFACE GetFaceElemType_Triangle + +!---------------------------------------------------------------------------- +! GetFaceElemType@GeometryMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-04-19 +! summary: Returns the element type of each face + +INTERFACE GetFaceElemType_Triangle + MODULE PURE SUBROUTINE GetFaceElemType_Triangle2(elemType, localFaceNumber, & + faceElemType, opt, tFaceNodes) + INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType + !! name of element + INTEGER(I4B), INTENT(IN) :: localFaceNumber + !! local face number + INTEGER(I4B), INTENT(OUT) :: faceElemType + !! Element names of faces + INTEGER(I4B), INTENT(OUT) :: tFaceNodes + !! Total number of nodes in each face + INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt + !! If opt = 1, then edge connectivity for hierarchial approximation + !! If opt = 2, then edge connectivity for Lagrangian approximation + !! opt = 1 is default + END SUBROUTINE GetFaceElemType_Triangle2 +END INTERFACE GetFaceElemType_Triangle !---------------------------------------------------------------------------- ! diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 similarity index 91% rename from src/modules/Polynomial/src/TriangleInterpolationUtility.F90 rename to src/modules/Triangle/src/TriangleInterpolationUtility.F90 index f52b2de36..fbe3299d9 100644 --- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 +++ b/src/modules/Triangle/src/TriangleInterpolationUtility.F90 @@ -69,6 +69,33 @@ MODULE TriangleInterpolationUtility PUBLIC :: GetTotalDOF_Triangle PUBLIC :: GetTotalInDOF_Triangle +PUBLIC :: GetHierarchicalDOF_Triangle + +!---------------------------------------------------------------------------- +! GetHierarchicalDOF_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-18 +! summary: Get the Hierarchical DOF for triangle + +! order, pe1, pe2, pe3 +INTERFACE + MODULE PURE FUNCTION GetHierarchicalDOF_Triangle( & + order, pe1, pe2, pe3, opt) RESULT(ans) + INTEGER(I4B), INTENT(IN) :: order + !! cell order + INTEGER(I4B), INTENT(IN) :: pe1, pe2, pe3 + !! face order + CHARACTER(1), INTENT(IN) :: opt + !! 'V' - vertex + !! 'E' - edge + !! 'C' - cell + !! 'H' - total hierarchical dof + INTEGER(I4B) :: ans + END FUNCTION GetHierarchicalDOF_Triangle +END INTERFACE + !---------------------------------------------------------------------------- ! GetTotalDOF_Triangle !---------------------------------------------------------------------------- @@ -123,7 +150,7 @@ END FUNCTION GetTotalInDOF_Triangle INTERFACE MODULE FUNCTION RefElemDomain_Triangle(baseContinuity, baseInterpol) & - & RESULT(ans) + RESULT(ans) CHARACTER(*), INTENT(IN) :: baseContinuity !! Cointinuity (conformity) of basis functions !! "H1", "HDiv", "HCurl", "DG" @@ -144,11 +171,10 @@ END FUNCTION RefElemDomain_Triangle ! summary: This function returns the edge connectivity of Triangle INTERFACE - MODULE FUNCTION FacetConnectivity_Triangle( & - & baseInterpol, & - & baseContinuity) RESULT(ans) - CHARACTER(*), INTENT(IN) :: baseInterpol - CHARACTER(*), INTENT(IN) :: baseContinuity + MODULE FUNCTION FacetConnectivity_Triangle(baseInterpol, & + baseContinuity) RESULT(ans) + CHARACTER(*), OPTIONAL, INTENT(IN) :: baseInterpol + CHARACTER(*), OPTIONAL, INTENT(IN) :: baseContinuity INTEGER(I4B) :: ans(2, 3) !! rows represents the end points of an edges !! columns denote the edge (facet) @@ -517,7 +543,8 @@ END SUBROUTINE Isaac_Triangle_ INTERFACE MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, & - layout, xij, alpha, beta, lambda) RESULT(ans) + layout, xij, alpha, & + beta, lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -542,8 +569,8 @@ END FUNCTION InterpolationPoint_Triangle !---------------------------------------------------------------------------- INTERFACE - MODULE SUBROUTINE InterpolationPoint_Triangle_(order, ipType, ans, nrow, & - ncol, layout, xij, alpha, beta, lambda) + MODULE SUBROUTINE InterpolationPoint_Triangle_( & + order, ipType, ans, nrow, ncol, layout, xij, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order INTEGER(I4B), INTENT(IN) :: ipType @@ -647,8 +674,7 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle2_(order, i, v, isVandermonde, & !! This is just to resolve interface issue, the value of isVandermonde !! is not used in thesubroutine _ REAL(DFP), INTENT(INOUT) :: ans(:) - ! ans(SIZE(v, 1)) - !! coefficients of ith Lagrange polynomial + ! ans(SIZE(v, 1)) ! coefficients of ith Lagrange polynomial INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE LagrangeCoeff_Triangle2_ END INTERFACE LagrangeCoeff_Triangle_ @@ -691,8 +717,7 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle3_(order, i, v, ipiv, ans, tsize) INTEGER(I4B), INTENT(IN) :: ipiv(:) !! inverse pivoting mapping, compes from LU decomposition REAL(DFP), INTENT(INOUT) :: ans(:) - !! ans(SIZE(v, 1)) - !! coefficients + !! ans(SIZE(v, 1)) ! coefficients INTEGER(I4B), INTENT(OUT) :: tsize END SUBROUTINE LagrangeCoeff_Triangle3_ END INTERFACE LagrangeCoeff_Triangle_ @@ -713,12 +738,9 @@ MODULE FUNCTION LagrangeCoeff_Triangle4(order, xij, basisType, & REAL(DFP), INTENT(IN) :: xij(:, :) !! points in xij format, size(xij,2) INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType - !! Monomials - !! Jacobi (Dubiner) - !! Heirarchical + !! Monomials ! Jacobi (Dubiner) ! Heirarchical CHARACTER(*), OPTIONAL, INTENT(IN) :: refTriangle - !! UNIT - !! BIUNIT + !! UNIT ! BIUNIT REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) !! coefficients END FUNCTION LagrangeCoeff_Triangle4 @@ -740,12 +762,9 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle4_(order, xij, basisType, & REAL(DFP), INTENT(IN) :: xij(:, :) !! points in xij format, size(xij,2) INTEGER(I4B), INTENT(IN) :: basisType - !! Monomials - !! Jacobi (Dubiner) - !! Heirarchical + !! Monomials ! Jacobi (Dubiner) ! Heirarchical CHARACTER(*), INTENT(IN) :: refTriangle - !! UNIT - !! BIUNIT + !! UNIT ! BIUNIT REAL(DFP), INTENT(INOUT) :: ans(:, :) ! REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2)) !! coefficients @@ -753,6 +772,57 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle4_(order, xij, basisType, & END SUBROUTINE LagrangeCoeff_Triangle4_ END INTERFACE LagrangeCoeff_Triangle_ +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 27 Oct 2022 +! summary: Returns the coefficients for ith lagrange polynomial + +INTERFACE LagrangeCoeff_Triangle_ + MODULE SUBROUTINE LagrangeCoeff_Triangle5_( & + order, xij, basisType, refTriangle, degree, ans, nrow, ncol) + INTEGER(I4B), INTENT(IN) :: order + !! order of polynomial + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in xij format, size(xij,2) + INTEGER(I4B), INTENT(IN) :: basisType + !! Monomials, Jacobi (Dubiner), Hierarchical + CHARACTER(*), INTENT(IN) :: refTriangle + !! UNIT, BIUNIT + INTEGER(I4B), INTENT(IN) :: degree(:, :) + !! degree of monomials, used when basisType is Monomial + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(xij, 2), SIZE(xij, 2)) + !! coefficients + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE LagrangeCoeff_Triangle5_ +END INTERFACE LagrangeCoeff_Triangle_ + +!---------------------------------------------------------------------------- +! LagrangeVandermonde_Triangle +!---------------------------------------------------------------------------- + +INTERFACE LagrangeVandermonde_Triangle_ + MODULE PURE SUBROUTINE LagrangeVandermonde_Triangle1_(xij, degree, ans, & + nrow, ncol) + REAL(DFP), INTENT(IN) :: xij(:, :) + !! points in $x_{iJ}$ format + !! nrow = number of spatial dimensions + !! ncol = number of points of evaluation + INTEGER(I4B), INTENT(IN) :: degree(:, :) + !! degree of monomials + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! Vandermonde matrix + !! nrows := number of points + !! ncols := number of dof + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! nrow = SIZE(xij, 2) + !! ncol = SIZE(degree, 1) + END SUBROUTINE LagrangeVandermonde_Triangle1_ +END INTERFACE LagrangeVandermonde_Triangle_ + !---------------------------------------------------------------------------- ! DubinerPolynomial !---------------------------------------------------------------------------- @@ -1098,8 +1168,8 @@ END FUNCTION HeirarchicalBasis_Triangle2 ! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle INTERFACE HeirarchicalBasis_Triangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle1_(order, pe1, pe2, pe3, & - xij, refTriangle, ans, nrow, ncol) + MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle1_( & + order, pe1, pe2, pe3, xij, refTriangle, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) !! it should be greater than 2 for cell bubble to exist @@ -1137,8 +1207,8 @@ END SUBROUTINE HeirarchicalBasis_Triangle1_ ! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle INTERFACE HeirarchicalBasis_Triangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle2_(order, xij, & - refTriangle, ans, nrow, ncol) + MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle2_( & + order, xij, refTriangle, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) !! it should be greater than 2 for cell bubble to exist @@ -1167,9 +1237,9 @@ END SUBROUTINE HeirarchicalBasis_Triangle2_ ! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle INTERFACE HeirarchicalBasis_Triangle_ - MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, & - xij, refTriangle, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, & - ans, nrow, ncol) + MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_( & + order, pe1, pe2, pe3, xij, refTriangle, edgeOrient1, edgeOrient2, & + edgeOrient3, faceOrient, ans, nrow, ncol) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) !! it should be greater than 2 for cell bubble to exist @@ -1197,7 +1267,6 @@ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, & ! REAL(DFP) :: ans( & ! & SIZE(xij, 2), & ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)) - !! INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE HeirarchicalBasis_Triangle3_ END INTERFACE HeirarchicalBasis_Triangle_ @@ -1211,8 +1280,8 @@ END SUBROUTINE HeirarchicalBasis_Triangle3_ ! summary: Evaluate all Lagrange polynomial of order n at single points INTERFACE LagrangeEvalAll_Triangle - MODULE FUNCTION LagrangeEvalAll_Triangle1(order, x, xij, refTriangle, & - coeff, firstCall, basisType) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Triangle1( & + order, x, xij, refTriangle, coeff, firstCall, basisType) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(2) @@ -1243,8 +1312,8 @@ END FUNCTION LagrangeEvalAll_Triangle1 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Triangle_ - MODULE SUBROUTINE LagrangeEvalAll_Triangle1_(order, x, xij, ans, tsize, & - refTriangle, coeff, firstCall, basisType) + MODULE SUBROUTINE LagrangeEvalAll_Triangle1_( & + order, x, xij, ans, tsize, refTriangle, coeff, firstCall, basisType) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(2) @@ -1283,8 +1352,9 @@ END SUBROUTINE LagrangeEvalAll_Triangle1_ ! summary: Evaluate all Lagrange polynomials of order n at several points INTERFACE LagrangeEvalAll_Triangle - MODULE FUNCTION LagrangeEvalAll_Triangle2(order, x, xij, refTriangle, & - coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans) + MODULE FUNCTION LagrangeEvalAll_Triangle2( & + order, x, xij, refTriangle, coeff, firstCall, basisType, alpha, beta, & + lambda) RESULT(ans) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1318,8 +1388,9 @@ END FUNCTION LagrangeEvalAll_Triangle2 !---------------------------------------------------------------------------- INTERFACE LagrangeEvalAll_Triangle_ - MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, & - ncol, refTriangle, coeff, firstCall, basisType, alpha, beta, lambda) + MODULE SUBROUTINE LagrangeEvalAll_Triangle2_( & + order, x, xij, ans, nrow, ncol, refTriangle, coeff, firstCall, & + basisType, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! Order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1352,6 +1423,49 @@ MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, & END SUBROUTINE LagrangeEvalAll_Triangle2_ END INTERFACE LagrangeEvalAll_Triangle_ +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle_@LagrangeMethods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-22 +! summary: Master routine for LagrangeEvalAll_Triangle_ + +INTERFACE LagrangeEvalAll_Triangle_ + MODULE SUBROUTINE LagrangeEvalAll_Triangle3_( & + order, x, xij, ans, nrow, ncol, refTriangle, coeff, firstCall, & + basisType, xx, degree) + INTEGER(I4B), INTENT(IN) :: order + !! Order of Lagrange polynomials + REAL(DFP), INTENT(IN) :: x(:, :) + !! Point of evaluation; x(1, :) is x coord; x(2, :) is y coord + REAL(DFP), INTENT(INOUT) :: xij(:, :) + !! Interpolation points + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(x, 2), SIZE(xij, 2)) + !! Value of n+1 Lagrange polynomials at point x + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! Number of rows and columns written to ans + !! nrow = size(x, 2), points of evaluation + !! ncol = size(xij, 2), number of interpolation points + CHARACTER(*), INTENT(IN) :: refTriangle + !! Reference triangle ! Biunit ! Unit + REAL(DFP), INTENT(INOUT) :: coeff(:, :) + !! coeff(SIZE(xij, 2), SIZE(xij, 2)) + !! Coefficient of Lagrange polynomials + LOGICAL(LGT) :: firstCall + !! If firstCall is true, then coeff will be made + !! If firstCall is False, then coeff will be used + !! Default value of firstCall is True + INTEGER(I4B), INTENT(IN) :: basisType + !! Monomials *Default ! Jacobi=Dubiner ! Heirarchical + REAL(DFP), INTENT(INOUT) :: xx(:, :) + !! xx(SIZE(x, 2), SIZE(xij, 2)) + INTEGER(I4B) :: degree(:, :) + ! degree(SIZE(xij, 2), 2) + END SUBROUTINE LagrangeEvalAll_Triangle3_ +END INTERFACE LagrangeEvalAll_Triangle_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- @@ -1546,7 +1660,7 @@ END SUBROUTINE TensorQuadraturePoint_Triangle1_ INTERFACE TensorQuadraturePoint_Triangle MODULE FUNCTION TensorQuadraturePoint_Triangle2(nipsx, nipsy, quadType, & - & refTriangle, xij) RESULT(ans) + & refTriangle, xij) RESULT(ans) INTEGER(I4B), INTENT(IN) :: nipsx(1) !! number of integration points in x direction INTEGER(I4B), INTENT(IN) :: nipsy(1) @@ -1660,9 +1774,9 @@ END FUNCTION LagrangeGradientEvalAll_Triangle1 ! summary: Evaluate Lagrange polynomials of n at several points INTERFACE LagrangeGradientEvalAll_Triangle_ - MODULE SUBROUTINE LagrangeGradientEvalAll_Triangle1_(order, x, xij, ans, & - dim1, dim2, dim3, refTriangle, coeff, firstCall, basisType, alpha, & - beta, lambda) + MODULE SUBROUTINE LagrangeGradientEvalAll_Triangle1_( & + order, x, xij, ans, dim1, dim2, dim3, refTriangle, coeff, firstCall, & + basisType, alpha, beta, lambda) INTEGER(I4B), INTENT(IN) :: order !! order of Lagrange polynomials REAL(DFP), INTENT(IN) :: x(:, :) @@ -1711,8 +1825,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 @@ -1747,8 +1861,8 @@ END FUNCTION HeirarchicalBasisGradient_Triangle1 ! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle INTERFACE HeirarchicalBasisGradient_Triangle_ - MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, & - pe3, xij, refTriangle, ans, tsize1, tsize2, tsize3) + MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_( & + order, pe1, pe2, pe3, xij, refTriangle, ans, tsize1, tsize2, tsize3) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) !! it should be greater than 2 for cell bubble to exist @@ -1781,9 +1895,9 @@ END SUBROUTINE HeirarchicalBasisGradient_Triangle1_ !---------------------------------------------------------------------------- INTERFACE HeirarchicalBasisGradient_Triangle_ - MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle2_(order, pe1, pe2, & - pe3, xij, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, & - refTriangle, ans, tsize1, tsize2, tsize3) + MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle2_( & + order, pe1, pe2, pe3, xij, edgeOrient1, edgeOrient2, edgeOrient3, & + faceOrient, refTriangle, ans, tsize1, tsize2, tsize3) INTEGER(I4B), INTENT(IN) :: order !! Order of approximation inside the triangle (i.e., cell) !! it should be greater than 2 for cell bubble to exist diff --git a/src/modules/Geometry/src/Triangle_Method.F90 b/src/modules/Triangle/src/Triangle_Method.F90 similarity index 99% rename from src/modules/Geometry/src/Triangle_Method.F90 rename to src/modules/Triangle/src/Triangle_Method.F90 index 62db70829..63222c801 100644 --- a/src/modules/Geometry/src/Triangle_Method.F90 +++ b/src/modules/Triangle/src/Triangle_Method.F90 @@ -29,7 +29,7 @@ ! easifem. MODULE Triangle_Method -USE GlobalData +USE GlobalData, ONLY: I4B, LGT, DFP IMPLICIT NONE PRIVATE PUBLIC :: triangle_angles_2d diff --git a/src/modules/Utility/CMakeLists.txt b/src/modules/Utility/CMakeLists.txt index 3428baa00..60fcc22cc 100644 --- a/src/modules/Utility/CMakeLists.txt +++ b/src/modules/Utility/CMakeLists.txt @@ -53,4 +53,5 @@ target_sources( ${src_path}/TriagUtility.F90 ${src_path}/LinearAlgebraUtility.F90 ${src_path}/SafeSizeUtility.F90 + ${src_path}/ReverseUtility.F90 ${src_path}/Utility.F90) diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90 index 2037e78d7..bcb54a384 100644 --- a/src/modules/Utility/src/ConvertUtility.F90 +++ b/src/modules/Utility/src/ConvertUtility.F90 @@ -50,17 +50,41 @@ MODULE ConvertUtility !@endnote INTERFACE Convert - MODULE PURE SUBROUTINE convert_1(From, To, Conversion, nns, tdof) - REAL(DFP), INTENT(IN) :: From(:, :) + MODULE PURE SUBROUTINE obj_Convert1(from, to, conversion, nns, tdof) + REAL(DFP), INTENT(IN) :: from(:, :) !! Matrix in one format - REAL(DFP), INTENT(INOUT), ALLOCATABLE :: To(:, :) + REAL(DFP), INTENT(INOUT), ALLOCATABLE :: to(:, :) !! Matrix is desired format - INTEGER(I4B), INTENT(IN) :: Conversion - !! `Conversion` can be `NodesToDOF` or `DOFToNodes` + INTEGER(I4B), INTENT(IN) :: conversion + !! `conversion` can be `NodestoDOF` or `DOFtoNodes` INTEGER(I4B), INTENT(IN) :: nns, tdof - END SUBROUTINE convert_1 + END SUBROUTINE obj_Convert1 END INTERFACE Convert +!---------------------------------------------------------------------------- +! Convert_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-11-20 +! summary: Like Convert_1, but no allocation + +INTERFACE Convert_ + MODULE PURE SUBROUTINE obj_Convert_1(from, to, conversion, nns, tdof, nrow, & + ncol) + REAL(DFP), INTENT(IN) :: from(:, :) + !! Matrix in one format + REAL(DFP), INTENT(INOUT) :: to(:, :) + !! Matrix is desired format + INTEGER(I4B), INTENT(IN) :: conversion + !! `conversion` can be `NodestoDOF` or `DOFtoNodes` + INTEGER(I4B), INTENT(IN) :: nns, tdof + !! number of nodes in space and tdod + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of data written in to + END SUBROUTINE obj_Convert_1 +END INTERFACE Convert_ + !---------------------------------------------------------------------------- ! Convert@ConvertMethods !---------------------------------------------------------------------------- @@ -87,15 +111,15 @@ END SUBROUTINE convert_1 !@endnote INTERFACE ConvertSafe - MODULE PURE SUBROUTINE convert_1_safe(From, To, Conversion, nns, tdof) - REAL(DFP), INTENT(IN) :: From(:, :) + MODULE PURE SUBROUTINE obj_ConvertSafe1(from, to, conversion, nns, tdof) + REAL(DFP), INTENT(IN) :: from(:, :) !! Matrix in one format - REAL(DFP), INTENT(INOUT) :: To(:, :) + REAL(DFP), INTENT(INOUT) :: to(:, :) !! Matrix is desired format - INTEGER(I4B), INTENT(IN) :: Conversion - !! `Conversion` can be `NodesToDOF` or `DOFToNodes` + INTEGER(I4B), INTENT(IN) :: conversion + !! `conversion` can be `NodestoDOF` or `DOFtoNodes` INTEGER(I4B), INTENT(IN) :: nns, tdof - END SUBROUTINE convert_1_safe + END SUBROUTINE obj_ConvertSafe1 END INTERFACE ConvertSafe !---------------------------------------------------------------------------- @@ -111,20 +135,20 @@ END SUBROUTINE convert_1_safe ! This subroutine converts rank4 matrix to rank2 matrix ! This routine can be used in Space-Time FEM ! -! - The first and second dimension of From is spatial nodes -! - The third and forth dimension of From is temporal nodes +! - The first and second dimension of from is spatial nodes +! - The third and forth dimension of from is temporal nodes ! -! - In this way `From(:, :, a, b)` denotes the `a,b` block matrix +! - In this way `from(:, :, a, b)` denotes the `a,b` block matrix ! -! Format of To matrix +! Format of to matrix ! ! Contains the block matrix structure in 2D. INTERFACE Convert - MODULE PURE SUBROUTINE convert_2(From, To) - REAL(DFP), INTENT(IN) :: From(:, :, :, :) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :) - END SUBROUTINE convert_2 + MODULE PURE SUBROUTINE obj_Convert2(from, to) + REAL(DFP), INTENT(IN) :: from(:, :, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :) + END SUBROUTINE obj_Convert2 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -136,11 +160,11 @@ END SUBROUTINE convert_2 ! summary: convert without allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE convert2_(From, To, nrow, ncol) - REAL(DFP), INTENT(IN) :: From(:, :, :, :) - REAL(DFP), INTENT(INOUT) :: To(:, :) + MODULE PURE SUBROUTINE obj_Convert_2(from, to, nrow, ncol) + REAL(DFP), INTENT(IN) :: from(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: to(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol - END SUBROUTINE convert2_ + END SUBROUTINE obj_Convert_2 END INTERFACE Convert_ !---------------------------------------------------------------------------- @@ -153,12 +177,12 @@ END SUBROUTINE convert2_ ! INTERFACE Convert - MODULE PURE SUBROUTINE convert_3(From, To) - REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :) + MODULE PURE SUBROUTINE obj_Convert3(from, to) + REAL(DFP), INTENT(IN) :: from(:, :, :, :, :, :) !! I, J, ii, jj, a, b - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :, :, :) + REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :, :, :) !! I, J, a, b - END SUBROUTINE convert_3 + END SUBROUTINE obj_Convert3 END INTERFACE Convert !---------------------------------------------------------------------------- @@ -170,11 +194,11 @@ END SUBROUTINE convert_3 ! summary: convert without allocation INTERFACE Convert_ - MODULE PURE SUBROUTINE convert3_(From, To, dim1, dim2, dim3, dim4) - REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :) - REAL(DFP), INTENT(INOUT) :: To(:, :, :, :) + MODULE PURE SUBROUTINE obj_Convert_3(from, to, dim1, dim2, dim3, dim4) + REAL(DFP), INTENT(IN) :: from(:, :, :, :, :, :) + REAL(DFP), INTENT(INOUT) :: to(:, :, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 - END SUBROUTINE convert3_ + END SUBROUTINE obj_Convert_3 END INTERFACE Convert_ !---------------------------------------------------------------------------- diff --git a/src/modules/Utility/src/MatmulUtility.F90 b/src/modules/Utility/src/MatmulUtility.F90 index 1fb96640e..0e873f488 100644 --- a/src/modules/Utility/src/MatmulUtility.F90 +++ b/src/modules/Utility/src/MatmulUtility.F90 @@ -16,11 +16,12 @@ ! MODULE MatmulUtility -USE GlobalData +USE GlobalData, ONLY: DFP, I4B, LGT IMPLICIT NONE PRIVATE PUBLIC :: MATMUL +PUBLIC :: MATMUL_ !---------------------------------------------------------------------------- ! Matmul@Matmul @@ -38,7 +39,7 @@ MODULE MatmulUtility MODULE PURE FUNCTION matmul_r4_r1(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :, :, :) REAL(DFP), INTENT(IN) :: a2(:) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3)) END FUNCTION END INTERFACE @@ -46,6 +47,31 @@ MODULE PURE FUNCTION matmul_r4_r1(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r4_r1 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 3 April 2021 +! summary: matmul for rank4 and rank1 array +! +!# Introduction +! +! `ans(i,j,k) = a1(i,j,k,l)*a2(l)` + +INTERFACE + MODULE PURE SUBROUTINE matmul_r4_r1_(a1, a2, ans, dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a1(:, :, :, :) + REAL(DFP), INTENT(IN) :: a2(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matmul_r4_r1_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r4_r1_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -61,8 +87,8 @@ MODULE PURE FUNCTION matmul_r4_r1(a1, a2) RESULT(ans) INTERFACE MODULE PURE FUNCTION matmul_r4_r2(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :, :, :) - REAL(DFP), INTENT(IN) :: a2(:,:) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3), size(a2, 2)) + REAL(DFP), INTENT(IN) :: a2(:, :) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3), SIZE(a2, 2)) END FUNCTION END INTERFACE @@ -70,6 +96,23 @@ MODULE PURE FUNCTION matmul_r4_r2(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r4_r2 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r4_r2_(a1, a2, ans, dim1, dim2, dim3, dim4) + REAL(DFP), INTENT(IN) :: a1(:, :, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE matmul_r4_r2_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r4_r2_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -85,9 +128,9 @@ MODULE PURE FUNCTION matmul_r4_r2(a1, a2) RESULT(ans) INTERFACE MODULE PURE FUNCTION matmul_r4_r3(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :, :, :) - REAL(DFP), INTENT(IN) :: a2(:,:,:) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3), & - & size(a2, 2), size(a2, 3)) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3), & + & SIZE(a2, 2), SIZE(a2, 3)) END FUNCTION END INTERFACE @@ -95,6 +138,24 @@ MODULE PURE FUNCTION matmul_r4_r3(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r4_r3 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r4_r3_(a1, a2, ans, dim1, dim2, dim3, dim4, & + dim5) + REAL(DFP), INTENT(IN) :: a1(:, :, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4, dim5 + END SUBROUTINE matmul_r4_r3_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r4_r3_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -110,9 +171,9 @@ MODULE PURE FUNCTION matmul_r4_r3(a1, a2) RESULT(ans) INTERFACE MODULE PURE FUNCTION matmul_r4_r4(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :, :, :) - REAL(DFP), INTENT(IN) :: a2(:,:,:,:) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3), & - & size(a2, 2), size(a2, 3), size(a2, 4)) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3), & + & SIZE(a2, 2), SIZE(a2, 3), SIZE(a2, 4)) END FUNCTION END INTERFACE @@ -120,6 +181,24 @@ MODULE PURE FUNCTION matmul_r4_r4(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r4_r4 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r4_r4_(a1, a2, ans, dim1, dim2, dim3, & + dim4, dim5, dim6) + REAL(DFP), INTENT(IN) :: a1(:, :, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4, dim5, dim6 + END SUBROUTINE matmul_r4_r4_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r4_r4_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -137,7 +216,7 @@ MODULE PURE FUNCTION matmul_r4_r4(a1, a2) RESULT(ans) MODULE PURE FUNCTION matmul_r3_r1(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :, :) REAL(DFP), INTENT(IN) :: a2(:) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2)) END FUNCTION END INTERFACE @@ -145,6 +224,23 @@ MODULE PURE FUNCTION matmul_r3_r1(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r3_r1 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r3_r1_(a1, a2, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE matmul_r3_r1_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r3_r1_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -161,8 +257,8 @@ MODULE PURE FUNCTION matmul_r3_r1(a1, a2) RESULT(ans) MODULE PURE FUNCTION matmul_r3_r2(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :, :) REAL(DFP), INTENT(IN) :: a2(:, :) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), & - & size(a2, 2)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), & + & SIZE(a2, 2)) END FUNCTION END INTERFACE @@ -170,6 +266,23 @@ MODULE PURE FUNCTION matmul_r3_r2(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r3_r2 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r3_r2_(a1, a2, ans, dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matmul_r3_r2_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r3_r2_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -184,10 +297,10 @@ MODULE PURE FUNCTION matmul_r3_r2(a1, a2) RESULT(ans) INTERFACE MODULE PURE FUNCTION matmul_r3_r3(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:,:,:) + REAL(DFP), INTENT(IN) :: a1(:, :, :) REAL(DFP), INTENT(IN) :: a2(:, :, :) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), & - & size(a2, 2), size(a2, 3)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), & + & SIZE(a2, 2), SIZE(a2, 3)) END FUNCTION END INTERFACE @@ -195,6 +308,24 @@ MODULE PURE FUNCTION matmul_r3_r3(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r3_r3 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r3_r3_(a1, a2, ans, dim1, dim2, dim3, & + dim4) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE matmul_r3_r3_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r3_r3_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -209,10 +340,10 @@ MODULE PURE FUNCTION matmul_r3_r3(a1, a2) RESULT(ans) INTERFACE MODULE PURE FUNCTION matmul_r3_r4(a1, a2) RESULT(ans) - REAL(DFP), INTENT(IN) :: a1(:,:,:) + REAL(DFP), INTENT(IN) :: a1(:, :, :) REAL(DFP), INTENT(IN) :: a2(:, :, :, :) - REAL(DFP) :: ans(size(a1, 1), size(a1, 2), & - & size(a2, 2), size(a2, 3), size(a2, 4)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), & + & SIZE(a2, 2), SIZE(a2, 3), SIZE(a2, 4)) END FUNCTION END INTERFACE @@ -220,6 +351,24 @@ MODULE PURE FUNCTION matmul_r3_r4(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r3_r4 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r3_r4_(a1, a2, ans, dim1, dim2, dim3, & + dim4, dim5) + REAL(DFP), INTENT(IN) :: a1(:, :, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4, dim5 + END SUBROUTINE matmul_r3_r4_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r3_r4_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -237,7 +386,7 @@ MODULE PURE FUNCTION matmul_r3_r4(a1, a2) RESULT(ans) MODULE PURE FUNCTION matmul_r2_r3(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :) REAL(DFP), INTENT(IN) :: a2(:, :, :) - REAL(DFP) :: ans(size(a1, 1), size(a2, 2), size(a2, 3)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a2, 2), SIZE(a2, 3)) END FUNCTION END INTERFACE @@ -245,6 +394,23 @@ MODULE PURE FUNCTION matmul_r2_r3(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r2_r3 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r2_r3_(a1, a2, ans, dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a1(:, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matmul_r2_r3_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r2_r3_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -262,8 +428,8 @@ MODULE PURE FUNCTION matmul_r2_r3(a1, a2) RESULT(ans) MODULE PURE FUNCTION matmul_r2_r4(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:, :) REAL(DFP), INTENT(IN) :: a2(:, :, :, :) - REAL(DFP) :: ans(size(a1, 1), size(a2, 2), & - & size(a2, 3), size(a2, 4)) + REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a2, 2), & + & SIZE(a2, 3), SIZE(a2, 4)) END FUNCTION END INTERFACE @@ -271,6 +437,23 @@ MODULE PURE FUNCTION matmul_r2_r4(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r2_r4 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r2_r4_(a1, a2, ans, dim1, dim2, dim3, dim4) + REAL(DFP), INTENT(IN) :: a1(:, :) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE matmul_r2_r4_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r2_r4_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -296,6 +479,22 @@ MODULE PURE FUNCTION matmul_r1_r1(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r1_r1 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r1_r1_(a1, a2, ans) + REAL(DFP), INTENT(IN) :: a1(:) + REAL(DFP), INTENT(IN) :: a2(:) + REAL(DFP), INTENT(INOUT) :: ans + END SUBROUTINE matmul_r1_r1_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r1_r1_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! Matmul@Matmul !---------------------------------------------------------------------------- @@ -313,7 +512,7 @@ MODULE PURE FUNCTION matmul_r1_r1(a1, a2) RESULT(ans) MODULE PURE FUNCTION matmul_r1_r3(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:) REAL(DFP), INTENT(IN) :: a2(:, :, :) - REAL(DFP) :: ans(size(a2, 2), size(a2, 3)) + REAL(DFP) :: ans(SIZE(a2, 2), SIZE(a2, 3)) END FUNCTION END INTERFACE @@ -322,7 +521,24 @@ MODULE PURE FUNCTION matmul_r1_r3(a1, a2) RESULT(ans) END INTERFACE MATMUL !---------------------------------------------------------------------------- -! Matmul@Matmul +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r1_r3_(a1, a2, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: a1(:) + REAL(DFP), INTENT(IN) :: a2(:, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + END SUBROUTINE matmul_r1_r3_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r1_r3_ +END INTERFACE MATMUL_ + +!---------------------------------------------------------------------------- +! Matmul !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -337,7 +553,7 @@ MODULE PURE FUNCTION matmul_r1_r3(a1, a2) RESULT(ans) MODULE PURE FUNCTION matmul_r1_r4(a1, a2) RESULT(ans) REAL(DFP), INTENT(IN) :: a1(:) REAL(DFP), INTENT(IN) :: a2(:, :, :, :) - REAL(DFP) :: ans(size(a2, 2), size(a2, 3), size(a2, 4)) + REAL(DFP) :: ans(SIZE(a2, 2), SIZE(a2, 3), SIZE(a2, 4)) END FUNCTION END INTERFACE @@ -345,8 +561,26 @@ MODULE PURE FUNCTION matmul_r1_r4(a1, a2) RESULT(ans) MODULE PROCEDURE matmul_r1_r4 END INTERFACE MATMUL +!---------------------------------------------------------------------------- +! Matmul_ +!---------------------------------------------------------------------------- + +INTERFACE + MODULE PURE SUBROUTINE matmul_r1_r4_(a1, a2, ans, dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a1(:) + REAL(DFP), INTENT(IN) :: a2(:, :, :, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE matmul_r1_r4_ +END INTERFACE + +INTERFACE MATMUL_ + MODULE PROCEDURE matmul_r1_r4_ +END INTERFACE MATMUL_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -END MODULE MatmulUtility \ No newline at end of file +END MODULE MatmulUtility + diff --git a/src/modules/Utility/src/MiscUtility.F90 b/src/modules/Utility/src/MiscUtility.F90 index b50d156f3..0adca15e7 100644 --- a/src/modules/Utility/src/MiscUtility.F90 +++ b/src/modules/Utility/src/MiscUtility.F90 @@ -33,6 +33,9 @@ MODULE MiscUtility PUBLIC :: IMAXLOC PUBLIC :: IMINLOC PUBLIC :: IMG +PUBLIC :: LOC_NearestPoint +PUBLIC :: safe_ACOS +PUBLIC :: safe_ASIN !---------------------------------------------------------------------------- ! Radian@MISC @@ -126,8 +129,6 @@ MODULE FUNCTION Loc_Nearest_Point(Array, x) RESULT(id) MODULE PROCEDURE Loc_Nearest_Point END INTERFACE LOC_NearestPoint -PUBLIC :: LOC_NearestPoint - INTERFACE SearchNearestCoord MODULE PROCEDURE Loc_Nearest_Point END INTERFACE SearchNearestCoord @@ -254,21 +255,21 @@ MODULE PURE FUNCTION arth_i(first, increment, n) INTERFACE MODULE PURE FUNCTION outerdiff_r(a, b) REAL(SP), DIMENSION(:), INTENT(IN) :: a, b - REAL(SP), DIMENSION(size(a), size(b)) :: outerdiff_r + REAL(SP), DIMENSION(SIZE(a), SIZE(b)) :: outerdiff_r END FUNCTION END INTERFACE INTERFACE MODULE PURE FUNCTION outerdiff_d(a, b) REAL(DP), DIMENSION(:), INTENT(IN) :: a, b - REAL(DP), DIMENSION(size(a), size(b)) :: outerdiff_d + REAL(DP), DIMENSION(SIZE(a), SIZE(b)) :: outerdiff_d END FUNCTION END INTERFACE INTERFACE MODULE PURE FUNCTION outerdiff_i(a, b) INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a, b - INTEGER(I4B), DIMENSION(size(a), size(b)) :: outerdiff_i + INTEGER(I4B), DIMENSION(SIZE(a), SIZE(b)) :: outerdiff_i END FUNCTION END INTERFACE @@ -323,8 +324,8 @@ MODULE FUNCTION iminloc_r(arr) INTERFACE MODULE ELEMENTAL FUNCTION IMG_1(x) RESULT(ans) - COMPLEX(Real32), INTENT(IN) :: x - REAL(Real32) :: ans + COMPLEX(REAL32), INTENT(IN) :: x + REAL(REAL32) :: ans END FUNCTION IMG_1 END INTERFACE @@ -342,8 +343,8 @@ END FUNCTION IMG_1 INTERFACE MODULE ELEMENTAL FUNCTION IMG_2(x) RESULT(ans) - COMPLEX(Real64), INTENT(IN) :: x - REAL(Real64) :: ans + COMPLEX(REAL64), INTENT(IN) :: x + REAL(REAL64) :: ans END FUNCTION IMG_2 END INTERFACE @@ -362,8 +363,6 @@ MODULE ELEMENTAL FUNCTION safe_ACOS(c) RESULT(ans) END FUNCTION safe_ACOS END INTERFACE -PUBLIC :: safe_ACOS - !---------------------------------------------------------------------------- ! safe_ASIN !---------------------------------------------------------------------------- @@ -375,8 +374,6 @@ MODULE ELEMENTAL FUNCTION safe_ASIN(s) RESULT(ans) END FUNCTION safe_ASIN END INTERFACE -PUBLIC :: safe_ASIN - !---------------------------------------------------------------------------- ! Factorial@MISC !---------------------------------------------------------------------------- diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90 index b076bf7ea..1e0d9269c 100644 --- a/src/modules/Utility/src/ProductUtility.F90 +++ b/src/modules/Utility/src/ProductUtility.F90 @@ -24,42 +24,52 @@ MODULE ProductUtility PUBLIC :: OuterProd PUBLIC :: OuterProd_ - PUBLIC :: OTimesTilda - +PUBLIC :: OTimesTilda_ PUBLIC :: Cross_Product PUBLIC :: Vector_Product PUBLIC :: VectorProduct !---------------------------------------------------------------------------- -! OTimesTilda@Methods +! OTimesTilda !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2024-08-13 ! summary: returns a space-time matrix from time and space matrix -INTERFACE OTimesTilda - MODULE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale) +INTERFACE + MODULE PURE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale) REAL(DFP), INTENT(IN) :: a(:, :) + !! time matrix REAL(DFP), INTENT(IN) :: b(:, :) + !! space matrix REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! space time matix in DOF Format INTEGER(I4B), INTENT(OUT) :: nrow, ncol REAL(DFP), INTENT(IN) :: anscoeff REAL(DFP), INTENT(IN) :: scale END SUBROUTINE OTimesTilda1 +END INTERFACE + +INTERFACE OTimesTilda + MODULE PROCEDURE OTimesTilda1 END INTERFACE OTimesTilda +INTERFACE OTimesTilda_ + MODULE PROCEDURE OTimesTilda1 +END INTERFACE OTimesTilda_ + !---------------------------------------------------------------------------- -! OtimesTilda@Methods +! OtimesTilda !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 2024-08-13 -! summary: returns a space-time vector from time and space vector +! summary: returns a space-time vector from time and space vector -INTERFACE OTimesTilda - MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) +INTERFACE + MODULE PURE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(INOUT) :: ans(:) @@ -67,10 +77,49 @@ MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale) REAL(DFP), INTENT(IN) :: anscoeff REAL(DFP), INTENT(IN) :: scale END SUBROUTINE OTimesTilda2 +END INTERFACE + +INTERFACE OTimesTilda + MODULE PROCEDURE OTimesTilda2 +END INTERFACE OTimesTilda + +INTERFACE OTimesTilda_ + MODULE PROCEDURE OTimesTilda2 +END INTERFACE OTimesTilda_ + +!---------------------------------------------------------------------------- +! OTimesTilda +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2024-08-13 +! summary: returns a space-time matrix from time and space matrix + +INTERFACE + MODULE PURE SUBROUTINE OTimesTilda3(a, b, c, d, ans, nrow, ncol, & + anscoeff, scale) + REAL(DFP), INTENT(IN) :: a(:), b(:) + !! time matrix + REAL(DFP), INTENT(IN) :: c(:), d(:) + !! space matrix + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! space time matix in DOF Format + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + REAL(DFP), INTENT(IN) :: anscoeff + REAL(DFP), INTENT(IN) :: scale + END SUBROUTINE OTimesTilda3 +END INTERFACE + +INTERFACE OTimesTilda + MODULE PROCEDURE OTimesTilda3 END INTERFACE OTimesTilda +INTERFACE OTimesTilda_ + MODULE PROCEDURE OTimesTilda3 +END INTERFACE OTimesTilda_ + !---------------------------------------------------------------------------- -! Cross_Product@ProductMethods +! Cross_Product !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -81,20 +130,24 @@ END SUBROUTINE OTimesTilda2 ! This FUNCTION evaluate vectors products ! $$\mathbf{ans} = \mathbf{a} \times \mathbf{b}$$ -INTERFACE Vector_Product +INTERFACE MODULE PURE FUNCTION vectorProduct_1(a, b) RESULT(c) ! Define INTENT of dummy argument REAL(REAL64), INTENT(IN) :: a(3), b(3) REAL(REAL64) :: c(3) END FUNCTION vectorProduct_1 -END INTERFACE Vector_Product +END INTERFACE -INTERFACE Vector_Product +INTERFACE MODULE PURE FUNCTION vectorProduct_2(a, b) RESULT(c) ! Define INTENT of dummy argument REAL(REAL32), INTENT(IN) :: a(3), b(3) REAL(REAL32) :: c(3) END FUNCTION vectorProduct_2 +END INTERFACE + +INTERFACE Vector_Product + MODULE PROCEDURE vectorProduct_1, vectorProduct_2 END INTERFACE Vector_Product INTERFACE Cross_Product @@ -106,25 +159,33 @@ END FUNCTION vectorProduct_2 END INTERFACE VectorProduct !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 22 March 2021 -! summary: This FUNCTION returns OuterProduct(matrix) of two vectors +! date: 22 March 2021 +! summary: This FUNCTION returns OuterProduct(matrix) of two vectors ! !# Introduction ! ! $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1(a, b) RESULT(ans) REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans END FUNCTION OuterProd_r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1 END INTERFACE OuterProd -INTERFACE OuterProd_ +!---------------------------------------------------------------------------- +! OuterProd_ +!---------------------------------------------------------------------------- + +INTERFACE MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, & ncol) REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b @@ -138,10 +199,14 @@ MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, & INTEGER(I4B), INTENT(OUT) :: nrow, ncol !! number of data written in ans END SUBROUTINE OuterProd_r1r1_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r1r1_ END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -154,16 +219,24 @@ END SUBROUTINE OuterProd_r1r1_ ! - $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$ ! - If `sym` is .true. THEN symmetric part is returned -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1s(a, b, sym) RESULT(ans) ! Define INTENT of dummy variables REAL(DFP), INTENT(IN) :: a(:), b(:) REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans LOGICAL(LGT), INTENT(IN) :: sym END FUNCTION OuterProd_r1r1s +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1s END INTERFACE OuterProd -INTERFACE OuterProd_ +!---------------------------------------------------------------------------- +! OuterProd_ +!---------------------------------------------------------------------------- + +INTERFACE MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, & nrow, ncol) ! Define INTENT of dummy variables @@ -174,10 +247,14 @@ MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, & REAL(DFP), INTENT(INOUT) :: ans(:, :) INTEGER(I4B), INTENT(OUT) :: nrow, ncol END SUBROUTINE OuterProd_r1r1s_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r1r1s_ END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -185,19 +262,27 @@ END SUBROUTINE OuterProd_r1r1s_ ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2)) END FUNCTION OuterProd_r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2 END INTERFACE OuterProd +!---------------------------------------------------------------------------- +! OuterProd_ +!---------------------------------------------------------------------------- + !> author: Shion Shimizu ! date: 2025-03-05 ! summary: a x b -INTERFACE OuterProd_ +INTERFACE MODULE PURE SUBROUTINE OuterProd_r1r2_(a, b, anscoeff, scale, ans, & dim1, dim2, dim3) REAL(DFP), INTENT(IN) :: a(:) @@ -206,10 +291,14 @@ MODULE PURE SUBROUTINE OuterProd_r1r2_(a, b, anscoeff, scale, ans, & REAL(DFP), INTENT(INOUT) :: ans(:, :, :) INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 END SUBROUTINE OuterProd_r1r2_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r1r2_ END INTERFACE OuterProd_ !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -217,16 +306,20 @@ END SUBROUTINE OuterProd_r1r2_ ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3)) END FUNCTION OuterProd_r1r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -234,16 +327,20 @@ END FUNCTION OuterProd_r1r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r4(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :) REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), SIZE(b, 4)) END FUNCTION OuterProd_r1r4 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r4 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -251,38 +348,64 @@ END FUNCTION OuterProd_r1r4 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r5(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :, :) - REAL(DFP) :: ans(& - & SIZE(a),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(b, 4),& - & SIZE(b, 5)) + REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), & + SIZE(b, 4), SIZE(b, 5)) END FUNCTION OuterProd_r1r5 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r5 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. ! date: 22 March 2021 ! summary: This FUNCTION returns OuterProduct -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b)) END FUNCTION OuterProd_r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd_ +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-09-04 +! summary: a x b + +INTERFACE + MODULE PURE SUBROUTINE OuterProd_r2r1_(a, b, anscoeff, scale, ans, & + dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: anscoeff, scale + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + END SUBROUTINE OuterProd_r2r1_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r2r1_ +END INTERFACE OuterProd_ + +!---------------------------------------------------------------------------- +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -290,20 +413,20 @@ END FUNCTION OuterProd_r2r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2)) END FUNCTION OuterProd_r2r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -311,21 +434,45 @@ END FUNCTION OuterProd_r2r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE + MODULE PURE SUBROUTINE OuterProd_r2r2_(a, b, ans, dim1, dim2, dim3, dim4, & + anscoeff, scale) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:, :) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + REAL(DFP), INTENT(IN) :: anscoeff, scale + END SUBROUTINE OuterProd_r2r2_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r2r2_ +END INTERFACE OuterProd_ + +!---------------------------------------------------------------------------- +! OuterProd +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-12-19 +! update: 2021-12-19 +! summary: a x b + +INTERFACE MODULE PURE FUNCTION OuterProd_r2r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), & + SIZE(b, 3)) END FUNCTION OuterProd_r2r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -333,22 +480,21 @@ END FUNCTION OuterProd_r2r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r4(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(b, 4)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), & + SIZE(b, 3), SIZE(b, 4)) END FUNCTION OuterProd_r2r4 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r4 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -356,20 +502,20 @@ END FUNCTION OuterProd_r2r4 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP) :: ans(& - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b)) END FUNCTION OuterProd_r3r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -377,21 +523,21 @@ END FUNCTION OuterProd_r3r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP) :: ans(& - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(b, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), & + SIZE(b, 2)) END FUNCTION OuterProd_r3r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -399,22 +545,21 @@ END FUNCTION OuterProd_r3r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r3(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:, :, :) - REAL(DFP) :: ans(& - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), & + SIZE(b, 2), SIZE(b, 3)) END FUNCTION OuterProd_r3r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -422,21 +567,21 @@ END FUNCTION OuterProd_r3r3 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r4r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :) REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP) :: ans(& - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(a, 4),& - & SIZE(b, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), & + SIZE(b, 1)) END FUNCTION OuterProd_r4r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r4r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -444,22 +589,21 @@ END FUNCTION OuterProd_r4r1 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r4r2(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :) REAL(DFP), INTENT(IN) :: b(:, :) - REAL(DFP) :: ans(& - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(a, 4),& - & SIZE(b, 1),& - & SIZE(b, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), & + SIZE(b, 1), SIZE(b, 2)) END FUNCTION OuterProd_r4r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r4r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@ProductMethods +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -467,22 +611,21 @@ END FUNCTION OuterProd_r4r2 ! update: 2021-12-19 ! summary: a x b -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r5r1(a, b) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :, :) REAL(DFP), INTENT(IN) :: b(:) - REAL(DFP) :: ans(& - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(a, 4),& - & SIZE(a, 5),& - & SIZE(b, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), & + SIZE(a, 5), SIZE(b, 1)) END FUNCTION OuterProd_r5r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r5r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -490,20 +633,21 @@ END FUNCTION OuterProd_r5r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1)) END FUNCTION OuterProd_r1r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -511,21 +655,46 @@ END FUNCTION OuterProd_r1r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE + MODULE PURE SUBROUTINE OuterProd_r1r1r1_( & + a, b, c, anscoeff, scale, ans, dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + REAL(DFP), INTENT(IN) :: anscoeff, scale + END SUBROUTINE OuterProd_r1r1r1_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r1r1r1_ +END INTERFACE OuterProd_ + +!---------------------------------------------------------------------------- +! OuterProd +!---------------------------------------------------------------------------- + +!> 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)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2)) END FUNCTION OuterProd_r1r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -533,22 +702,47 @@ END FUNCTION OuterProd_r1r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE + MODULE PURE SUBROUTINE OuterProd_r1r1r2_( & + a, b, c, anscoeff, scale, ans, dim1, dim2, dim3, dim4) + REAL(DFP), INTENT(IN) :: a(:) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:, :) + REAL(DFP), INTENT(IN) :: anscoeff, scale + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + END SUBROUTINE OuterProd_r1r1r2_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r1r1r2_ +END INTERFACE OuterProd_ + +!---------------------------------------------------------------------------- +! OuterProd +!---------------------------------------------------------------------------- + +!> 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)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), & + SIZE(c, 3)) END FUNCTION OuterProd_r1r1r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -556,23 +750,22 @@ END FUNCTION OuterProd_r1r1r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r4(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3),& - & SIZE(c, 4)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), & + SIZE(c, 3), SIZE(c, 4)) END FUNCTION OuterProd_r1r1r4 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r4 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -580,21 +773,21 @@ END FUNCTION OuterProd_r1r1r4 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1)) END FUNCTION OuterProd_r1r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -602,22 +795,22 @@ END FUNCTION OuterProd_r1r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), & + SIZE(c, 2)) END FUNCTION OuterProd_r1r2r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -625,23 +818,22 @@ END FUNCTION OuterProd_r1r2r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2r3(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), & + SIZE(c, 2), SIZE(c, 3)) END FUNCTION OuterProd_r1r2r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -649,22 +841,22 @@ END FUNCTION OuterProd_r1r2r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r3r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), & + SIZE(c, 1)) END FUNCTION OuterProd_r1r3r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r3r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -672,23 +864,22 @@ END FUNCTION OuterProd_r1r3r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r3r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(c, 1),& - & SIZE(c, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), & + SIZE(c, 1), SIZE(c, 2)) END FUNCTION OuterProd_r1r3r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r3r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -696,23 +887,22 @@ END FUNCTION OuterProd_r1r3r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r4r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :, :) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(b, 4),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), & + SIZE(b, 4), SIZE(c, 1)) END FUNCTION OuterProd_r1r4r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r4r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -720,21 +910,21 @@ END FUNCTION OuterProd_r1r4r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1)) END FUNCTION OuterProd_r2r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd_ !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -742,22 +932,47 @@ END FUNCTION OuterProd_r2r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE + MODULE PURE SUBROUTINE OuterProd_r2r1r1_(a, b, c, ans, dim1, dim2, dim3, & + dim4, scale, anscoeff) + REAL(DFP), INTENT(IN) :: a(:, :) + REAL(DFP), INTENT(IN) :: b(:) + REAL(DFP), INTENT(IN) :: c(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + REAL(DFP), INTENT(IN) :: scale, anscoeff + END SUBROUTINE OuterProd_r2r1r1_ +END INTERFACE + +INTERFACE OuterProd_ + MODULE PROCEDURE OuterProd_r2r1r1_ +END INTERFACE OuterProd_ + +!---------------------------------------------------------------------------- +! OuterProd +!---------------------------------------------------------------------------- + +!> 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)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), & + SIZE(c, 2)) END FUNCTION OuterProd_r2r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -765,23 +980,22 @@ END FUNCTION OuterProd_r2r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1r3(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), & + SIZE(c, 2), SIZE(c, 3)) END FUNCTION OuterProd_r2r1r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -789,22 +1003,22 @@ END FUNCTION OuterProd_r2r1r3 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r2r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), & + SIZE(c, 1)) END FUNCTION OuterProd_r2r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -812,23 +1026,22 @@ END FUNCTION OuterProd_r2r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r2r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), & + SIZE(c, 1), SIZE(c, 2)) END FUNCTION OuterProd_r2r2r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r2r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -836,22 +1049,22 @@ END FUNCTION OuterProd_r2r2r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), & + SIZE(c, 1)) END FUNCTION OuterProd_r3r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -859,23 +1072,22 @@ END FUNCTION OuterProd_r3r1r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r1r2(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), & + SIZE(c, 1), SIZE(c, 2)) END FUNCTION OuterProd_r3r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -883,23 +1095,22 @@ END FUNCTION OuterProd_r3r1r2 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r2r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), & + SIZE(b, 2), SIZE(c, 1)) END FUNCTION OuterProd_r3r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -907,23 +1118,22 @@ END FUNCTION OuterProd_r3r2r1 ! update: 2021-12-19 ! summary: a b c -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r4r1r1(a, b, c) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(a, 4),& - & SIZE(b, 1),& - & SIZE(c, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), & + SIZE(b, 1), SIZE(c, 1)) END FUNCTION OuterProd_r4r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r4r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -931,22 +1141,22 @@ END FUNCTION OuterProd_r4r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(d, 1)) END FUNCTION OuterProd_r1r1r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -954,23 +1164,23 @@ END FUNCTION OuterProd_r1r1r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r1r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(d, 1),& - & SIZE(d, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(d, 1), & + SIZE(d, 2)) END FUNCTION OuterProd_r1r1r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -978,24 +1188,23 @@ END FUNCTION OuterProd_r1r1r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r1r3(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:, :, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(d, 1),& - & SIZE(d, 2),& - & SIZE(d, 3)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(d, 1), & + SIZE(d, 2), SIZE(d, 3)) END FUNCTION OuterProd_r1r1r1r3 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r1r3 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1003,23 +1212,23 @@ END FUNCTION OuterProd_r1r1r1r3 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r2r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), & + SIZE(d, 1)) END FUNCTION OuterProd_r1r1r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1027,24 +1236,23 @@ END FUNCTION OuterProd_r1r1r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r2r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) REAL(DFP), INTENT(IN) :: d(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(d, 1),& - & SIZE(d, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), & + SIZE(d, 1), SIZE(d, 2)) END FUNCTION OuterProd_r1r1r2r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r2r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1052,24 +1260,23 @@ END FUNCTION OuterProd_r1r1r2r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r1r3r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :, :) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(c, 3),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), & + SIZE(c, 3), SIZE(d, 1)) END FUNCTION OuterProd_r1r1r3r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r1r3r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1077,23 +1284,23 @@ END FUNCTION OuterProd_r1r1r3r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), & + SIZE(d, 1)) END FUNCTION OuterProd_r1r2r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1101,24 +1308,23 @@ END FUNCTION OuterProd_r1r2r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2r1r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(d, 1),& - & SIZE(d, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), & + SIZE(d, 1), SIZE(d, 2)) END FUNCTION OuterProd_r1r2r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1126,24 +1332,23 @@ END FUNCTION OuterProd_r1r2r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r2r2r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:, :) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), & + SIZE(c, 2), SIZE(d, 1)) END FUNCTION OuterProd_r1r2r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r2r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1151,24 +1356,23 @@ END FUNCTION OuterProd_r1r2r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r1r3r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:) REAL(DFP), INTENT(IN) :: b(:, :, :) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(b, 3),& - & SIZE(c, 1),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), & + SIZE(c, 1), SIZE(d, 1)) END FUNCTION OuterProd_r1r3r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r1r3r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1176,23 +1380,23 @@ END FUNCTION OuterProd_r1r3r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), & + SIZE(d, 1)) END FUNCTION OuterProd_r2r1r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1200,24 +1404,23 @@ END FUNCTION OuterProd_r2r1r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1r1r2(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:, :) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(d, 1),& - & SIZE(d, 2)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), & + SIZE(d, 1), SIZE(d, 2)) END FUNCTION OuterProd_r2r1r1r2 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1r1r2 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1225,24 +1428,23 @@ END FUNCTION OuterProd_r2r1r1r2 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r1r2r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:, :) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(c, 2),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), & + SIZE(c, 2), SIZE(d, 1)) END FUNCTION OuterProd_r2r1r2r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r1r2r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1250,24 +1452,23 @@ END FUNCTION OuterProd_r2r1r2r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r2r2r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :) REAL(DFP), INTENT(IN) :: b(:, :) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(b, 1),& - & SIZE(b, 2),& - & SIZE(c, 1),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), & + SIZE(c, 1), SIZE(d, 1)) END FUNCTION OuterProd_r2r2r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r2r2r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- -! OuterProd@PROD +! OuterProd !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -1275,20 +1476,19 @@ END FUNCTION OuterProd_r2r2r1r1 ! update: 2021-12-19 ! summary: a b c d -INTERFACE OuterProd +INTERFACE MODULE PURE FUNCTION OuterProd_r3r1r1r1(a, b, c, d) RESULT(ans) REAL(DFP), INTENT(IN) :: a(:, :, :) REAL(DFP), INTENT(IN) :: b(:) REAL(DFP), INTENT(IN) :: c(:) REAL(DFP), INTENT(IN) :: d(:) - REAL(DFP) :: ans( & - & SIZE(a, 1),& - & SIZE(a, 2),& - & SIZE(a, 3),& - & SIZE(b, 1),& - & SIZE(c, 1),& - & SIZE(d, 1)) + REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), & + SIZE(c, 1), SIZE(d, 1)) END FUNCTION OuterProd_r3r1r1r1 +END INTERFACE + +INTERFACE OuterProd + MODULE PROCEDURE OuterProd_r3r1r1r1 END INTERFACE OuterProd !---------------------------------------------------------------------------- diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90 index 8d9f989f7..08bcb9b63 100644 --- a/src/modules/Utility/src/ReallocateUtility.F90 +++ b/src/modules/Utility/src/ReallocateUtility.F90 @@ -111,7 +111,8 @@ END SUBROUTINE Reallocate_Real32_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R2(mat, row, col, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real64_R2(mat, row, col, isExpand, & + expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -143,7 +144,8 @@ END SUBROUTINE Reallocate_Real64_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R2(mat, row, col, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real32_R2(mat, row, col, isExpand, & + expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -175,7 +177,8 @@ END SUBROUTINE Reallocate_Real32_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R3(mat, i1, i2, i3, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real64_R3(mat, i1, i2, i3, isExpand, & + expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -207,7 +210,8 @@ END SUBROUTINE Reallocate_Real64_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R3(mat, i1, i2, i3, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real32_R3(mat, i1, i2, i3, isExpand, & + expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -239,7 +243,8 @@ END SUBROUTINE Reallocate_Real32_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real64_R4(mat, i1, i2, i3, i4, isExpand, & + expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -271,7 +276,8 @@ END SUBROUTINE Reallocate_Real64_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real32_R4(mat, i1, i2, i3, i4, isExpand, & + expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -303,7 +309,8 @@ END SUBROUTINE Reallocate_Real32_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real64_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real64_R5(mat, i1, i2, i3, i4, i5, & + isExpand, expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -335,7 +342,8 @@ END SUBROUTINE Reallocate_Real64_R5b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real32_R5(mat, i1, i2, i3, i4, i5, & + isExpand, expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -400,7 +408,8 @@ END SUBROUTINE Reallocate_Real64_R6b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Real32_R6(mat, i1, i2, i3, i4, i5, i6, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Real32_R6(mat, i1, i2, i3, i4, i5, i6, & + isExpand, expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -630,7 +639,8 @@ END SUBROUTINE Reallocate_Int8_R1b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R2(mat, row, col, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int64_R2(mat, row, col, isExpand, & + expandFactor) INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -650,7 +660,8 @@ MODULE PURE SUBROUTINE Reallocate_Int64_R2b(mat, s, isExpand, expandFactor) INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int64_R2b - MODULE PURE SUBROUTINE Reallocate_Int32_R2(mat, row, col, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int32_R2(mat, row, col, isExpand, & + expandFactor) INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -670,7 +681,8 @@ MODULE PURE SUBROUTINE Reallocate_Int32_R2b(mat, s, isExpand, expandFactor) INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int32_R2b - MODULE PURE SUBROUTINE Reallocate_Int16_R2(mat, row, col, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int16_R2(mat, row, col, isExpand, & + expandFactor) INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -690,7 +702,8 @@ MODULE PURE SUBROUTINE Reallocate_Int16_R2b(mat, s, isExpand, expandFactor) INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor END SUBROUTINE Reallocate_Int16_R2b - MODULE PURE SUBROUTINE Reallocate_Int8_R2(mat, row, col, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int8_R2(mat, row, col, isExpand, & + expandFactor) INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:, :) INTEGER(I4B), INTENT(IN) :: row, col LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -716,7 +729,8 @@ END SUBROUTINE Reallocate_Int8_R2b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R3(mat, i1, i2, i3, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int64_R3(mat, i1, i2, i3, isExpand, & + expandFactor) INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -748,7 +762,8 @@ END SUBROUTINE Reallocate_Int64_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R3(mat, i1, i2, i3, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int32_R3(mat, i1, i2, i3, isExpand, & + expandFactor) INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -780,8 +795,8 @@ END SUBROUTINE Reallocate_Int32_R3b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int64_R4(mat, i1, & - i2, i3, i4, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int64_R4(mat, i1, i2, i3, i4, isExpand, & + expandFactor) INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -813,7 +828,8 @@ END SUBROUTINE Reallocate_Int64_R4b !---------------------------------------------------------------------------- INTERFACE Reallocate - MODULE PURE SUBROUTINE Reallocate_Int32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor) + MODULE PURE SUBROUTINE Reallocate_Int32_R4(mat, i1, i2, i3, i4, isExpand, & + expandFactor) INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -978,7 +994,7 @@ END SUBROUTINE Reallocate_Int32_R6b INTERFACE Reallocate MODULE PURE SUBROUTINE Reallocate_Int64_R7(mat, i1, i2, i3, i4, i5, & - & i6, i7, isExpand, expandFactor) + i6, i7, isExpand, expandFactor) INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :) INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7 LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand @@ -1044,7 +1060,8 @@ END SUBROUTINE Reallocate_Int32_R7b INTERFACE Reallocate MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(vec1, n1, vec2, n2, vec3, & - n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor) + n3, vec4, n4, vec5, n5, vec6, & + n6, isExpand, expandFactor) INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:) INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), & vec4(:), vec5(:), vec6(:) @@ -1064,7 +1081,9 @@ END SUBROUTINE Reallocate_Int32_R1_6 INTERFACE Reallocate MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(vec1, n1, vec2, & - n2, vec3, n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor) + n2, vec3, n3, vec4, n4, & + vec5, n5, vec6, n6, & + isExpand, expandFactor) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:) REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), & vec4(:), vec5(:), vec6(:) @@ -1084,7 +1103,9 @@ END SUBROUTINE Reallocate_Real64_R1_6 INTERFACE Reallocate MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(vec1, n1, vec2, & - n2, vec3, n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor) + n2, vec3, n3, vec4, & + n4, vec5, n5, vec6, & + n6, isExpand, expandFactor) REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:) REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), & vec4(:), vec5(:), vec6(:) diff --git a/src/modules/Utility/src/ReverseUtility.F90 b/src/modules/Utility/src/ReverseUtility.F90 new file mode 100644 index 000000000..2390c37af --- /dev/null +++ b/src/modules/Utility/src/ReverseUtility.F90 @@ -0,0 +1,255 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +MODULE ReverseUtility +USE GlobalData, ONLY: I4B, DFP, LGT, REAL32, REAL64, INT8, INT16, INT32, & + INT64 +IMPLICIT NONE + +PRIVATE + +PUBLIC :: Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of an integer array + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int8_R1(ans, n1, n2) + INTEGER(INT8), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + END SUBROUTINE Reverse_Int8_R1 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of an integer array + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int16_R1(ans, n1, n2) + INTEGER(INT16), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + END SUBROUTINE Reverse_Int16_R1 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of an integer array + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int32_R1(ans, n1, n2) + INTEGER(INT32), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + END SUBROUTINE Reverse_Int32_R1 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of an integer array + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int64_R1(ans, n1, n2) + INTEGER(INT64), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + END SUBROUTINE Reverse_Int64_R1 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a real array + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Real32_R1(ans, n1, n2) + REAL(REAL32), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + END SUBROUTINE Reverse_Real32_R1 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a real array + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Real64_R1(ans, n1, n2) + REAL(REAL64), INTENT(INOUT) :: ans(:) + INTEGER(I4B), INTENT(IN) :: n1, n2 + END SUBROUTINE Reverse_Real64_R1 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a integer matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int8_R2(ans, r1, r2, c1, c2, dim) + INTEGER(INT8), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2 + !! Extent of ans(r1:r2, c1:c2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the rows + !! dim=2, reverse the columns + END SUBROUTINE Reverse_Int8_R2 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a integer matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int16_R2(ans, r1, r2, c1, c2, dim) + INTEGER(INT16), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2 + !! Extent of ans(r1:r2, c1:c2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the rows + !! dim=2, reverse the columns + END SUBROUTINE Reverse_Int16_R2 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a integer matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int32_R2(ans, r1, r2, c1, c2, dim) + INTEGER(INT32), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2 + !! Extent of ans(r1:r2, c1:c2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the rows + !! dim=2, reverse the columns + END SUBROUTINE Reverse_Int32_R2 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a integer matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Int64_R2(ans, r1, r2, c1, c2, dim) + INTEGER(INT64), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2 + !! Extent of ans(r1:r2, c1:c2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the rows + !! dim=2, reverse the columns + END SUBROUTINE Reverse_Int64_R2 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a real matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Real32_R2(ans, r1, r2, c1, c2, dim) + REAL(REAL32), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2 + !! Extent of ans(r1:r2, c1:c2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the rows + !! dim=2, reverse the columns + END SUBROUTINE Reverse_Real32_R2 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a real matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Real64_R2(ans, r1, r2, c1, c2, dim) + REAL(REAL64), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2 + !! Extent of ans(r1:r2, c1:c2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the rows + !! dim=2, reverse the columns + END SUBROUTINE Reverse_Real64_R2 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! Reverse@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: This function reverses the elements of a real matrix + +INTERFACE Reverse + MODULE SUBROUTINE Reverse_Real64_R3(ans, r1, r2, c1, c2, d1, d2, dim) + REAL(REAL64), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2, d1, d2 + !! Extent of ans(r1:r2, c1:c2, d1:d2) + INTEGER(I4B), INTENT(IN) :: dim + !! dim=1, reverse the dim1 + !! dim=2, reverse the dim2 + !! dim=3, reverse the dim3 + END SUBROUTINE Reverse_Real64_R3 +END INTERFACE Reverse + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END MODULE ReverseUtility diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90 index 0304fc55f..3b83c1246 100644 --- a/src/modules/Utility/src/SwapUtility.F90 +++ b/src/modules/Utility/src/SwapUtility.F90 @@ -19,6 +19,10 @@ MODULE SwapUtility USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, & DFPC, LGT, I4B +#ifdef USE_BLAS95 +USE F95_BLAS, ONLY: SWAP +#endif + IMPLICIT NONE PRIVATE @@ -27,7 +31,7 @@ MODULE SwapUtility PUBLIC :: Swap_ !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -38,19 +42,52 @@ MODULE SwapUtility MODULE PURE SUBROUTINE Swap_Int8(a, b) INTEGER(INT8), INTENT(INOUT) :: a, b END SUBROUTINE Swap_Int8 +END INTERFACE swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two integer + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int16(a, b) INTEGER(INT16), INTENT(INOUT) :: a, b END SUBROUTINE Swap_Int16 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two integer + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int32(a, b) INTEGER(INT32), INTENT(INOUT) :: a, b END SUBROUTINE Swap_Int32 +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two integer + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int64(a, b) INTEGER(INT64), INTENT(INOUT) :: a, b END SUBROUTINE Swap_Int64 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -64,7 +101,7 @@ END SUBROUTINE Swap_r32 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -78,7 +115,7 @@ END SUBROUTINE Swap_r64 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -90,7 +127,19 @@ END SUBROUTINE Swap_r64 MODULE PURE SUBROUTINE Swap_r32v(a, b) REAL(REAL32), INTENT(INOUT) :: a(:), b(:) END SUBROUTINE Swap_r32v +END INTERFACE Swap +#endif +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two vectors of real, if blas95 is used then ignore it. + +#ifndef USE_BLAS95 +INTERFACE Swap MODULE PURE SUBROUTINE Swap_r64v(a, b) REAL(REAL64), INTENT(INOUT) :: a(:), b(:) END SUBROUTINE Swap_r64v @@ -98,7 +147,7 @@ END SUBROUTINE Swap_r64v #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -109,21 +158,58 @@ END SUBROUTINE Swap_r64v MODULE PURE SUBROUTINE Swap_Int8v(a, b) INTEGER(INT8), INTENT(INOUT) :: a(:), b(:) END SUBROUTINE Swap_Int8v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two vectors of real, if blas95 is used then ignore it. + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int16v(a, b) INTEGER(INT16), INTENT(INOUT) :: a(:), b(:) END SUBROUTINE Swap_Int16v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two vectors of real, if blas95 is used then ignore it. + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int32v(a, b) INTEGER(INT32), INTENT(INOUT) :: a(:), b(:) END SUBROUTINE Swap_Int32v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two vectors of real, if blas95 is used then ignore it. + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int64v(a, b) INTEGER(INT64), INTENT(INOUT) :: a(:), b(:) END SUBROUTINE Swap_Int64v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two vectors of real, if blas95 is used then ignore it. + #ifdef USE_Int128 INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int128v(a, b) @@ -133,7 +219,7 @@ END SUBROUTINE Swap_Int128v #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -147,9 +233,13 @@ END SUBROUTINE Swap_c END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two vectors of complex numbers, if blas95 is used ignore it. + #ifndef USE_BLAS95 INTERFACE Swap MODULE PURE SUBROUTINE Swap_cv(a, b) @@ -159,9 +249,13 @@ END SUBROUTINE Swap_cv #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 22 March 2021 +! summary: Swap two matrix + INTERFACE Swap MODULE PURE SUBROUTINE Swap_cm(a, b) COMPLEX(DFPC), INTENT(INOUT) :: a(:, :), b(:, :) @@ -169,7 +263,7 @@ END SUBROUTINE Swap_cm END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -183,7 +277,7 @@ END SUBROUTINE Swap_r32m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -197,7 +291,7 @@ END SUBROUTINE Swap_r64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -208,24 +302,58 @@ END SUBROUTINE Swap_r64m MODULE PURE SUBROUTINE Swap_Int8m(a, b) INTEGER(INT8), INTENT(INOUT) :: a(:, :), b(:, :) END SUBROUTINE Swap_Int8m +END INTERFACE Swap +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrix + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int16m(a, b) INTEGER(INT16), INTENT(INOUT) :: a(:, :), b(:, :) END SUBROUTINE Swap_Int16m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrix + +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int32m(a, b) INTEGER(INT32), INTENT(INOUT) :: a(:, :), b(:, :) END SUBROUTINE Swap_Int32m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrix +INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int64m(a, b) INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :) END SUBROUTINE Swap_Int64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrix + #ifdef USE_Int128 INTERFACE Swap MODULE PURE SUBROUTINE Swap_Int128m(a, b) @@ -235,12 +363,12 @@ END SUBROUTINE Swap_Int128m #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. -! date: 2023-06-27 -! summary: Swap two scalars with masking +! date: 2023-06-27 +! summary: Swap two scalars with masking INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_r32s(a, b, mask) @@ -250,7 +378,7 @@ END SUBROUTINE masked_Swap_r32s END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -265,7 +393,7 @@ END SUBROUTINE masked_Swap_r64s END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -277,17 +405,47 @@ MODULE PURE SUBROUTINE masked_Swap_Int8s(a, b, mask) INTEGER(INT8), INTENT(INOUT) :: a, b LOGICAL(LGT), INTENT(IN) :: mask END SUBROUTINE masked_Swap_Int8s +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int16s(a, b, mask) INTEGER(INT16), INTENT(INOUT) :: a, b LOGICAL(LGT), INTENT(IN) :: mask END SUBROUTINE masked_Swap_Int16s +END INTERFACE Swap +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int32s(a, b, mask) INTEGER(INT32), INTENT(INOUT) :: a, b LOGICAL(LGT), INTENT(IN) :: mask END SUBROUTINE masked_Swap_Int32s +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2023-06-27 +! summary: Swap two scalars with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int64s(a, b, mask) INTEGER(INT64), INTENT(INOUT) :: a, b LOGICAL(LGT), INTENT(IN) :: mask @@ -295,7 +453,7 @@ END SUBROUTINE masked_Swap_Int64s END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -312,7 +470,7 @@ END SUBROUTINE masked_Swap_Int128s #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -327,7 +485,7 @@ END SUBROUTINE masked_Swap_r32v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -342,7 +500,7 @@ END SUBROUTINE masked_Swap_r64v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -354,17 +512,47 @@ MODULE PURE SUBROUTINE masked_Swap_Int8v(a, b, mask) INTEGER(INT8), INTENT(INOUT) :: a(:), b(:) LOGICAL(LGT), INTENT(IN) :: mask(:) END SUBROUTINE masked_Swap_Int8v +END INTERFACE Swap +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two vectors with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int16v(a, b, mask) INTEGER(INT16), INTENT(INOUT) :: a(:), b(:) LOGICAL(LGT), INTENT(IN) :: mask(:) END SUBROUTINE masked_Swap_Int16v +END INTERFACE Swap +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two vectors with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int32v(a, b, mask) INTEGER(INT32), INTENT(INOUT) :: a(:), b(:) LOGICAL(LGT), INTENT(IN) :: mask(:) END SUBROUTINE masked_Swap_Int32v +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two vectors with masking +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int64v(a, b, mask) INTEGER(INT64), INTENT(INOUT) :: a(:), b(:) LOGICAL(LGT), INTENT(IN) :: mask(:) @@ -372,7 +560,7 @@ END SUBROUTINE masked_Swap_Int64v END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -389,7 +577,7 @@ END SUBROUTINE masked_Swap_Int128v #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -404,7 +592,7 @@ END SUBROUTINE masked_Swap_r32m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -419,7 +607,7 @@ END SUBROUTINE masked_Swap_r64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -431,17 +619,47 @@ MODULE PURE SUBROUTINE masked_Swap_Int8m(a, b, mask) INTEGER(INT8), INTENT(INOUT) :: a(:, :), b(:, :) LOGICAL(LGT), INTENT(IN) :: mask(:, :) END SUBROUTINE masked_Swap_Int8m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrices with masking +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int16m(a, b, mask) INTEGER(INT16), INTENT(INOUT) :: a(:, :), b(:, :) LOGICAL(LGT), INTENT(IN) :: mask(:, :) END SUBROUTINE masked_Swap_Int16m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrices with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int32m(a, b, mask) INTEGER(INT32), INTENT(INOUT) :: a(:, :), b(:, :) LOGICAL(LGT), INTENT(IN) :: mask(:, :) END SUBROUTINE masked_Swap_Int32m +END INTERFACE Swap + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2025-10-14 +! summary: Swap two matrices with masking + +INTERFACE Swap MODULE PURE SUBROUTINE masked_Swap_Int64m(a, b, mask) INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :) LOGICAL(LGT), INTENT(IN) :: mask(:, :) @@ -449,7 +667,7 @@ END SUBROUTINE masked_Swap_Int64m END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -466,7 +684,7 @@ END SUBROUTINE masked_Swap_Int128m #endif !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -497,7 +715,7 @@ END SUBROUTINE Swap_index1 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -529,7 +747,7 @@ END SUBROUTINE Swap_index2 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -557,7 +775,6 @@ MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, i2) !! index 2 is Swapped with index `i2` !! make sure i2 is less than or equal to 2 END SUBROUTINE Swap_index_1 - END INTERFACE Swap_ !---------------------------------------------------------------------------- @@ -580,7 +797,7 @@ END SUBROUTINE Swap_index_2 END INTERFACE Swap_ !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -615,7 +832,7 @@ END SUBROUTINE Swap_index3 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -647,7 +864,25 @@ MODULE PURE SUBROUTINE Swap_index_3(a, b, i1, i2, i3) !! index 3 is Swapped with index `i3` !! make sure i3 is less than or equal to 3 END SUBROUTINE Swap_index_3 +END INTERFACE Swap_ + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-20 +! update: 2021-11-20 +! summary: Swap the index, it is like taking transpose. +! +!# Introduction +! +! - This routine returns an matrix by chaning the dimensions of input matrix +! `b`. +! - This routine does not check the shape, so make sure the shape of +! `a` and `b` are appropriate,. + +INTERFACE Swap_ MODULE PURE SUBROUTINE Swap_index_4(a, b, i1, i2, i3) REAL(REAL64), INTENT(INOUT) :: a(:, :, :) !! the returned array @@ -666,7 +901,7 @@ END SUBROUTINE Swap_index_4 END INTERFACE Swap_ !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -680,7 +915,6 @@ END SUBROUTINE Swap_index_4 ! `b`. ! - This routine does not check the shape, so make sure the shape of ! `a` and `b` are appropriate,. -! INTERFACE Swap MODULE PURE SUBROUTINE Swap_index4(a, b, i1, i2, i3) @@ -701,7 +935,7 @@ END SUBROUTINE Swap_index4 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -738,7 +972,7 @@ END SUBROUTINE Swap_index5 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -775,7 +1009,7 @@ END SUBROUTINE Swap_index6 END INTERFACE Swap !---------------------------------------------------------------------------- -! Swap@SwapMethods +! Swap@Methods !---------------------------------------------------------------------------- !> author: Vikas Sharma, Ph. D. @@ -809,7 +1043,17 @@ MODULE PURE SUBROUTINE Swap_index_5(a, b, i1, i2, i3, i4) !! index 4 is Swapped with index `i4` !! make sure i4 is less than or equal to 4 END SUBROUTINE Swap_index_5 +END INTERFACE Swap_ + +!---------------------------------------------------------------------------- +! Swap@Methods +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 2021-11-20 +! summary: Swap the index, it is like taking transpose. +INTERFACE Swap_ MODULE PURE SUBROUTINE Swap_index_6(a, b, i1, i2, i3, i4) REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :) !! the returned array diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 index 4d3f08049..1353c3479 100644 --- a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 +++ b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 @@ -174,6 +174,29 @@ END IF END PROCEDURE bb_deallocate2 +!---------------------------------------------------------------------------- +! Reallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Reallocate +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tempint + +isok = ALLOCATED(obj) + +IF (.NOT. isok) THEN + ALLOCATE (obj(tsize)) + RETURN +END IF + +tempint = SIZE(obj) +isok = tempint .NE. tsize +IF (isok) THEN + DEALLOCATE (obj) + ALLOCATE (obj(tsize)) +END IF +END PROCEDURE obj_Reallocate + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt index c6af0f192..ac3d6e7fb 100644 --- a/src/submodules/CMakeLists.txt +++ b/src/submodules/CMakeLists.txt @@ -27,6 +27,30 @@ include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt) # Utility include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt) +# Point +include(${CMAKE_CURRENT_LIST_DIR}/Point/CMakeLists.txt) + +# Line +include(${CMAKE_CURRENT_LIST_DIR}/Line/CMakeLists.txt) + +# Triangle +include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt) + +# Quadrangle +include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt) + +# Tetrahedron +include(${CMAKE_CURRENT_LIST_DIR}/Tetrahedron/CMakeLists.txt) + +# Hexahedron +include(${CMAKE_CURRENT_LIST_DIR}/Hexahedron/CMakeLists.txt) + +# Prism +include(${CMAKE_CURRENT_LIST_DIR}/Prism/CMakeLists.txt) + +# Pyramid +include(${CMAKE_CURRENT_LIST_DIR}/Pyramid/CMakeLists.txt) + # Polynomial include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt) @@ -117,6 +141,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/ForceVector/CMakeLists.txt) # STForceVector include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt) +# Projection +include(${CMAKE_CURRENT_LIST_DIR}/Projection/CMakeLists.txt) + # VoigtRank2Tensor include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt) diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 index 15664fcb3..a36bcf6c0 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 @@ -20,24 +20,43 @@ ! summary: It contains method for setting values in [[CSRMatrix_]] SUBMODULE(CSRMatrix_AddMethods) Methods -USE BaseMethod +USE GlobalData, ONLY: FMT_NODES, FMT_DOF, NodesToDOF, DofToNodes +USE DOF_Method, ONLY: GetIndex, GetNodeLoc, OPERATOR(.tdof.), & + GetIndex_, GetNodeLoc_ +USE ConvertUtility, ONLY: Convert, Convert_ +USE CSRSparsity_Method, ONLY: CSR_SetIA => SetIA, CSR_SetJA => SetJA +USE InputUtility, ONLY: Input +USE F95_BLAS, ONLY: Scal, Copy +USE ReallocateUtility, ONLY: Reallocate + +USE CSRMatrix_Method, ONLY: OPERATOR(.StorageFMT.), & + CSRMatrix_GetColIndex => GetColIndex, & + CSRMatrix_Size => Size, & + CSRMatrix_GetNNZ => GetNNZ, & + CSRMatrixAPLSB, & + CSRMatrixAPLSBSorted + IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = __FILE__ +#endif + CONTAINS !---------------------------------------------------------------------------- ! AddContribution !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_Add0 +MODULE PROCEDURE AddMaster1 ! Internal variables -INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk +INTEGER(I4B) :: ii, jj, kk, trow, tcol -row = getIndex(obj=obj%csr%idof, nodeNum=nodenum) -col = getIndex(obj=obj%csr%jdof, nodeNum=nodenum) +trow = SIZE(row) +tcol = SIZE(col) -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) +DO ii = 1, trow + DO kk = 1, tcol DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 IF (obj%csr%JA(jj) .EQ. col(kk)) THEN obj%A(jj) = obj%A(jj) + scale * VALUE(ii, kk) @@ -46,10 +65,61 @@ END DO END DO END DO + +END PROCEDURE AddMaster1 + +!---------------------------------------------------------------------------- +! AddMaster +!---------------------------------------------------------------------------- + +MODULE PROCEDURE AddMaster2 +! Internal variables +INTEGER(I4B) :: ii, jj, kk, trow, tcol + +trow = SIZE(row) +tcol = SIZE(col) + +DO ii = 1, trow + DO kk = 1, tcol + DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 + IF (obj%csr%JA(jj) .EQ. col(kk)) THEN + obj%A(jj) = obj%A(jj) + scale * VALUE + EXIT + END IF + END DO + END DO +END DO + +END PROCEDURE AddMaster2 + +!---------------------------------------------------------------------------- +! AddContribution +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add0 +! Internal variables +INTEGER(I4B), ALLOCATABLE :: row(:), col(:) + +row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum) +col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum) + +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) + IF (ALLOCATED(row)) DEALLOCATE (row) IF (ALLOCATED(col)) DEALLOCATE (col) END PROCEDURE obj_Add0 +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_0 +CALL GetIndex_(obj=obj%csr%idof, nodeNum=nodenum, ans=row, tsize=nrow) +CALL GetIndex_(obj=obj%csr%jdof, nodeNum=nodenum, ans=col, tsize=ncol) +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_0 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- @@ -65,7 +135,7 @@ m2 = VALUE ELSE CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, & - & nns=SIZE(nodenum), tDOF=tdof) + nns=SIZE(nodenum), tDOF=tdof) END IF CASE (FMT_DOF) @@ -73,7 +143,7 @@ m2 = VALUE ELSE CALL Convert(From=VALUE, To=m2, Conversion=DofToNodes, & - & nns=SIZE(nodenum), tDOF=tdof) + nns=SIZE(nodenum), tDOF=tdof) END IF END SELECT @@ -82,6 +152,41 @@ END PROCEDURE obj_Add1 +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_1 +INTEGER(I4B) :: tdof, nns, conversion, objStorageFMT +LOGICAL(LGT) :: m2formed, isnode2dof + +objStorageFMT = (obj.StorageFMT.1) +m2formed = storageFMT .EQ. objStorageFMT + +IF (m2formed) THEN + m2_nrow = 0 + m2_ncol = 0 + CALL Add_(obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, & + row=row, col=col, nrow=nrow, ncol=ncol) + RETURN +END IF + +isnode2dof = (storageFMT .EQ. FMT_NODES) .AND. (objStorageFMT .EQ. FMT_DOF) +IF (isnode2dof) THEN + conversion = NodesToDOF +ELSE + conversion = DofToNodes +END IF + +tdof = .tdof.obj%csr%idof +nns = SIZE(nodenum) +CALL Convert_(from=VALUE, to=m2, conversion=conversion, & + nns=nns, tDOF=tdof, nrow=m2_nrow, ncol=m2_ncol) + +CALL Add_(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale, & + row=row, col=col, nrow=nrow, ncol=ncol) +END PROCEDURE obj_Add_1 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- @@ -95,10 +200,13 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Add3 -INTEGER(I4B) :: i, j -DO j = obj%csr%IA(iRow), obj%csr%IA(iRow + 1) - 1 - IF (obj%csr%JA(j) .EQ. iColumn) & - & obj%A(j) = obj%A(j) + scale * VALUE +INTEGER(I4B) :: j + +DO j = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1 + IF (obj%csr%JA(j) .EQ. icolumn) THEN + obj%A(j) = obj%A(j) + scale * VALUE + EXIT + END IF END DO END PROCEDURE obj_Add3 @@ -107,12 +215,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Add4 -! -CALL Add(obj=obj, & - & irow=getNodeLoc(obj=obj%csr%idof, nodenum=inodenum, idof=idof), & - & icolumn=getNodeLoc(obj=obj%csr%jdof, nodenum=jnodenum, idof=jdof), & - & VALUE=VALUE, scale=scale) -! +INTEGER(I4B) :: irow, icolumn + +irow = GetNodeLoc(obj=obj%csr%idof, nodenum=inodenum, idof=idof) +icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jnodenum, idof=jdof) +CALL Add_(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, scale=scale) END PROCEDURE obj_Add4 !---------------------------------------------------------------------------- @@ -122,14 +229,29 @@ MODULE PROCEDURE obj_Add5 REAL(DFP), ALLOCATABLE :: m2(:, :) INTEGER(I4B) :: tdof1, tdof2 + tdof1 = .tdof.obj%csr%idof tdof2 = .tdof.obj%csr%jdof + ALLOCATE (m2(tdof1 * SIZE(nodenum), tdof2 * SIZE(nodenum))) + m2 = VALUE + CALL Add(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale) DEALLOCATE (m2) END PROCEDURE obj_Add5 +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_5 +CALL GetIndex_(obj=obj%csr%idof, nodeNum=nodenum, ans=row, tsize=nrow) +CALL GetIndex_(obj=obj%csr%jdof, nodeNum=nodenum, ans=col, tsize=ncol) +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_5 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- @@ -137,45 +259,41 @@ MODULE PROCEDURE obj_Add6 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk -row = getIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) -col = getIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) +row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) +col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE(ii, kk) - EXIT - END IF - END DO - END DO -END DO +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) - END PROCEDURE obj_Add6 +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_6 +CALL GetIndex_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, ans=row, & + tsize=nrow) +CALL GetIndex_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, ans=col, & + tsize=ncol) +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_6 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Add7 -CALL Add(obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=iNodeNum, & - & ivar=ivar, & - & idof=iDOF),& - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=jNodeNum, & - & ivar=jvar, & - & idof=jDOF), & - & VALUE=VALUE, & - & scale=scale) -! +INTEGER(I4B) :: irow, icolumn + +irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, & + idof=idof) +icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, & + idof=jdof) + +CALL Add_(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, scale=scale) END PROCEDURE obj_Add7 !---------------------------------------------------------------------------- @@ -185,46 +303,40 @@ MODULE PROCEDURE obj_Add8 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk -row = getIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) -col = getIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) +row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) +col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE(ii, kk) - EXIT - END IF - END DO - END DO -END DO +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) END PROCEDURE obj_Add8 +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_8 +CALL GetIndex_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof, & + ans=row, tsize=nrow) +CALL GetIndex_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof, & + ans=col, tsize=ncol) +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_8 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Add9 -CALL Add( & - & obj=obj, & - & irow=getNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=iNodeNum, & - & ivar=ivar, & - & spacecompo=ispacecompo, & - & timecompo=itimecompo),& - & icolumn=getNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=jNodeNum, & - & ivar=jvar, & - & spacecompo=jspacecompo, & - & timecompo=jtimecompo), & - & VALUE=VALUE, & - & scale=scale) +INTEGER(I4B) :: irow, icolumn + +irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo) +icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo) +CALL Add_(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, scale=scale) END PROCEDURE obj_Add9 !---------------------------------------------------------------------------- @@ -234,25 +346,28 @@ MODULE PROCEDURE obj_Add10 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk ! -row = getIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) -col = getIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) - -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE - EXIT - END IF - END DO - END DO -END DO +row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar) +col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar) +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) END PROCEDURE obj_Add10 +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_10 +CALL GetIndex_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + ans=row, tsize=nrow) +CALL GetIndex_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + ans=col, tsize=ncol) + +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), & + VALUE=VALUE, scale=scale) +END PROCEDURE obj_Add_10 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- @@ -260,26 +375,27 @@ MODULE PROCEDURE obj_Add11 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk - -row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) -col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE - EXIT - END IF - END DO - END DO -END DO +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof) +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof) +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) - END PROCEDURE obj_Add11 +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_11 +CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof, & + ans=row, tsize=nrow) +CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof, & + ans=col, tsize=ncol) +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_11 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- @@ -287,24 +403,14 @@ MODULE PROCEDURE obj_Add12 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk -row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo) -col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo) -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE - EXIT - END IF - END DO - END DO -END DO +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) END PROCEDURE obj_Add12 @@ -313,32 +419,53 @@ ! Add !---------------------------------------------------------------------------- +MODULE PROCEDURE obj_Add_12 +CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo, & + ans=row, tsize=nrow) + +CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo, & + ans=col, tsize=ncol) + +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_12 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + MODULE PROCEDURE obj_Add13 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk -row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo) -col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) - -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE - EXIT - END IF - END DO - END DO -END DO +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo) +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) - END PROCEDURE obj_Add13 +!---------------------------------------------------------------------------- +! Add_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Add_13 +CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo, & + ans=row, tsize=nrow) + +CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo, & + ans=col, tsize=ncol) +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_13 + !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- @@ -346,34 +473,44 @@ MODULE PROCEDURE obj_Add14 ! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) -INTEGER(I4B) :: ii, jj, kk - -row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & - & spacecompo=ispacecompo, timecompo=itimecompo) -col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & - & spacecompo=jspacecompo, timecompo=jtimecompo) +row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo) -DO ii = 1, SIZE(row) - DO kk = 1, SIZE(col) - DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 - IF (obj%csr%JA(jj) .EQ. col(kk)) THEN - obj%A(jj) = obj%A(jj) + scale * VALUE - EXIT - END IF - END DO - END DO -END DO +col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo) +CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale) DEALLOCATE (row, col) - END PROCEDURE obj_Add14 !---------------------------------------------------------------------------- ! Add !---------------------------------------------------------------------------- +MODULE PROCEDURE obj_Add_14 +CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo, & + ans=row, tsize=nrow) + +CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo, & + ans=col, tsize=ncol) + +CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, & + scale=scale) +END PROCEDURE obj_Add_14 + +!---------------------------------------------------------------------------- +! Add +!---------------------------------------------------------------------------- + MODULE PROCEDURE obj_Add15 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_Add15()" +LOGICAL(LGT) :: isok +#endif + LOGICAL(LGT) :: sameStructure0, isSorted0 INTEGER(I4B) :: nrow, ncol, nzmax, ierr @@ -386,35 +523,73 @@ isSorted0 = Input(default=.FALSE., option=isSorted) -nrow = SIZE(obj, 1) -ncol = SIZE(obj, 2) -nzmax = GetNNZ(obj) +nrow = CSRMatrix_SIZE(obj, 1) +ncol = CSRMatrix_SIZE(obj, 2) +nzmax = CSRMatrix_GetNNZ(obj) IF (isSorted0) THEN - CALL CSRMatrixAPLSBSorted(nrow=nrow, ncol=ncol, & - & a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, & - & s=scale, & - & b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, & - & c=obj%A, jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, & - & ierr=ierr) + CALL CSRMatrixAPLSBSorted( & + nrow=nrow, ncol=ncol, a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, & + s=scale, b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, c=obj%A, & + jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, ierr=ierr) + ELSE - CALL CSRMatrixAPLSB(nrow=nrow, ncol=ncol, & - & a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, & - & s=scale, & - & b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, & - & c=obj%A, jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, & - & ierr=ierr) + CALL CSRMatrixAPLSB( & + nrow=nrow, ncol=ncol, a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, & + s=scale, b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, & + c=obj%A, jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, & + ierr=ierr) END IF -IF (ierr .EQ. 0) THEN - CALL Errormsg( & - & "Some error occured while calling CSRMarixAPLSB.", & - & __FILE__, & - & "obj_Add15()", & - & __LINE__, & - & stderr) - STOP -END IF +#ifdef DEBUG_VER +isok = ierr .NE. 0 +CALL AssertError1(isok, myName, modName, __LINE__, & + "Some error occured while calling CSRMarixAPLSB.") +#endif END PROCEDURE obj_Add15 +!---------------------------------------------------------------------------- +! AddToSTMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_AddToSTMatrix1 +REAL(DFP) :: scale0 +INTEGER(I4B) :: icol +INTEGER(I4B) :: irow_rhs, trow_rhs, icol_rhs, colIndex_rhs(2), & + tcol_rhs +INTEGER(I4B) :: irow_lhs, icol_lhs, colIndex_lhs(2), & + offAdd_row_lhs, offAdd_col_lhs + +scale0 = Input(default=1.0_DFP, option=scale) + +trow_rhs = CSRMatrix_Size(obj=VALUE, dims=1) +offAdd_row_lhs = (itimecompo - 1) * trow_rhs + +! start row loop +DO irow_rhs = 1, trow_rhs + ! Get the starting and ending data index for irow in value + colIndex_rhs = CSRMatrix_GetColIndex(obj=VALUE, irow=irow_rhs) + tcol_rhs = colIndex_rhs(2) - colIndex_rhs(1) + 1 + + ! Calculate the column offAdd for lhs + offAdd_col_lhs = (jtimecompo - 1) * tcol_rhs + + irow_lhs = offAdd_row_lhs + irow_rhs + colIndex_lhs = CSRMatrix_GetColIndex(obj=obj, irow=irow_lhs) + + DO icol = 1, tcol_rhs + icol_rhs = colIndex_rhs(1) + icol - 1 + icol_lhs = colIndex_lhs(1) + offAdd_col_lhs + icol - 1 + + obj%A(icol_lhs) = obj%A(icol_lhs) + scale0 * VALUE%A(icol_rhs) + END DO +END DO +END PROCEDURE obj_AddToSTMatrix1 + +!---------------------------------------------------------------------------- +! Include Errror +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 index f41ca5305..5b2ba7383 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 @@ -30,6 +30,11 @@ USE ErrorHandling USE GlobalData, ONLY: DofToNodes, NodesToDOF, FMT_NODES, FMT_DOF, stderr IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = "CSRMatrix_GetMethods@Methods.F90" +#endif + CONTAINS !---------------------------------------------------------------------------- @@ -246,25 +251,6 @@ END PROCEDURE obj_Get2 -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get10 -INTEGER(I4B) :: ii, jj - -! VALUE = 0.0_DFP -nrow = SIZE(irow) -ncol = SIZE(icolumn) -DO jj = 1, ncol - DO ii = 1, nrow - CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=irow(ii), & - icolumn=icolumn(jj)) - END DO -END DO - -END PROCEDURE obj_Get10 - !---------------------------------------------------------------------------- ! GetValue !---------------------------------------------------------------------------- @@ -318,7 +304,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Get6 -! Internal variables INTEGER(I4B), ALLOCATABLE :: row(:), col(:) INTEGER(I4B) :: ii, jj @@ -346,51 +331,23 @@ MODULE PROCEDURE obj_Get7 INTEGER(I4B) :: irow, icolumn -irow = GetNodeLoc( & - & obj=obj%csr%idof, & - & nodenum=iNodeNum, & - & ivar=ivar, & - & spacecompo=ispacecompo, & - & timecompo=itimecompo) - -icolumn = GetNodeLoc( & - & obj=obj%csr%jdof, & - & nodenum=jNodeNum, & - & ivar=jvar, & - & spacecompo=jspacecompo, & - & timecompo=jtimecompo) - -CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) -END PROCEDURE obj_Get7 - -!---------------------------------------------------------------------------- -! GetValue -!---------------------------------------------------------------------------- - -MODULE PROCEDURE obj_Get9 -INTEGER(I4B) :: irow(SIZE(iNodeNum)), icolumn(SIZE(jNodeNum)) - irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, & spacecompo=ispacecompo, timecompo=itimecompo) - icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, & spacecompo=jspacecompo, timecompo=jtimecompo) - -CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, & - nrow=nrow, ncol=ncol) -END PROCEDURE obj_Get9 +CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE) +END PROCEDURE obj_Get7 !---------------------------------------------------------------------------- ! GetValue !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Get8 -CHARACTER(*), PARAMETER :: myName = "CSR2CSR_Get_Master()" -CHARACTER(*), PARAMETER :: filename = __FILE__ -INTEGER(I4B) :: myindx(6, 2), idof1, jdof1, idof2, jdof2, & - & row1, row2, col1, col2, ierr0 +CHARACTER(*), PARAMETER :: myName = "obj_Get8()" +INTEGER(I4B) :: myindx(6, 2), idof1, jdof1, idof2, jdof2, & + row1, row2, col1, col2 CLASS(DOF_), POINTER :: dof_obj -LOGICAL(LGT) :: problem +LOGICAL(LGT) :: isok ! 1 ivar ! 2 ispacecompo @@ -399,7 +356,8 @@ ! 5 jspacecompo ! 6 jtimecompo -IF (PRESENT(ierr)) ierr = 0 +isok = PRESENT(ierr) +IF (isok) ierr = 0 myindx(1, 1) = Input(default=1, option=ivar1) myindx(2, 1) = Input(default=1, option=ispacecompo1) @@ -418,96 +376,120 @@ NULLIFY (dof_obj) dof_obj => GetDOFPointer(obj1, 1) -problem = .NOT. ASSOCIATED(dof_obj) -IF (problem) THEN - CALL ErrorMSG( & - & "Cannot get idof pointer from obj1", & - & filename, & - & myName, & - & __LINE__, stderr) - ierr0 = -1 - IF (PRESENT(ierr)) ierr = ierr0 - RETURN -END IF -idof1 = GetIDOF(obj=dof_obj, & - & ivar=myindx(1, 1), & - & spacecompo=myindx(2, 1), & - & timecompo=myindx(3, 1)) + +#ifdef DEBUG_VER +isok = ASSOCIATED(dof_obj) +CALL AssertError1(isok, myName, modName, __LINE__, & + "dof_obj is not associated.") +#endif + +idof1 = GetIDOF(obj=dof_obj, ivar=myindx(1, 1), spacecompo=myindx(2, 1), & + timecompo=myindx(3, 1)) row1 = dof_obj.tNodes.idof1 dof_obj => GetDOFPointer(obj1, 2) -problem = .NOT. ASSOCIATED(dof_obj) -IF (problem) THEN - CALL ErrorMSG( & - & "Cannot get jdof pointer from obj1", & - & filename, & - & myName, & - & __LINE__, stderr) - ierr0 = -2 - IF (PRESENT(ierr)) ierr = ierr0 - RETURN -END IF -jdof1 = GetIDOF(obj=dof_obj, & - & ivar=myindx(4, 1), & - & spacecompo=myindx(5, 1), & - & timecompo=myindx(6, 1)) + +#ifdef DEBUG_VER +isok = ASSOCIATED(dof_obj) +CALL AssertError1(isok, myName, modName, __LINE__, & + "dof_obj is not associated.") +#endif + +jdof1 = GetIDOF(obj=dof_obj, ivar=myindx(4, 1), spacecompo=myindx(5, 1), & + timecompo=myindx(6, 1)) col1 = dof_obj.tNodes.jdof1 dof_obj => GetDOFPointer(obj2, 1) -problem = .NOT. ASSOCIATED(dof_obj) -IF (problem) THEN - CALL ErrorMSG( & - & "Cannot get idof pointer from obj2", & - & filename, & - & myName, & - & __LINE__, stderr) - ierr0 = -3 - IF (PRESENT(ierr)) ierr = ierr0 - RETURN -END IF -idof2 = GetIDOF(obj=dof_obj, & - & ivar=myindx(1, 2), & - & spacecompo=myindx(2, 2), & - & timecompo=myindx(3, 2)) + +#ifdef DEBUG_VER +isok = ASSOCIATED(dof_obj) +CALL AssertError1(isok, myName, modName, __LINE__, & + "dof_obj is not associated.") +#endif + +idof2 = GetIDOF(obj=dof_obj, ivar=myindx(1, 2), spacecompo=myindx(2, 2), & + timecompo=myindx(3, 2)) row2 = dof_obj.tNodes.idof2 dof_obj => GetDOFPointer(obj2, 2) -problem = .NOT. ASSOCIATED(dof_obj) -IF (problem) THEN - CALL ErrorMSG( & - & "Cannot get jdof pointer from obj2", & - & filename, & - & myName, & - & __LINE__, stderr) - ierr0 = -4 - IF (PRESENT(ierr)) ierr = ierr0 - RETURN -END IF -jdof2 = GetIDOF(obj=dof_obj, & - & ivar=myindx(4, 2), & - & spacecompo=myindx(5, 2), & - & timecompo=myindx(6, 2)) + +#ifdef DEBUG_VER +isok = ASSOCIATED(dof_obj) +CALL AssertError1(isok, myName, modName, __LINE__, & + "dof_obj is not associated.") +#endif + +jdof2 = GetIDOF(obj=dof_obj, ivar=myindx(4, 2), spacecompo=myindx(5, 2), & + timecompo=myindx(6, 2)) + col2 = dof_obj.tNodes.jdof2 NULLIFY (dof_obj) -problem = (row1 .NE. row2) .OR. (col1 .NE. col2) -IF (problem) THEN - CALL ErrorMSG( & - & "Some error occured in sizes.", & - & filename, & - & myName, & - & __LINE__, stderr) - ierr0 = -5 - IF (PRESENT(ierr)) ierr = ierr0 - RETURN -END IF - -CALL CSR2CSR_Get_Master(obj1=obj1, obj2=obj2, idof1=idof1, idof2=idof2, & -& jdof1=jdof1, jdof2=jdof2, tNodes1=row1, tNodes2=col1) +#ifdef DEBUG_VER +isok = (row1 .EQ. row2) .AND. (col1 .EQ. col2) +CALL AssertError1(isok, myName, modName, __LINE__, & + "Some error occured in sizes.") +#endif +CALL CSR2CSR_Get_Master(obj1=obj1, obj2=obj2, idof1=idof1, idof2=idof2, & + jdof1=jdof1, jdof2=jdof2, tNodes1=row1, tNodes2=col1) END PROCEDURE obj_Get8 +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get9 +INTEGER(I4B) :: irow(SIZE(iNodeNum)), icolumn(SIZE(jNodeNum)) + +irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, & + spacecompo=ispacecompo, timecompo=itimecompo) + +icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, & + spacecompo=jspacecompo, timecompo=jtimecompo) + +CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, & + nrow=nrow, ncol=ncol) +END PROCEDURE obj_Get9 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get10 +INTEGER(I4B) :: ii, jj + +! VALUE = 0.0_DFP +nrow = SIZE(irow) +ncol = SIZE(icolumn) +DO jj = 1, ncol + DO ii = 1, nrow + CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=irow(ii), & + icolumn=icolumn(jj)) + END DO +END DO + +END PROCEDURE obj_Get10 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get11 +ans = obj%A(indx) +END PROCEDURE obj_Get11 + +!---------------------------------------------------------------------------- +! GetValue +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Get12 +INTEGER(I4B) :: ii +tsize = SIZE(indx) +DO ii = 1, tsize; ans(ii) = obj%A(indx(ii)); END DO +END PROCEDURE obj_Get12 + !---------------------------------------------------------------------------- ! CSR2CSRGetValue !---------------------------------------------------------------------------- @@ -517,22 +499,19 @@ REAL(DFP) :: VALUE DO jj = 1, tNodes2 DO ii = 1, tNodes1 - CALL GetValue(obj=obj1, & - & idof=idof1, & - & jdof=jdof1, & - & iNodeNum=ii, & - & jNodeNum=jj, & - & VALUE=VALUE) - - CALL Set(obj=obj2, & - & idof=idof2, & - & jdof=jdof2, & - & iNodeNum=ii, & - & jNodeNum=jj, & - & VALUE=VALUE) + CALL GetValue(obj=obj1, idof=idof1, jdof=jdof1, iNodeNum=ii, & + jNodeNum=jj, VALUE=VALUE) + + CALL Set(obj=obj2, idof=idof2, jdof=jdof2, iNodeNum=ii, jNodeNum=jj, & + VALUE=VALUE) END DO END DO - END PROCEDURE CSR2CSR_Get_Master +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 index 0abd51aae..e6499613d 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 @@ -15,113 +15,171 @@ ! along with this program. If not, see SUBMODULE(CSRMatrix_GetSubMatrixMethods) Methods -USE BaseMethod +USE Display_Method, ONLY: ToString, Display +USE BaseType, ONLY: math => TypeMathOpt +USE CSRMatrix_Method, ONLY: GetNNZ +USE CSRMatrix_Method, ONLY: CSRMatrix_GetColIndex => GetColIndex +USE CSRMatrix_Method, ONLY: CSRMatrix_GetColNumber => GetColNumber +USE CSRMatrix_Method, ONLY: CSRMatrix_Size => SIZE +USE CSRMatrix_Method, ONLY: CSRMatrix_GetSingleValue => GetSingleValue +USE CSRMatrix_Method, ONLY: CSRMatrix_SetIA => SetIA +USE CSRMatrix_Method, ONLY: CSRMatrix_SetJA => SetJA +USE CSRMatrix_Method, ONLY: CSRMatrix_SetSingleValue => SetSingleValue +USE CSRMatrix_Method, ONLY: CSRMatrix_GetValue => GetValue +USE CSRMatrix_Method, ONLY: CSRMatrix_Initiate => Initiate +USE CSRSparsity_Method, ONLY: CSR_GetColNumber => GetColNumber +USE ReallocateUtility, ONLY: Reallocate + IMPLICIT NONE + +CHARACTER(*), PARAMETER :: modName="CSRMatrix_GetSubMatrixMethods@Methods.F90" + CONTAINS !---------------------------------------------------------------------------- -! GetSubMatrix +! GetSubMatrixNNZ !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_GetSubMatrix1 -LOGICAL(LGT), ALLOCATABLE :: selectCol(:) -INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), & +MODULE PROCEDURE obj_GetSubMatrixNNZ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetSubMatrixNNZ()" +LOGICAL(LGT) :: isok +#endif + +INTEGER(I4B) :: nnz, nrow, ncol, ii, nn, irow, colIndx(2), & icol, jj -REAL(DFP) :: aval -CHARACTER(:), ALLOCATABLE :: astr nnz = GetNNZ(obj=obj) -nrow = SIZE(obj, 1) -ncol = SIZE(obj, 2) +nrow = CSRMatrix_Size(obj, 1) +ncol = CSRMatrix_Size(obj, 2) -CALL Reallocate(selectCol, ncol) +! CALL Reallocate(selectCol, ncol) -selectCol = .FALSE. +selectCol(1:ncol) = math%no nn = SIZE(cols) DO ii = 1, nn jj = cols(ii) #ifdef DEBUG_VER - IF (jj .GT. ncol) THEN - astr = "Error cols( "//tostring(ii)//") is greater than "// & - "ncol = "//tostring(ncol) - CALL ErrorMSG(msg=astr, & - file="CSRMatrix_GetSubMatrixMethods@Methods.F90", & - routine="obj_GetSubMatrix1()", & - line=__LINE__, unitno=stderr) - STOP - END IF + isok = jj .LE. ncol + CALL AssertError1( & + isok, myName, modName, __LINE__, "Error cols( "//ToString(ii)// & + ") is greater than ncol = "//ToString(ncol)) #endif - selectCol(jj) = .TRUE. + selectCol(jj) = math%yes END DO -submat_nnz = 0 +ans = 0 DO irow = 1, nrow - colIndx = GetColIndex(obj=obj, irow=irow) + colIndx = CSRMatrix_GetColIndex(obj=obj, irow=irow) DO ii = colIndx(1), colIndx(2) - icol = GetColNumber(obj, ii) - IF (selectCol(icol)) submat_nnz = submat_nnz + 1 + icol = CSRMatrix_GetColNumber(obj, ii) + IF (selectCol(icol)) ans = ans + 1 END DO END DO +END PROCEDURE obj_GetSubMatrixNNZ + +!---------------------------------------------------------------------------- +! GetSubMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSubMatrix1 +LOGICAL(LGT), ALLOCATABLE :: selectCol(:) +INTEGER(I4B) :: tsize +tsize = CSRMatrix_Size(obj, 2) +CALL Reallocate(selectCol, tsize) +CALL GetSubMatrixNNZ(obj=obj, cols=cols, selectCol=selectCol, ans=tsize) +CALL Reallocate(subIndices, tsize) +CALL GetSubMatrix_( & + obj=obj, cols=cols, submat=submat, subIndices=subIndices, & + selectCol=selectCol, tsize=tsize) +IF (ALLOCATED(selectCol)) DEALLOCATE (selectCol) +END PROCEDURE obj_GetSubMatrix1 + +!---------------------------------------------------------------------------- +! GetSubMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetSubMatrix_1 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetSubMatrix_1()" +#endif + +INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, irow, colIndx(2), icol, jj +REAL(DFP) :: aval + +nnz = GetNNZ(obj=obj) +nrow = CSRMatrix_Size(obj, 1) +ncol = CSRMatrix_Size(obj, 2) + +! CALL Reallocate(selectCol, ncol) +CALL GetSubMatrixNNZ(obj=obj, cols=cols, selectCol=selectCol, ans=submat_nnz) -CALL Reallocate(subIndices, submat_nnz) -CALL Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=submat_nnz) +! CALL Reallocate(subIndices, submat_nnz) +CALL CSRMatrix_Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=submat_nnz) submat_nnz = 1 -CALL SetIA(obj=submat, irow=1, VALUE=submat_nnz) +CALL CSRMatrix_SetIA(obj=submat, irow=1, VALUE=submat_nnz) DO irow = 1, nrow - colIndx = GetColIndex(obj=obj, irow=irow) + colIndx = CSRMatrix_GetColIndex(obj=obj, irow=irow) + jj = 0 DO ii = colIndx(1), colIndx(2) - icol = GetColNumber(obj%csr, ii) + icol = CSR_GetColNumber(obj%csr, ii) + IF (selectCol(icol)) THEN - CALL SetJA(obj=submat, indx=submat_nnz + jj, VALUE=icol) - aval = GetSingleValue(obj=obj, indx=ii) - CALL SetSingleValue(obj=submat, indx=submat_nnz + jj, VALUE=aval) + CALL CSRMatrix_SetJA(obj=submat, indx=submat_nnz + jj, VALUE=icol) + + aval = CSRMatrix_GetSingleValue(obj=obj, indx=ii) + + CALL CSRMatrix_SetSingleValue( & + obj=submat, indx=submat_nnz + jj, VALUE=aval) + subIndices(submat_nnz + jj) = ii + jj = jj + 1 END IF END DO - submat_nnz = submat_nnz + jj - CALL SetIA(obj=submat, irow=irow + 1, VALUE=submat_nnz) -END DO -IF (ALLOCATED(selectCol)) DEALLOCATE (selectCol) + submat_nnz = submat_nnz + jj + CALL CSRMatrix_SetIA(obj=submat, irow=irow + 1, VALUE=submat_nnz) -END PROCEDURE obj_GetSubMatrix1 +END DO +END PROCEDURE obj_GetSubMatrix_1 !---------------------------------------------------------------------------- ! GetSubMatrix1 !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetSubMatrix2 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetSubMatrix2()" +#endif LOGICAL(LGT) :: isok +INTEGER(I4B) :: tsize +#ifdef DEBUG_VER isok = ALLOCATED(submat%A) -IF (.NOT. isok) THEN - CALL ErrorMSG( & - & "submat%A not allocated", & - & "CSRMatrix_GetSubMatrixMethods@Methods.F90", & - & "obj_GetSubMatrix2()", & - & __LINE__, stderr) - STOP -END IF +CALL AssertError1( & + isok, myName, modName, __LINE__, "submat%A is not allocated") +#endif +#ifdef DEBUG_VER isok = SIZE(submat%A) .EQ. SIZE(subIndices) -IF (.NOT. isok) THEN - CALL ErrorMSG( & - & "Size of submat%A not same as size of subIndices.", & - & "CSRMatrix_GetSubMatrixMethods@Methods.F90", & - & "obj_GetSubMatrix2()", & - & __LINE__, stderr) - STOP -END IF - -submat%A = Get(obj=obj, indx=subIndices) +CALL AssertError1(isok, myName, modName, __LINE__, & + "Size of submat%A not same as size of subIndices.") +#endif +CALL CSRMatrix_GetValue(obj=obj, indx=subIndices, ans=submat%A, tsize=tsize) END PROCEDURE obj_GetSubMatrix2 +!---------------------------------------------------------------------------- +! Include Error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 index 8283f5447..7e9f07ab0 100644 --- a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 +++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 @@ -20,7 +20,18 @@ ! summary: It contains method for setting values in [[CSRMatrix_]] SUBMODULE(CSRMatrix_SetMethods) Methods -USE BaseMethod +USE GlobalData, ONLY: FMT_NODES, FMT_DOF, NodesToDOF, DofToNodes +USE DOF_Method, ONLY: GetIndex, GetNodeLoc, OPERATOR(.tdof.) +USE ConvertUtility, ONLY: Convert +USE CSRSparsity_Method, ONLY: CSR_SetIA => SetIA, CSR_SetJA => SetJA +USE InputUtility, ONLY: Input +USE F95_BLAS, ONLY: Scal, Copy +USE ReallocateUtility, ONLY: Reallocate + +USE CSRMatrix_GetMethods, ONLY: OPERATOR(.StorageFMT.), & + CSRMatrix_GetColIndex => GetColIndex +USE CSRMatrix_ConstructorMethods, ONLY: CSRMatrix_Size => Size + IMPLICIT NONE CONTAINS @@ -41,8 +52,8 @@ INTEGER(I4B), ALLOCATABLE :: row(:), col(:) INTEGER(I4B) :: ii, jj, kk -row = getIndex(obj=obj%csr%idof, nodeNum=nodenum) -col = getIndex(obj=obj%csr%jdof, nodeNum=nodenum) +row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum) +col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum) DO ii = 1, SIZE(row) DO kk = 1, SIZE(col) DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1 @@ -72,14 +83,14 @@ m2 = VALUE ELSE CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, & - & nns=SIZE(nodenum), tDOF=tdof) + nns=SIZE(nodenum), tDOF=tdof) END IF CASE (FMT_DOF) IF ((obj.StorageFMT.1) .EQ. FMT_DOF) THEN m2 = VALUE ELSE CALL Convert(From=VALUE, To=m2, Conversion=DofToNodes, & - & nns=SIZE(nodenum), tDOF=tdof) + nns=SIZE(nodenum), tDOF=tdof) END IF END SELECT CALL Set(obj=obj, nodenum=nodenum, VALUE=m2) @@ -378,9 +389,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_set15 -CALL COPY(Y=obj%A, X=VALUE%A) +CALL Copy(Y=obj%A, X=VALUE%A) IF (PRESENT(scale)) THEN - CALL SCAL(X=obj%A, A=scale) + CALL Scal(X=obj%A, A=scale) END IF END PROCEDURE obj_set15 @@ -389,7 +400,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_SetIA -CALL SetIA(obj%csr, irow, VALUE) +CALL CSR_SetIA(obj=obj%csr, irow=irow, VALUE=VALUE) END PROCEDURE obj_SetIA !---------------------------------------------------------------------------- @@ -397,7 +408,46 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_SetJA -CALL SetJA(obj%csr, indx, VALUE) +CALL CSR_SetJA(obj=obj%csr, indx=indx, VALUE=VALUE) END PROCEDURE obj_SetJA +!---------------------------------------------------------------------------- +! SetToSTMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_SetToSTMatrix1 +REAL(DFP) :: scale0 +INTEGER(I4B) :: icol +INTEGER(I4B) :: irow_rhs, trow_rhs, icol_rhs, colIndex_rhs(2), & + tcol_rhs +INTEGER(I4B) :: irow_lhs, icol_lhs, colIndex_lhs(2), & + offset_row_lhs, offset_col_lhs + +scale0 = Input(default=1.0_DFP, option=scale) + +trow_rhs = CSRMatrix_Size(obj=VALUE, dims=1) +offset_row_lhs = (itimecompo - 1) * trow_rhs + +! start row loop +DO irow_rhs = 1, trow_rhs + ! Get the starting and ending data index for irow in value + colIndex_rhs = CSRMatrix_GetColIndex(obj=VALUE, irow=irow_rhs) + tcol_rhs = colIndex_rhs(2) - colIndex_rhs(1) + 1 + + ! Calculate the column offset for lhs + offset_col_lhs = (jtimecompo - 1) * tcol_rhs + + irow_lhs = offset_row_lhs + irow_rhs + colIndex_lhs = CSRMatrix_GetColIndex(obj=obj, irow=irow_lhs) + + DO icol = 1, tcol_rhs + icol_rhs = colIndex_rhs(1) + icol - 1 + icol_lhs = colIndex_lhs(1) + offset_col_lhs + icol - 1 + + obj%A(icol_lhs) = scale0 * VALUE%A(icol_rhs) + END DO +END DO + +END PROCEDURE obj_SetToSTMatrix1 + END SUBMODULE Methods diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 index bad5cdb52..2cefe0534 100644 --- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 +++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 @@ -19,16 +19,16 @@ IMPLICIT NONE CONTAINS -#include "./CM_1.inc" -#include "./CM_2.inc" -#include "./CM_3.inc" -#include "./CM_4.inc" -#include "./CM_5.inc" -#include "./CM_6.inc" -#include "./CM_7.inc" -#include "./CM_8.inc" -#include "./CM_9.inc" -#include "./CM_10.inc" +#include "./include/CM_1.F90" +#include "./include/CM_2.F90" +#include "./include/CM_3.F90" +#include "./include/CM_4.F90" +#include "./include/CM_5.F90" +#include "./include/CM_6.F90" +#include "./include/CM_7.F90" +#include "./include/CM_8.F90" +#include "./include/CM_9.F90" +#include "./include/CM_10.F90" !---------------------------------------------------------------------------- ! ConvectiveMatrix @@ -195,8 +195,9 @@ PURE SUBROUTINE CM1_(ans, test, trial, c, term1, term2, opt, nrow, ncol) ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetProjectionOfdNdXt_(obj=trial, cdNdXt=p, val=c, nrow=ii, ncol=jj) - !! + CALL GetProjectionOfdNdXt_(obj=trial, ans=p, c=c, nrow=ii, ncol=jj, & + crank=TypeFEVariableVector) + DO ips = 1, trial%nips realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) CALL OuterProd_(a=test%N(1:nrow, ips), & @@ -235,7 +236,8 @@ PURE SUBROUTINE CM2_(ans, test, trial, c, term1, term2, opt, nrow, ncol) ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetProjectionOfdNdXt_(obj=test, cdNdXt=p, val=c, nrow=ii, ncol=jj) + CALL GetProjectionOfdNdXt_(obj=test, ans=p, c=c, nrow=ii, ncol=jj, & + crank=TypeFEVariableVector) DO ips = 1, trial%nips realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) @@ -273,7 +275,7 @@ PURE SUBROUTINE CM3_(ans, test, trial, term1, term2, c, opt, nrow, ncol) ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + CALL GetInterpolation_(obj=trial, val=c, ans=realval, tsize=ii) realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii) DO ips = 1, trial%nips @@ -311,7 +313,7 @@ PURE SUBROUTINE CM4_(ans, test, trial, term1, term2, c, opt, nrow, ncol) ncol = SIZE(trial%N, 1) ans(1:nrow, 1:ncol) = 0.0_DFP - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + CALL GetInterpolation_(obj=trial, val=c, ans=realval, tsize=ii) realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii) DO ips = 1, trial%nips @@ -347,7 +349,7 @@ PURE SUBROUTINE CM5_(ans, test, trial, term1, term2, c, opt, nrow, ncol) REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd) REAL(DFP), PARAMETER :: one = 1.0_DFP - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + CALL GetInterpolation_(obj=trial, val=c, ans=realval, tsize=ii) realval(1:trial%nips) = trial%js * trial%ws * trial%thickness * realval(1:trial%nips) nrow = test%nns @@ -400,7 +402,7 @@ PURE SUBROUTINE CM6_(ans, test, trial, term1, term2, c, opt, nrow, ncol) nrow = test%nns ncol = trial%nns - CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii) + CALL GetInterpolation_(obj=trial, val=c, ans=realval, tsize=ii) realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii) IF (opt .EQ. 1) THEN @@ -513,6 +515,8 @@ PURE SUBROUTINE CM9_(ans, test, trial, term1, term2, opt, nrow, ncol) INTEGER(I4B), INTENT(IN) :: term2 INTEGER(I4B), INTENT(IN) :: opt INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! internal variables INTEGER(I4B) :: ips, ii, jj, kk REAL(DFP), PARAMETER :: one = 1.0_DFP REAL(DFP) :: realval diff --git a/src/submodules/ConvectiveMatrix/src/CM_1.inc b/src/submodules/ConvectiveMatrix/src/include/CM_1.F90 similarity index 96% rename from src/submodules/ConvectiveMatrix/src/CM_1.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_1.F90 index b72de1350..3500b3885 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_1.inc +++ b/src/submodules/ConvectiveMatrix/src/include/CM_1.F90 @@ -46,7 +46,7 @@ PURE SUBROUTINE CM_1(ans, test, trial, c, term1, term2, opt) !! !! projection on trial !! - CALL GetProjectionOfdNdXt(obj=trial, cdNdXt=p, val=c) + CALL GetProjectionOfdNdXt(obj=trial, ans=p, c=c, crank=TypeFEVariableVector) !! DO ips = 1, SIZE(trial%N, 2) ans = ans + outerprod(a=test%N(:, ips), & diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/include/CM_10.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_10.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_10.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_2.inc b/src/submodules/ConvectiveMatrix/src/include/CM_2.F90 similarity index 93% rename from src/submodules/ConvectiveMatrix/src/CM_2.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_2.F90 index 345c2a243..a6fe2f259 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_2.inc +++ b/src/submodules/ConvectiveMatrix/src/include/CM_2.F90 @@ -29,7 +29,7 @@ PURE SUBROUTINE CM_2(ans, test, trial, c, term1, term2, opt) !! !! projection on test !! - CALL GetProjectionOfdNdXt(obj=test, cdNdXt=p, val=c) + CALL GetProjectionOfdNdXt(obj=test, ans=p, c=c, crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) ans = ans + outerprod(a=p(:, ips), & diff --git a/src/submodules/ConvectiveMatrix/src/CM_3.inc b/src/submodules/ConvectiveMatrix/src/include/CM_3.F90 similarity index 95% rename from src/submodules/ConvectiveMatrix/src/CM_3.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_3.F90 index 4095c3ac6..e6f7207a5 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_3.inc +++ b/src/submodules/ConvectiveMatrix/src/include/CM_3.F90 @@ -26,7 +26,7 @@ PURE SUBROUTINE CM_3(ans, test, trial, term1, term2, c, opt) !! CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) + CALL GetInterpolation(obj=trial, val=c, ans=realval) !! realval = trial%js * trial%ws * trial%thickness * realval !! diff --git a/src/submodules/ConvectiveMatrix/src/CM_4.inc b/src/submodules/ConvectiveMatrix/src/include/CM_4.F90 similarity index 95% rename from src/submodules/ConvectiveMatrix/src/CM_4.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_4.F90 index 91c1be600..5dfd5daf9 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_4.inc +++ b/src/submodules/ConvectiveMatrix/src/include/CM_4.F90 @@ -25,7 +25,7 @@ PURE SUBROUTINE CM_4(ans, test, trial, term1, term2, c, opt) !! CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) + CALL GetInterpolation(obj=trial, val=c, ans=realval) !! realval = trial%js * trial%ws * trial%thickness * realval !! diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/include/CM_5.F90 similarity index 97% rename from src/submodules/ConvectiveMatrix/src/CM_5.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_5.F90 index 572670b68..987058f70 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_5.inc +++ b/src/submodules/ConvectiveMatrix/src/include/CM_5.F90 @@ -41,7 +41,7 @@ PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) + CALL GetInterpolation(obj=trial, val=c, ans=realval) !! realval = trial%js * trial%ws * trial%thickness * realval !! diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/include/CM_6.F90 similarity index 97% rename from src/submodules/ConvectiveMatrix/src/CM_6.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_6.F90 index c260ddaa5..82afeb95c 100644 --- a/src/submodules/ConvectiveMatrix/src/CM_6.inc +++ b/src/submodules/ConvectiveMatrix/src/include/CM_6.F90 @@ -41,7 +41,7 @@ PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, val=c, interpol=realval) + CALL GetInterpolation(obj=trial, val=c, ans=realval) !! realval = trial%js * trial%ws * trial%thickness * realval !! diff --git a/src/submodules/ConvectiveMatrix/src/CM_7.inc b/src/submodules/ConvectiveMatrix/src/include/CM_7.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_7.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_7.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_8.inc b/src/submodules/ConvectiveMatrix/src/include/CM_8.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_8.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_8.F90 diff --git a/src/submodules/ConvectiveMatrix/src/CM_9.inc b/src/submodules/ConvectiveMatrix/src/include/CM_9.F90 similarity index 100% rename from src/submodules/ConvectiveMatrix/src/CM_9.inc rename to src/submodules/ConvectiveMatrix/src/include/CM_9.F90 diff --git a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 index 1c00e54ca..fa76e9c91 100644 --- a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 +++ b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 @@ -364,7 +364,8 @@ MODULE PROCEDURE obj_GetNodeLoc2 INTEGER(I4B) :: tsize -CALL obj_getnodeloc_2(obj, nodenum, idof, ans, tsize) +CALL obj_GetNodeLoc_2(obj=obj, nodenum=nodenum, idof=idof, ans=ans, & + tsize=tsize) END PROCEDURE obj_GetNodeLoc2 !---------------------------------------------------------------------------- @@ -386,7 +387,8 @@ MODULE PROCEDURE obj_GetNodeLoc3 INTEGER(I4B) :: tsize -CALL obj_getnodeloc_3(obj, nodenum, idof, ans, tsize) +CALL obj_GetNodeLoc_3(obj=obj, nodenum=nodenum, idof=idof, ans=ans, & + tsize=tsize) END PROCEDURE obj_GetNodeLoc3 !---------------------------------------------------------------------------- @@ -408,9 +410,13 @@ MODULE PROCEDURE obj_GetNodeLoc4 IF (obj%storageFMT .EQ. NODES_FMT) THEN - ans = [idof, .tnodes.obj, .tdof.obj] + ans(1) = idof + ans(2) = .tnodes.obj + ans(3) = .tdof.obj ELSE - ans = [obj%valmap(idof), obj%valmap(idof + 1) - 1, 1] + ans(1) = obj%valmap(idof) + ans(2) = obj%valmap(idof + 1) - 1 + ans(3) = 1 END IF END PROCEDURE obj_GetNodeLoc4 @@ -432,7 +438,8 @@ MODULE PROCEDURE obj_GetNodeLoc6 INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_6(obj, nodenum, ivar, idof, ans, tsize) +CALL obj_GetNodeLoc_6(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof, & + ans=ans, tsize=tsize) END PROCEDURE obj_GetNodeLoc6 !---------------------------------------------------------------------------- @@ -459,10 +466,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc7 +INTEGER(I4B) :: idof, tspacecompo + +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) + ans = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, & - idof=GetIDOF(spacecompo=spacecompo, & - timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) + END PROCEDURE obj_GetNodeLoc7 !---------------------------------------------------------------------------- @@ -470,10 +482,13 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc8 -INTEGER(I4B) :: tsize +INTEGER(I4B) :: tsize, idof, tspacecompo + +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) END PROCEDURE obj_GetNodeLoc8 !---------------------------------------------------------------------------- @@ -481,9 +496,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc_8 +INTEGER(I4B) :: idof, tspacecompo + +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) + CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) END PROCEDURE obj_GetNodeLoc_8 !---------------------------------------------------------------------------- @@ -492,7 +512,8 @@ MODULE PROCEDURE obj_GetNodeLoc9 INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_9(obj, nodenum, ivar, idof, ans, tsize) +CALL obj_GetNodeLoc_9(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof, & + ans=ans, tsize=tsize) END PROCEDURE obj_GetNodeLoc9 !---------------------------------------------------------------------------- @@ -531,10 +552,14 @@ MODULE PROCEDURE obj_GetNodeLoc10 INTEGER(I4B) :: tsize +INTEGER(I4B) :: idof(SIZE(timecompo)), tspacecompo + +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) + CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, & - timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) END PROCEDURE obj_GetNodeLoc10 !---------------------------------------------------------------------------- @@ -542,9 +567,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc_10 +INTEGER(I4B) :: idof(SIZE(timecompo)), tspacecompo +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) END PROCEDURE obj_GetNodeLoc_10 !---------------------------------------------------------------------------- @@ -553,9 +581,13 @@ MODULE PROCEDURE obj_GetNodeLoc11 INTEGER(I4B) :: tsize +INTEGER(I4B) :: idof(SIZE(spacecompo)), tspacecompo + +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) END PROCEDURE obj_GetNodeLoc11 !---------------------------------------------------------------------------- @@ -563,9 +595,13 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc_11 +INTEGER(I4B) :: idof(SIZE(spacecompo)), tspacecompo + +tspacecompo = obj.spacecomponents.ivar +idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & + tspacecompo=tspacecompo) CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, & - idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar)) + idof=idof) END PROCEDURE obj_GetNodeLoc_11 !---------------------------------------------------------------------------- @@ -574,8 +610,9 @@ MODULE PROCEDURE obj_GetNodeLoc12 INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_12(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) +CALL obj_GetNodeLoc_12(obj=obj, nodenum=nodenum, ivar=ivar, & + spacecompo=spacecompo, timecompo=timecompo, & + ans=ans, tsize=tsize) END PROCEDURE obj_GetNodeLoc12 !---------------------------------------------------------------------------- @@ -583,14 +620,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc_12 -INTEGER(I4B) :: idofs(SIZE(timecompo)), ii, tempsize, tnode +INTEGER(I4B) :: idofs(SIZE(timecompo)) +INTEGER(I4B) :: ii, tempsize, tnode, tspacecompo tempsize = SIZE(timecompo) tnode = SIZE(nodenum) tsize = tempsize * tnode +tspacecompo = obj.spacecomponents.ivar idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar) + tspacecompo=tspacecompo) tsize = 1 DO ii = 1, tnode @@ -600,7 +639,6 @@ END DO tsize = tsize - 1 - END PROCEDURE obj_GetNodeLoc_12 !---------------------------------------------------------------------------- @@ -609,8 +647,9 @@ MODULE PROCEDURE obj_GetNodeLoc13 INTEGER(I4B) :: tsize -CALL obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, & - timecompo, ans, tsize) +CALL obj_GetNodeLoc_13(obj=obj, nodenum=nodenum, ivar=ivar, & + spacecompo=spacecompo, timecompo=timecompo, & + ans=ans, tsize=tsize) END PROCEDURE obj_GetNodeLoc13 !---------------------------------------------------------------------------- @@ -618,14 +657,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetNodeLoc_13 -INTEGER(I4B) :: idofs(SIZE(spacecompo)), ii, tempsize, tnode +INTEGER(I4B) :: idofs(SIZE(spacecompo)) +INTEGER(I4B) :: ii, tempsize, tnode, tspacecompo tempsize = SIZE(spacecompo) tnode = SIZE(nodenum) tsize = tempsize * tnode +tspacecompo = obj.spacecomponents.ivar idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, & - tspacecompo=obj.spacecomponents.ivar) + tspacecompo=tspacecompo) tsize = 1 DO ii = 1, tnode @@ -635,11 +676,10 @@ END DO tsize = tsize - 1 - END PROCEDURE obj_GetNodeLoc_13 !---------------------------------------------------------------------------- -! GetIndex +! GetIndex !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex1 @@ -651,7 +691,7 @@ END PROCEDURE obj_GetIndex1 !---------------------------------------------------------------------------- -! GetIndex_ +! GetIndex_ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex_1 @@ -661,7 +701,7 @@ END PROCEDURE obj_GetIndex_1 !---------------------------------------------------------------------------- -! GetIndex +! GetIndex !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex2 @@ -673,7 +713,7 @@ END PROCEDURE obj_GetIndex2 !---------------------------------------------------------------------------- -! GetIndex_ +! GetIndex_ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_GetIndex_2 diff --git a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 index 5fda02d7e..7c7d17d14 100644 --- a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 +++ b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 @@ -20,7 +20,11 @@ ! summary: This submodule contains IO method for [[DOF_]] SUBMODULE(DOF_IOMethods) Methods -USE BaseMethod +USE Display_Method, ONLY: MyDisplay => Display +USE Display_Method, ONLY: ToString +USE DOF_Method, ONLY: OPERATOR(.tNames.) +USE DOF_Method, ONLY: GetNodeLoc +USE GlobalData, ONLY: FMT_DOF, FMT_NODES IMPLICIT NONE CONTAINS @@ -30,65 +34,73 @@ MODULE PROCEDURE dof_Display1 INTEGER(I4B) :: n, j +LOGICAL(LGT) :: isok + +CALL MyDisplay(msg, unitNo=unitNo) + +isok = ALLOCATED(obj%map) +CALL MyDisplay(isok, "obj%map allocated: ", UnitNo=UnitNo) +IF (.NOT. isok) RETURN + +n = SIZE(obj%map, 1) - 1 +CALL MyDisplay(n, "Total Physical Variables :", unitNo=unitNo) + +DO j = 1, n + CALL MyDisplay("Name : "//CHAR(obj%map(j, 1)), unitNo=unitNo) + + IF (obj%map(j, 2) .LT. 0) THEN + CALL MyDisplay("Space Components : "//"Scalar", unitNo=unitNo) + ELSE + CALL MyDisplay(obj%map(j, 2), "Space Components : ", unitNo=unitNo) + END IF + + CALL MyDisplay(obj%map(j, 3), "Time Components : ", unitNo=unitNo) + CALL MyDisplay(obj%map(j, 6), "Total Nodes : ", unitNo=unitNo) +END DO + +SELECT CASE (obj%StorageFMT) +CASE (FMT_DOF) + CALL MyDisplay("Storage Format : DOF", unitNo=unitNo) +CASE (FMT_NODES) + CALL MyDisplay("Storage Format : Nodes", unitNo=unitNo) +END SELECT + +CALL MyDisplay(obj%valmap, "Value map : ", unitNo=unitNo) -IF (LEN_TRIM(msg) .NE. 0) THEN - CALL Display("# "//TRIM(msg), unitNo=unitNo) -END IF -IF (ALLOCATED(obj%Map)) THEN - ASSOCIATE (Map => obj%Map, ValMap => obj%ValMap) - n = SIZE(Map, 1) - 1 - CALL Display(n, "# Total Physical Variables :", unitNo=unitNo) - DO j = 1, n - CALL Display("# Name : "//CHAR(Map(j, 1)), unitNo=unitNo) - IF (Map(j, 2) .LT. 0) THEN - CALL Display("# Space Components : "//"Scalar", unitNo=unitNo) - ELSE - CALL Display(Map(j, 2), "# Space Components : ", unitNo=unitNo) - END IF - CALL Display(Map(j, 3), "# Time Components : ", unitNo=unitNo) - CALL Display(Map(j, 6), "# Total Nodes : ", unitNo=unitNo) - END DO - SELECT CASE (obj%StorageFMT) - CASE (DOF_FMT) - CALL Display("# Storage Format : DOF", unitNo=unitNo) - CASE (Nodes_FMT) - CALL Display("# Storage Format : Nodes", unitNo=unitNo) - END SELECT - CALL Display(obj%ValMap, "# Value Map : ", unitNo=unitNo) - END ASSOCIATE -ELSE - CALL Display("# obj%Map : NOT ALLOCATED") -END IF END PROCEDURE dof_Display1 !---------------------------------------------------------------------------- ! Display !---------------------------------------------------------------------------- -MODULE PROCEDURE dof_display2 +MODULE PROCEDURE dof_Display2 INTEGER(I4B) :: jj, tnames, idof, a(3) !> main -CALL Display(obj, '# DOF data : ', unitNo=unitNo) +CALL Display(obj, 'DOF data : ', unitNo=unitNo) + tnames = .tNames.obj + DO jj = 1, tnames - CALL Display(ACHAR(obj%Map(jj, 1)), "# VAR : ", unitNo) + CALL MyDisplay(ACHAR(obj%Map(jj, 1)), "VAR : ", unitNo) + DO idof = obj%Map(jj, 5), obj%Map(jj + 1, 5) - 1 - a = getNodeLOC(obj=obj, idof=idof) - CALL Display(Vec(a(1):a(2):a(3)), & - & msg="DOF-"//TOSTRING(idof), unitNo=unitNo, advance="NO") + a = GetNodeLoc(obj=obj, idof=idof) + CALL MyDisplay( & + vec(a(1):a(2):a(3)), msg="DOF-"//ToString(idof), unitNo=unitNo, & + advance="NO", full=.TRUE.) END DO - CALL Display(" ", unitNo=unitNo, advance=.TRUE.) + CALL MyDisplay(" ", unitNo=unitNo, advance=.TRUE.) END DO -END PROCEDURE dof_display2 +END PROCEDURE dof_Display2 !---------------------------------------------------------------------------- ! Display !---------------------------------------------------------------------------- -MODULE PROCEDURE dof_display3 +MODULE PROCEDURE dof_Display3 IF (ALLOCATED(vec%val)) THEN CALL Display(vec=vec%val, obj=obj, msg=msg, unitNo=unitNo) END IF -END PROCEDURE dof_display3 +END PROCEDURE dof_Display3 END SUBMODULE Methods diff --git a/src/submodules/DiffusionMatrix/src/DM_1.inc b/src/submodules/DiffusionMatrix/src/DM_1.inc index 9517abe0d..fb2e5bc73 100644 --- a/src/submodules/DiffusionMatrix/src/DM_1.inc +++ b/src/submodules/DiffusionMatrix/src/DM_1.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE DM_1(ans, test, trial, k, opt) REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! realval = trial%js * trial%ws * trial%thickness * kbar !! diff --git a/src/submodules/DiffusionMatrix/src/DM_10.inc b/src/submodules/DiffusionMatrix/src/DM_10.inc index 040bbf3c3..de1be138e 100644 --- a/src/submodules/DiffusionMatrix/src/DM_10.inc +++ b/src/submodules/DiffusionMatrix/src/DM_10.inc @@ -36,8 +36,8 @@ PURE SUBROUTINE DM_10(ans, test, trial, c1, c2, opt) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) - CALL getInterpolation(obj=trial, interpol=matbar, val=c2) + CALL getInterpolation(obj=trial, ans=c2bar, val=c1) + CALL getInterpolation(obj=trial, ans=matbar, val=c2) CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) !! DO ii = 1, SIZE(c2bar, 2) diff --git a/src/submodules/DiffusionMatrix/src/DM_3.inc b/src/submodules/DiffusionMatrix/src/DM_3.inc index 5e67de895..40e78772f 100644 --- a/src/submodules/DiffusionMatrix/src/DM_3.inc +++ b/src/submodules/DiffusionMatrix/src/DM_3.inc @@ -36,7 +36,7 @@ PURE SUBROUTINE DM_3(ans, test, trial, k, opt) REAL(DFP), ALLOCATABLE :: realval(:) INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! realval = trial%js * trial%ws * trial%thickness !! diff --git a/src/submodules/DiffusionMatrix/src/DM_5.inc b/src/submodules/DiffusionMatrix/src/DM_5.inc index 19137878e..0fdbcfdce 100644 --- a/src/submodules/DiffusionMatrix/src/DM_5.inc +++ b/src/submodules/DiffusionMatrix/src/DM_5.inc @@ -41,9 +41,9 @@ PURE SUBROUTINE DM_5(ans, test, trial, c1, c2, opt) !! !! main !! - CALL getInterpolation(obj=trial, Interpol=realval, val=c1) + CALL getInterpolation(obj=trial, ans=realval, val=c1) !! - CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) + CALL getInterpolation(obj=trial, ans=kbar, val=c2) !! realval = realval * trial%js * trial%ws * trial%thickness !! diff --git a/src/submodules/DiffusionMatrix/src/DM_6.inc b/src/submodules/DiffusionMatrix/src/DM_6.inc index 1219d3a13..5ab22b8b3 100644 --- a/src/submodules/DiffusionMatrix/src/DM_6.inc +++ b/src/submodules/DiffusionMatrix/src/DM_6.inc @@ -40,8 +40,8 @@ PURE SUBROUTINE DM_6(ans, test, trial, c1, c2, opt) REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, Interpol=realval, val=c2) + CALL getInterpolation(obj=trial, ans=cbar, val=c1) + CALL getInterpolation(obj=trial, ans=realval, val=c2) realval = realval * trial%js * trial%ws * trial%thickness * cbar CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) diff --git a/src/submodules/DiffusionMatrix/src/DM_7.inc b/src/submodules/DiffusionMatrix/src/DM_7.inc index 079844613..1fb143ef8 100644 --- a/src/submodules/DiffusionMatrix/src/DM_7.inc +++ b/src/submodules/DiffusionMatrix/src/DM_7.inc @@ -41,7 +41,7 @@ PURE SUBROUTINE DM_7(ans, test, trial, c1, c2, opt) !! main CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) - CALL getInterpolation(obj=trial, interpol=realval, val=c1) + CALL getInterpolation(obj=trial, ans=realval, val=c1) realval = realval * trial%js * trial%ws * trial%thickness CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) diff --git a/src/submodules/DiffusionMatrix/src/DM_8.inc b/src/submodules/DiffusionMatrix/src/DM_8.inc index 9fac7662e..6feb3670b 100644 --- a/src/submodules/DiffusionMatrix/src/DM_8.inc +++ b/src/submodules/DiffusionMatrix/src/DM_8.inc @@ -39,9 +39,9 @@ PURE SUBROUTINE DM_8(ans, test, trial, c1, c2, opt) REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) + CALL getInterpolation(obj=trial, ans=k1bar, val=c1) !! - CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) + CALL getInterpolation(obj=trial, ans=k2bar, val=c2) !! realval = trial%js * trial%ws * trial%thickness !! diff --git a/src/submodules/DiffusionMatrix/src/DM_9.inc b/src/submodules/DiffusionMatrix/src/DM_9.inc index c2367cc8d..86f91763f 100644 --- a/src/submodules/DiffusionMatrix/src/DM_9.inc +++ b/src/submodules/DiffusionMatrix/src/DM_9.inc @@ -36,8 +36,8 @@ PURE SUBROUTINE DM_9(ans, test, trial, c1, c2, opt) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii !! main - CALL getInterpolation(obj=trial, interpol=matbar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL getInterpolation(obj=trial, ans=matbar, val=c1) + CALL getInterpolation(obj=trial, ans=c2bar, val=c2) CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) !! DO ii = 1, SIZE(c2bar, 2) diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 index 358c371d7..e877c2974 100644 --- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 @@ -77,7 +77,7 @@ MODULE PROCEDURE DiffusionMatrix_2 REAL(DFP), ALLOCATABLE :: realval(:), kbar(:) INTEGER(I4B) :: ii -CALL GetInterpolation(obj=trial, Interpol=kbar, val=k) +CALL GetInterpolation(obj=trial, ans=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) @@ -96,7 +96,7 @@ REAL(DFP) :: realval, kbar(trial%nips) INTEGER(I4B) :: ii -CALL GetInterpolation_(obj=trial, Interpol=kbar, val=k, tsize=ii) +CALL GetInterpolation_(obj=trial, ans=kbar, val=k, tsize=ii) nrow = test%nns ncol = trial%nns ans(1:nrow, 1:ncol) = 0.0 @@ -123,8 +123,10 @@ MODULE PROCEDURE DiffusionMatrix_3 REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +CALL getProjectionOfdNdXt(obj=test, ans=c1bar, c=k, & + crank=TypeFEVariableVector) +CALL getProjectionOfdNdXt(obj=trial, ans=c2bar, c=k, & + crank=TypeFEVariableVector) realval = trial%js * trial%ws * trial%thickness CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) @@ -144,8 +146,10 @@ INTEGER(I4B) :: ii, jj, kk REAL(DFP), PARAMETER :: one = 1.0_DFP -CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=k, nrow=nrow, ncol=ii) -CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=k, nrow=ncol, ncol=ii) +CALL getProjectionOfdNdXt_(obj=test, ans=c1bar, c=k, nrow=nrow, ncol=ii, & + crank=TypeFEVariableVector) +CALL getProjectionOfdNdXt_(obj=trial, ans=c2bar, c=k, nrow=ncol, ncol=ii, & + crank=TypeFEVariableVector) ans(1:nrow, 1:ncol) = 0.0 @@ -172,7 +176,7 @@ REAL(DFP), ALLOCATABLE :: kbar(:, :, :) REAL(DFP), ALLOCATABLE :: realval(:) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=kbar, val=k) +CALL getInterpolation(obj=trial, ans=kbar, val=k) realval = trial%js * trial%ws * trial%thickness CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) @@ -194,7 +198,7 @@ REAL(DFP), PARAMETER :: one = 1.0_DFP INTEGER(I4B) :: ii, jj, kk -CALL getInterpolation_(obj=trial, Interpol=kbar, val=k, & +CALL getInterpolation_(obj=trial, ans=kbar, val=k, & dim1=ii, dim2=jj, dim3=kk) nrow = test%nns ncol = trial%nns @@ -222,8 +226,8 @@ MODULE PROCEDURE DiffusionMatrix_5 REAL(DFP), ALLOCATABLE :: realval(:), cbar(:) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=cbar, val=c1) -CALL getInterpolation(obj=trial, Interpol=realval, val=c2) +CALL getInterpolation(obj=trial, ans=cbar, val=c1) +CALL getInterpolation(obj=trial, ans=realval, val=c2) realval = realval * trial%js * trial%ws * trial%thickness * cbar CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) @@ -242,8 +246,8 @@ REAL(DFP) :: realval(trial%nips), cbar(trial%nips) INTEGER(I4B) :: ii -CALL getInterpolation_(obj=trial, Interpol=cbar, val=c1, tsize=ii) -CALL getInterpolation_(obj=trial, Interpol=realval, val=c2, tsize=ii) +CALL GetInterpolation_(obj=trial, ans=cbar, val=c1, tsize=ii) +CALL GetInterpolation_(obj=trial, ans=realval, val=c2, tsize=ii) realval = realval * trial%js * trial%ws * trial%thickness * cbar nrow = test%nns @@ -271,11 +275,16 @@ MODULE PROCEDURE DiffusionMatrix_6 REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:) INTEGER(I4B) :: ii -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) -CALL getInterpolation(obj=trial, interpol=realval, val=c1) + +CALL GetProjectionOfdNdXt(obj=test, ans=c1bar, c=c2, & + crank=TypeFEVariableVector) +CALL GetProjectionOfdNdXt(obj=trial, ans=c2bar, c=c2, & + crank=TypeFEVariableVector) + +CALL GetInterpolation(obj=trial, ans=realval, val=c1) realval = realval * trial%js * trial%ws * trial%thickness -CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) + +CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) END DO @@ -293,12 +302,11 @@ INTEGER(I4B) :: ii, jj, kk REAL(DFP), PARAMETER :: one = 1.0_DFP -CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=c2, & - nrow=nrow, ncol=ii) -CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=c2, & - nrow=ncol, ncol=ii) - -CALL getInterpolation_(obj=trial, interpol=realval, val=c1, & +CALL GetProjectionOfdNdXt_(obj=test, ans=c1bar, c=c2, & + nrow=nrow, ncol=ii, crank=TypeFEVariableVector) +CALL GetProjectionOfdNdXt_(obj=trial, ans=c2bar, c=c2, & + nrow=ncol, ncol=ii, crank=TypeFEVariableVector) +CALL GetInterpolation_(obj=trial, ans=realval, val=c1, & tsize=ii) realval = realval * trial%js * trial%ws * trial%thickness @@ -316,7 +324,6 @@ nrow = opt * nrow ncol = opt * ncol END IF - END PROCEDURE DiffusionMatrix6_ !---------------------------------------------------------------------------- @@ -327,8 +334,9 @@ REAL(DFP), ALLOCATABLE :: realval(:) REAL(DFP), ALLOCATABLE :: kbar(:, :, :) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=realval, val=c1) -CALL getInterpolation(obj=trial, Interpol=kbar, val=c2) + +CALL GetInterpolation(obj=trial, ans=realval, val=c1) +CALL GetInterpolation(obj=trial, ans=kbar, val=c2) realval = realval * trial%js * trial%ws * trial%thickness DO ii = 1, SIZE(realval) ans = ans + realval(ii) * MATMUL(& @@ -363,8 +371,10 @@ INTEGER(I4B) :: ii !! main CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2) +CALL getProjectionOfdNdXt(obj=test, ans=c1bar, c=c1, & + crank=TypeFEVariableVector) +CALL getProjectionOfdNdXt(obj=trial, ans=c2bar, c=c2, & + crank=TypeFEVariableVector) realval = trial%js * trial%ws * trial%thickness DO ii = 1, SIZE(realval) ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii)) @@ -384,15 +394,17 @@ REAL(DFP), ALLOCATABLE :: realval(:) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, interpol=c2bar, val=c1) -CALL getInterpolation(obj=trial, interpol=matbar, val=c2) +CALL getInterpolation(obj=trial, ans=c2bar, val=c1) +CALL getInterpolation(obj=trial, ans=matbar, val=c2) CALL Reallocate(c1bar, SIZE(matbar, 2), SIZE(matbar, 3)) DO ii = 1, SIZE(c2bar, 2) c1bar(:, ii) = MATMUL(c2bar(:, ii), matbar(:, :, ii)) END DO k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace) -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +CALL getProjectionOfdNdXt(obj=test, ans=c1bar, c=k, & + crank=TypeFEVariableVector) +CALL getProjectionOfdNdXt(obj=trial, ans=c2bar, c=k, & + crank=TypeFEVariableVector) realval = trial%js * trial%ws * trial%thickness CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) @@ -427,15 +439,17 @@ REAL(DFP), ALLOCATABLE :: realval(:) TYPE(FEVariable_) :: k INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, interpol=matbar, val=c1) -CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) +CALL getInterpolation(obj=trial, ans=matbar, val=c1) +CALL getInterpolation(obj=trial, ans=c2bar, val=c2) CALL Reallocate(c1bar, SIZE(matbar, 1), SIZE(matbar, 3)) DO ii = 1, SIZE(c2bar, 2) c1bar(:, ii) = MATMUL(matbar(:, :, ii), c2bar(:, ii)) END DO k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace) -CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k) -CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k) +CALL GetProjectionOfdNdXt(obj=test, ans=c1bar, c=k, & + crank=TypeFEVariableVector) +CALL GetProjectionOfdNdXt(obj=trial, ans=c2bar, c=k, & + crank=TypeFEVariableVector) realval = trial%js * trial%ws * trial%thickness CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) DO ii = 1, SIZE(realval) @@ -452,8 +466,8 @@ MODULE PROCEDURE DiffusionMatrix_13 REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:) INTEGER(I4B) :: ii -CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1) -CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2) +CALL getInterpolation(obj=trial, ans=k1bar, val=c1) +CALL getInterpolation(obj=trial, ans=k2bar, val=c2) CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) realval = trial%js * trial%ws * trial%thickness DO ii = 1, SIZE(realval) @@ -559,7 +573,7 @@ PURE SUBROUTINE DiffusionMatrix_15a(test, trial, k, ans) INTEGER(I4B) :: ii, jj, nsd, ips nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + CALL GetInterpolation(obj=trial, ans=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd @@ -589,7 +603,7 @@ PURE SUBROUTINE DiffusionMatrix_15b(test, trial, k, ans) INTEGER(I4B) :: ii, jj, nsd, ips nsd = test%nsd CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd) - CALL getInterpolation(obj=trial, Interpol=kbar, val=k) + CALL GetInterpolation(obj=trial, ans=kbar, val=k) realval = trial%js * trial%ws * trial%thickness * kbar DO ips = 1, SIZE(trial%N, 2) DO jj = 1, nsd diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 index 4d43bd2a3..9dcba89fc 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 @@ -27,11 +27,11 @@ MODULE PROCEDURE ElasticNitscheMatrix1a REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:), evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda) -CALL getInterpolation(obj=trial, interpol=muBar, val=mu) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) -ans = ElasticNitscheMatrix( & -& test=test, trial=trial, lambda=lamBar, mu=muBar, evec=evecBar) +CALL GetInterpolation(obj=trial, ans=lamBar, val=lambda) +CALL GetInterpolation(obj=trial, ans=muBar, val=mu) +CALL GetInterpolation(obj=trial, ans=evecBar, val=evec) +ans = ElasticNitscheMatrix(test=test, trial=trial, lambda=lamBar, & + mu=muBar, evec=evecBar) DEALLOCATE (lamBar, muBar, evecBar) END PROCEDURE ElasticNitscheMatrix1a @@ -41,7 +41,7 @@ MODULE PROCEDURE ElasticNitscheMatrix1b REAL(DFP), ALLOCATABLE :: evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +CALL GetInterpolation(obj=trial, ans=evecBar, val=evec) ans = ElasticNitscheMatrix( & & test=test, & & trial=trial, & @@ -57,7 +57,7 @@ MODULE PROCEDURE ElasticNitscheMatrix1c REAL(DFP), ALLOCATABLE :: evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +CALL getInterpolation(obj=trial, ans=evecBar, val=evec) ans = ElasticNitscheMatrix(test=test, trial=trial, & & lambda=lambda, mu=mu, evec=evecBar) DEALLOCATE (evecBar) @@ -298,10 +298,10 @@ MODULE PROCEDURE ElasticNitscheMatrix1j REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:) -CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda) -CALL getInterpolation(obj=trial, interpol=muBar, val=mu) -ans = ElasticNitscheMatrix( & -& test=test, trial=trial, lambda=lamBar, mu=muBar, dim=dim) +CALL GetInterpolation(obj=trial, ans=lamBar, val=lambda) +CALL GetInterpolation(obj=trial, ans=muBar, val=mu) +ans = ElasticNitscheMatrix(test=test, trial=trial, lambda=lamBar, & + mu=muBar, dim=dim) DEALLOCATE (lamBar, muBar) END PROCEDURE ElasticNitscheMatrix1j diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 index 0424b6a0f..73845954c 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 @@ -27,8 +27,8 @@ MODULE PROCEDURE ElasticNitscheMatrix3a REAL(DFP), ALLOCATABLE :: alphaBar(:), evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=alphaBar, val=alpha) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +CALL GetInterpolation(obj=trial, ans=alphaBar, val=alpha) +CALL GetInterpolation(obj=trial, ans=evecBar, val=evec) ans = ElasticNitscheMatrix( & & test=test, trial=trial, alpha=alphaBar, evec=evecBar) DEALLOCATE (alphaBar, evecBar) @@ -40,7 +40,7 @@ MODULE PROCEDURE ElasticNitscheMatrix3b REAL(DFP), ALLOCATABLE :: evecBar(:, :) -CALL getInterpolation(obj=trial, interpol=evecBar, val=evec) +CALL getInterpolation(obj=trial, ans=evecBar, val=evec) ans = ElasticNitscheMatrix( & & test=test, trial=trial, alpha=alpha, evec=evecBar) DEALLOCATE (evecBar) @@ -175,9 +175,8 @@ MODULE PROCEDURE ElasticNitscheMatrix3f REAL(DFP), ALLOCATABLE :: alphaBar(:) -CALL getInterpolation(obj=trial, interpol=alphaBar, val=alpha) -ans = ElasticNitscheMatrix( & -& test=test, trial=trial, alpha=alphaBar, dim=dim) +CALL GetInterpolation(obj=trial, ans=alphaBar, val=alpha) +ans = ElasticNitscheMatrix(test=test, trial=trial, alpha=alphaBar, dim=dim) DEALLOCATE (alphaBar) END PROCEDURE ElasticNitscheMatrix3f diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 index 3a5fb73d3..3fc5a008f 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 @@ -123,8 +123,8 @@ MODULE PROCEDURE ElasticNitscheMatrixNormal1c REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:) -CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda) -CALL getInterpolation(obj=trial, interpol=muBar, val=mu) +CALL GetInterpolation(obj=trial, ans=lamBar, val=lambda) +CALL GetInterpolation(obj=trial, ans=muBar, val=mu) ans = ElasticNitscheMatrixNormal( & & test=test, trial=trial, lambda=lamBar, mu=muBar) DEALLOCATE (lamBar, muBar) diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 index 677cb68ab..ab0021934 100644 --- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 +++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 @@ -119,7 +119,7 @@ ! ! MODULE PROCEDURE ElasticNitscheMatrixTangent1c ! REAL(DFP), ALLOCATABLE :: muBar(:) -! CALL getInterpolation(obj=trial, interpol=muBar, val=mu) +! CALL getInterpolation(obj=trial, ans=muBar, val=mu) ! ans = ElasticNitscheMatrixTangent( & ! & test=test, trial=trial, mu=muBar) ! DEALLOCATE (muBar) diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt index bc0b5a57d..113ff1297 100644 --- a/src/submodules/ElemshapeData/CMakeLists.txt +++ b/src/submodules/ElemshapeData/CMakeLists.txt @@ -26,6 +26,9 @@ target_sources( ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90 ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90 ${src_path}/ElemshapeData_InterpolMethods@Methods.F90 + ${src_path}/ElemshapeData_ScalarInterpolMethods@Methods.F90 + ${src_path}/ElemshapeData_VectorInterpolMethods@Methods.F90 + ${src_path}/ElemshapeData_MatrixInterpolMethods@Methods.F90 ${src_path}/ElemshapeData_IOMethods@Methods.F90 ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90 ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90 diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 index 9c8f20e39..b442e106f 100755 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 @@ -20,10 +20,9 @@ ! summary: Constructor method for ElemshapeData_ and STElemshapeData_ SUBMODULE(ElemshapeData_ConstructorMethods) Methods +USE GlobalData, ONLY: stderr USE ReallocateUtility, ONLY: Reallocate - USE QuadraturePoint_Method, ONLY: GetQuadraturePoints - USE ErrorHandling, ONLY: Errormsg IMPLICIT NONE @@ -33,12 +32,12 @@ ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_Allocate +MODULE PROCEDURE obj_Allocate LOGICAL(LGT) :: isok CALL Reallocate(obj%N, nns, nips) CALL Reallocate(obj%dNdXi, nns, xidim, nips) -CALL Reallocate(obj%Normal, 3, nips) +CALL Reallocate(obj%normal, 3, nips) CALL Reallocate(obj%dNdXt, nns, nsd, nips) CALL Reallocate(obj%jacobian, nsd, xidim, nips) CALL Reallocate(obj%js, nips) @@ -52,41 +51,32 @@ obj%nns = nns isok = PRESENT(nnt) - -IF (isok) THEN - SELECT TYPE (obj); TYPE is (STElemShapeData_) - obj%nnt = nnt - - CALL Reallocate(obj%T, nnt) - CALL Reallocate(obj%dTdTheta, nnt) - CALL Reallocate(obj%dNTdt, nns, nnt, nips) - CALL Reallocate(obj%dNTdXt, nns, nnt, nsd, nips) - - END SELECT -END IF - -END PROCEDURE elemsd_Allocate +IF (.NOT. isok) RETURN + +SELECT TYPE (obj); TYPE is (STElemShapeData_) + obj%nnt = nnt + CALL Reallocate(obj%T, nnt) + CALL Reallocate(obj%dTdTheta, nnt) + CALL Reallocate(obj%dNTdt, nns, nnt, nips) + CALL Reallocate(obj%dNTdXt, nns, nnt, nsd, nips) +END SELECT +END PROCEDURE obj_Allocate !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_Initiate1 - -CALL ErrorMSG( & - & Msg="[WORK IN PROGRESS]", & - & File=__FILE__, & - & Routine="elemsd_Initiate1()", & - & Line=__LINE__, & - & UnitNo=stdout) +MODULE PROCEDURE obj_Initiate1 +CALL ErrorMSG(msg="[WORK IN PROGRESS]", file=__FILE__, & + routine="obj_Initiate1()", line=__LINE__, unitno=stderr) STOP -END PROCEDURE elemsd_Initiate1 +END PROCEDURE obj_Initiate1 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_Initiate2 +MODULE PROCEDURE obj_Initiate2 INTEGER(I4B) :: ii, jj, kk, nns, nsd, xidim, nips, nnt, ll, nnt nns = obj2%nns @@ -98,8 +88,8 @@ nnt = obj2%nnt END SELECT -CALL elemsd_Allocate(obj=obj1, nsd=nsd, xidim=xidim, nns=nns, & - nips=nips, nnt=nnt) +CALL obj_Allocate(obj=obj1, nsd=nsd, xidim=xidim, nns=nns, & + nips=nips, nnt=nnt) DO CONCURRENT(jj=1:nips, ii=1:nns) obj1%N(ii, jj) = obj2%N(ii, jj) @@ -128,7 +118,7 @@ SELECT TYPE (obj1); TYPE is (STElemShapeData_) SELECT TYPE (obj2); TYPE is (STElemShapeData_) obj1%wt = obj2%wt -! obj1%theta = obj2%theta + ! obj1%theta = obj2%theta obj1%jt = obj2%jt obj1%nnt = obj2%nnt nnt = obj1%nnt @@ -149,21 +139,26 @@ END SELECT END SELECT -END PROCEDURE elemsd_Initiate2 +END PROCEDURE obj_Initiate2 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE stsd_Initiate -INTEGER(I4B) :: tip, ip, nnt +MODULE PROCEDURE obj_Initiate3 +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tip, ip, nnt, tsize tip = elemsd%nips -IF (ALLOCATED(obj)) THEN - DO ip = 1, SIZE(obj) +isok = ALLOCATED(obj) +IF (isok) THEN + tsize = SIZE(obj) + + DO ip = 1, tsize CALL DEALLOCATE (obj(ip)) END DO + DEALLOCATE (obj) END IF @@ -183,13 +178,13 @@ obj(ip)%dTdTheta(1:nnt) = elemsd%dNdXi(1:nnt, 1, ip) END DO -END PROCEDURE stsd_Initiate +END PROCEDURE obj_Initiate3 !---------------------------------------------------------------------------- ! Deallocate !---------------------------------------------------------------------------- -MODULE PROCEDURE elemsd_Deallocate +MODULE PROCEDURE obj_Deallocate IF (ALLOCATED(obj%normal)) DEALLOCATE (obj%normal) IF (ALLOCATED(obj%N)) DEALLOCATE (obj%N) IF (ALLOCATED(obj%dNdXi)) DEALLOCATE (obj%dNdXi) @@ -216,7 +211,7 @@ IF (ALLOCATED(obj%dNTdt)) DEALLOCATE (obj%dNTdt) IF (ALLOCATED(obj%dNTdXt)) DEALLOCATE (obj%dNTdXt) END SELECT -END PROCEDURE elemsd_Deallocate +END PROCEDURE obj_Deallocate !---------------------------------------------------------------------------- ! diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 index 97ba604d5..deb176da3 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90 @@ -53,7 +53,8 @@ PURE SUBROUTINE elemsd_getHRGNParam_a(obj, h, val, opt) !! !! Call get projection of dNdXt in q !! - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) + CALL GetProjectionOfdNdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) !! !! Calculate hmin and hmax !! @@ -108,7 +109,8 @@ PURE SUBROUTINE elemsd_getHRGNParam_b(obj, h, val, opt) !! !! Get Projection of dNTdXt in q !! - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) + CALL GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) !! !! Calculate hmin and hmax !! diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 index 6c7862129..94b39a313 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 @@ -16,9 +16,14 @@ ! SUBMODULE(ElemShapeData_Hierarchical) Methods +USE ErrorHandling, ONLY: Errormsg +USE GlobalData, ONLY: stderr + USE InputUtility, ONLY: Input -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate +USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate, & + Refelem_GetFaceElemType => GetFaceElemType, & + Refelem_RefCoord_ => RefCoord_ USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE @@ -40,6 +45,10 @@ IMPLICIT NONE +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = "ElemshapeData_Hierarchical@Methods.F90" +#endif + CONTAINS !---------------------------------------------------------------------------- @@ -48,7 +57,7 @@ MODULE PROCEDURE HierarchicalElemShapeData1 REAL(DFP), ALLOCATABLE :: temp(:, :, :) -INTEGER(I4B) :: ipType0, basisType0, nips, nns, ii, jj, kk +INTEGER(I4B) :: nips, nns, ii, jj, kk ! CALL DEALLOCATE (obj) @@ -101,11 +110,13 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HierarchicalElemShapeData2 -CALL HierarchicalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & - xidim=refelem%xidimension, elemType=refelem%name, & - refelemCoord=refelem%xij, domainName=refelem%domainName, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +CALL HierarchicalElemShapeData( & + obj=obj, quad=quad, nsd=refelem%nsd, xidim=refelem%xidimension, & + elemType=refelem%name, refelemCoord=refelem%xij, & + domainName=refelem%domainName, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, & + edgeOrient=edgeOrient) END PROCEDURE HierarchicalElemShapeData2 !---------------------------------------------------------------------------- @@ -113,9 +124,56 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE HierarchicalElemShapeData3 -CALL HierarchicalElemShapeData2(obj=obj, quad=quad, refelem=refelem, & - cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, & - cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient) +CALL HierarchicalElemShapeData( & + obj=obj, quad=quad, refelem=refelem, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder, cellOrient=cellOrient, & + faceOrient=faceOrient, edgeOrient=edgeOrient) END PROCEDURE HierarchicalElemShapeData3 +!---------------------------------------------------------------------------- +! HierarchicalFacetElemShapeData +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HierarchicalFacetElemShapeData1 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "HierarchicalFacetElemShapeData1()" +#endif + +INTEGER(I4B) :: faceElemType, faceXidim, tFaceNodes, nrow, ncol +REAL(DFP) :: faceRefelemCoord(3, 8) + +CALL HierarchicalElemShapeData(obj=obj, quad=quad, nsd=nsd, xidim=xidim, & + elemType=elemType, refelemCoord=refelemCoord, & + domainName=domainName, cellOrder=cellOrder, & + faceOrder=faceOrder, edgeOrder=edgeOrder, & + cellOrient=cellOrient, faceOrient=faceOrient, & + edgeOrient=edgeOrient) + +CALL Refelem_GetFaceElemType(elemType=elemType, & + localFaceNumber=localFaceNumber, & + faceElemType=faceElemType, & + opt=1, tFaceNodes=tFaceNodes) + +CALL Refelem_RefCoord_(elemType=faceElemType, refElem=domainName, & + ans=faceRefelemCoord, nrow=nrow, ncol=ncol) + +#ifdef DEBUG_VER +CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "This is routine is under development") +#endif + +faceXidim = xidim - 1 +CALL HierarchicalElemShapeData( & + obj=facetElemsd, quad=facetQuad, nsd=nsd, xidim=faceXidim, & + elemType=faceElemType, refelemCoord=faceRefelemCoord(1:nrow, 1:ncol), & + domainName=domainName, cellOrder=faceOrder(:, localFaceNumber)) + +END PROCEDURE HierarchicalFacetElemShapeData1 + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 index 321a86582..9f10658b5 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 @@ -16,952 +16,183 @@ ! SUBMODULE(ElemshapeData_InterpolMethods) Methods -USE BaseMethod +USE BaseType, ONLY: TypeFEVariableOpt +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_,& + FEVariableInitiate => Initiate, & + FEVariableGetRank => GetRank, & + FEVariableGetTotalShape => GetTotalShape, & + FEVariableSize => Size + IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE scalar_getinterpolation_1 - -!---------------------------------------------------------------------------- -! +! GetInterpolation !---------------------------------------------------------------------------- -MODULE PROCEDURE scalar_getinterpolation1_ -tsize = SIZE(obj%N, 2) -interpol(1:tsize) = MATMUL(val, obj%N) -END PROCEDURE scalar_getinterpolation1_ +MODULE PROCEDURE GetInterpolation1 +INTEGER(I4B) :: s(TypeFEVariableOpt%maxRank), totalShape, myrank, mylen -!---------------------------------------------------------------------------- -! 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 +IF (ans%isInit) THEN + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +ELSE -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- + myrank = FEVariableGetRank(val) + totalShape = 0 -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_ + SELECT CASE (myrank) + CASE (TypeFEVariableOpt%scalar) + totalShape = 1 + s(1) = obj%nips + mylen = s(1) -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- + CASE (TypeFEVariableOpt%vector) + totalShape = 2 + s(1) = FEVariableSize(val, 1) + s(2) = obj%nips + mylen = s(1) * s(2) -MODULE PROCEDURE scalar_getinterpolation_3 -INTEGER(I4B) :: ipt -CALL reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) -DO ipt = 1, SIZE(obj) - interpol(:, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) -END DO -END PROCEDURE scalar_getinterpolation_3 + CASE (TypeFEVariableOpt%matrix) + totalShape = 3 + s(1) = FEVariableSize(val, 1) + s(2) = FEVariableSize(val, 2) + s(3) = obj%nips + mylen = s(1) * s(2) * s(3) -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation3_ -INTEGER(I4B) :: ipt -nrow = SIZE(obj(1)%N, 2) -ncol = SIZE(obj) -DO ipt = 1, ncol - interpol(1:nrow, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) -END DO -END PROCEDURE scalar_getinterpolation3_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation_4 -SELECT CASE (val%vartype) -CASE (Constant) - CALL Reallocate(interpol, SIZE(obj%N, 2)) - interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - interpol = interpolation(obj, & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) - ELSE - interpol = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - IF (val%DefineOn .EQ. Nodal) THEN - interpol = STinterpolation(obj, & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) - END IF END SELECT -END SELECT -END PROCEDURE scalar_getinterpolation_4 -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- + CALL FEVariableInitiate(obj=ans, & + s=s(1:totalShape), & + defineon=TypeFEVariableOpt%quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=FEVariableGetRank(val), & + len=mylen) -MODULE PROCEDURE scalar_getinterpolation4_ -SELECT CASE (val%vartype) -CASE (Constant) - tsize = SIZE(obj%N, 2) - interpol(1:tsize) = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, interpol=interpol, & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpace), & - tsize=tsize) - ELSE - CALL Get_(obj=val, rank=TypeFEVariableScalar, & - vartype=TypeFEVariableSpace, & - val=interpol, tsize=tsize) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, interpol=interpol, & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpaceTime), & - tsize=tsize) - END IF - END SELECT -END SELECT -END PROCEDURE scalar_getinterpolation4_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation_5 -INTEGER(I4B) :: ii -! REAL(DFP), ALLOCATABLE :: m1(:) -! !! main -! CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) -! DO ii = 1, SIZE(obj) -! CALL getInterpolation(obj=obj(ii), interpol=m1, val=val) -! interpol(:, ii) = m1 -! END DO -! DEALLOCATE (m1) -CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj)) -!! -SELECT CASE (val%vartype) -!! -!! -!! -!! -CASE (Constant) - !! - interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -!! -!! -!! -!! -CASE (Space) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, ii) = Interpolation(obj(ii), & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpace)) - END DO - !! - ELSE - !! - interpol(:, 1) = Get(val, TypeFEVariableScalar, TypeFEVariableSpace) - !! - DO ii = 2, SIZE(obj) - interpol(:, ii) = interpol(:, 1) - END DO - !! - END IF -!! -!! -!! -!! -CASE (SpaceTime) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, ii) = STinterpolation(obj(ii), & - & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime)) - END DO - !! - ELSE - interpol = Get(val, TypeFEVariableScalar, typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE scalar_getinterpolation_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE scalar_getinterpolation5_ -INTEGER(I4B) :: ii -nrow = SIZE(obj(1)%N, 2) -ncol = SIZE(obj) -SELECT CASE (val%vartype) -CASE (Constant) - interpol(1:nrow, 1:ncol) = Get(val, TypeFEVariableScalar, TypeFEVariableConstant) -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, ncol - CALL GetInterpolation_(obj=obj(ii), & - interpol=interpol(1:nrow, ii), & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpace), & - tsize=nrow) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableScalar, & - vartype=TypeFEVariableSpace, & - val=interpol(1:nrow, 1), tsize=nrow) - DO ii = 2, ncol - interpol(1:nrow, ii) = interpol(1:nrow, 1) - END DO - END IF -CASE (SpaceTime) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, ncol - CALL GetInterpolation_(obj=obj(ii), & - interpol=interpol(1:nrow, ii), & - val=Get(val, TypeFEVariableScalar, & - TypeFEVariableSpaceTime), & - tsize=nrow) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableScalar, & - vartype=typeFEVariableSpaceTime, & - val=interpol, nrow=nrow, ncol=ncol) - END IF -END SELECT - -END PROCEDURE scalar_getinterpolation5_ - -!--------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation_1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation1_ -nrow = SIZE(val, 1) -ncol = SIZE(obj%N, 2) -interpol(1:nrow, 1:ncol) = MATMUL(val, obj%N) -END PROCEDURE vector_getinterpolation1_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_2 -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE vector_getinterpolation_2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation2_ -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - nrow = SIZE(val, 1) - ncol = SIZE(obj%N, 2) - interpol(1:nrow, 1:ncol) = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE vector_getinterpolation2_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_3 -INTEGER(I4B) :: ipt -!! -CALL reallocate(interpol, SIZE(val, 1), SIZE(obj(1)%N, 2), SIZE(obj)) -DO ipt = 1, SIZE(obj) - interpol(:, :, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N) -END DO -END PROCEDURE vector_getinterpolation_3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation3_ -INTEGER(I4B) :: ipt - -dim1 = SIZE(val, 1) -dim2 = SIZE(obj(1)%N, 2) -dim3 = SIZE(obj) -DO ipt = 1, dim3 - interpol(1:dim1, 1:dim2, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), & - obj(ipt)%N) -END DO -END PROCEDURE vector_getinterpolation3_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_4 -REAL(DFP), ALLOCATABLE :: m1(:) -INTEGER(I4B) :: ii -!! main -SELECT CASE (val%vartype) -!! -!! Constant -!! -CASE (Constant) - !! - m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant) - CALL Reallocate(interpol, SIZE(m1), SIZE(obj%N, 2)) - DO ii = 1, SIZE(interpol, 2) - interpol(:, ii) = m1 - END DO - DEALLOCATE (m1) -!! -!! Space -!! -CASE (Space) - !! - IF (val%DefineOn .EQ. Nodal) THEN - interpol = interpolation(obj, & - & Get(val, TypeFEVariableVector, TypeFEVariableSpace)) - ELSE - interpol = Get(val, TypeFEVariableVector, TypeFEVariableSpace) - END IF -!! -!! SpaceTime -!! -CASE (SpaceTime) - !! - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - interpol = STinterpolation(obj, & - & Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) - END SELECT -END SELECT -!! -!! -!! -END PROCEDURE vector_getinterpolation_4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation4_ -INTEGER(I4B) :: ii - -SELECT CASE (val%vartype) -CASE (Constant) - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableConstant, & - val=interpol(:, 1), tsize=nrow) - ncol = SIZE(obj%N, 2) - DO ii = 2, ncol - interpol(1:nrow, ii) = interpol(1:nrow, 1) - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpace), & - interpol=interpol, & - nrow=nrow, ncol=ncol) - ELSE - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableSpace, & - val=interpol, nrow=nrow, ncol=ncol) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpaceTime), & - interpol=interpol, & - nrow=nrow, ncol=ncol) - END SELECT -END SELECT - -END PROCEDURE vector_getinterpolation4_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation_5 -! INTEGER(I4B) :: ii -! INTEGER(I4B), ALLOCATABLE :: s(:) -! REAL(DFP), ALLOCATABLE :: m2(:, :) -! !! main -! s = SHAPE(val) -! CALL Reallocate(interpol, s(1), SIZE(obj(1)%N, 2), SIZE(obj)) -! DO ii = 1, SIZE(obj) -! CALL getInterpolation(obj=obj(ii), interpol=m2, val=val) -! interpol(:, :, ii) = m2 -! END DO -! DEALLOCATE (m2, s) -!! -REAL(DFP), ALLOCATABLE :: m1(:) -INTEGER(I4B) :: ii, jj -INTEGER(I4B), ALLOCATABLE :: s(:) -!! -!! main -!! -s = SHAPE(val) -CALL Reallocate(interpol, s(1), SIZE(obj(1)%N, 2), SIZE(obj)) -!! -SELECT CASE (val%vartype) -!! -!! Constant -!! -CASE (Constant) - !! - m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant) - !! - DO jj = 1, SIZE(interpol, 3) - DO ii = 1, SIZE(interpol, 2) - interpol(:, ii, jj) = m1 - END DO - END DO - DEALLOCATE (m1) -!! -!! Space -!! -CASE (Space) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, :, ii) = Interpolation(obj(ii), & - & Get(val, TypeFEVariableVector, TypeFEVariableSpace)) - END DO - !! - ELSE - !! - interpol(:, :, 1) = Get(val, TypeFEVariableVector, TypeFEVariableSpace) - !! - DO ii = 2, SIZE(obj) - interpol(:, :, ii) = interpol(:, :, 1) - END DO - !! - END IF -!! -!! SpaceTime -!! -CASE (SpaceTime) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, :, ii) = STinterpolation(obj(ii), & - & Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime)) - END DO - !! - ELSE - interpol = Get(val, TypeFEVariableVector, typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE vector_getinterpolation_5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE vector_getinterpolation5_ -INTEGER(I4B) :: ii, jj - -dim1 = SIZE(val, 1) -dim2 = SIZE(obj(1)%N, 2) -dim3 = SIZE(obj) -SELECT CASE (val%vartype) -CASE (Constant) - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableConstant, & - val=interpol(:, 1, 1), tsize=dim1) - DO jj = 1, dim3 - DO ii = 1, dim2 - IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE - interpol(1:dim1, ii, jj) = interpol(1:dim1, 1, 1) - END DO - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, dim3 - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpace), & - interpol=interpol(1:dim1, 1:dim2, ii), & - nrow=dim1, ncol=dim2) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableSpace, & - val=interpol(:, :, 1), nrow=dim1, ncol=dim2) - DO ii = 2, SIZE(obj) - interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) - END DO - END IF -CASE (SpaceTime) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, SIZE(obj) - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableVector, & - TypeFEVariableSpaceTime), & - interpol=interpol(1:dim1, 1:dim2, ii), & - nrow=dim1, ncol=dim2) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableVector, & - vartype=TypeFEVariableSpaceTime, & - val=interpol, dim1=dim1, dim2=dim2, dim3=dim3) - END IF -END SELECT - -END PROCEDURE vector_getinterpolation5_ + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +END IF +END PROCEDURE GetInterpolation1 !---------------------------------------------------------------------------- -! getinterpolation +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE matrix_getinterpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_getinterpolation_1 +MODULE PROCEDURE GetInterpolation_1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL, PARAMETER :: no = .FALSE. -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -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_ +CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, & + nips=obj%nips, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_1 !---------------------------------------------------------------------------- -! getSTinterpolation +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE matrix_getinterpolation_2 -SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - interpol = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE matrix_getinterpolation_2 +MODULE PROCEDURE GetInterpolation_1a +INTEGER(I4B), PARAMETER :: timeIndx = 1 -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation2_ SELECT TYPE (obj) -TYPE IS (STElemShapeData_) - dim1 = SIZE(val, 1) - dim2 = SIZE(val, 2) - dim3 = SIZE(obj%N, 2) - interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(MATMUL(val, obj%T), obj%N) -END SELECT -END PROCEDURE matrix_getinterpolation2_ - -!---------------------------------------------------------------------------- -! getSTinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_3 -!! TODO -END PROCEDURE matrix_getinterpolation_3 - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_4 -INTEGER(I4B) :: i -INTEGER(I4B) :: s(2) -!! main -SELECT CASE (val%vartype) -CASE (Constant) - s(1:2) = SHAPE(val) - CALL reallocate(interpol, s(1), s(2), SIZE(obj%N, 2)) - interpol(:, :, 1) = Get(val, TypeFEVariableMatrix, & - & TypeFEVariableConstant) - DO i = 2, SIZE(interpol, 3) - interpol(:, :, i) = interpol(:, :, 1) - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - interpol = interpolation(obj, & - & Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) - ELSE - interpol = Get(val, TypeFEVariableMatrix, TypeFEVariableSpace) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - IF (val%DefineOn .EQ. Nodal) THEN - interpol = STinterpolation(obj, & - & Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) - END IF - END SELECT -END SELECT -END PROCEDURE matrix_getinterpolation_4 +TYPE IS (ElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, & + nips=obj%nips, scale=scale, & + addContribution=addContribution) +CLASS IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, N=obj%N, nns=obj%nns, & + nips=obj%nips, T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + timeIndx=timeIndx, ans=ans) +END SELECT +END PROCEDURE GetInterpolation_1a + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation2 +INTEGER(I4B) :: s(TypeFEVariableOpt%maxRank), totalShape, myrank, mylen, & + nipt + +IF (ans%isInit) THEN + CALL GetInterpolation_(obj=obj, ans=ans, val=val) +ELSE + + myrank = FEVariableGetRank(val) + totalShape = 0 + nipt = SIZE(obj) + + SELECT CASE (myrank) + CASE (TypeFEVariableOpt%scalar) + + totalShape = 2 + s(1) = obj(1)%nips + s(2) = nipt + mylen = s(1) * s(2) + + CASE (TypeFEVariableOpt%vector) + totalShape = 3 + s(1) = FEVariableSize(val, 1) + s(2) = obj(1)%nips + s(3) = nipt + mylen = s(1) * s(2) * s(3) + + CASE (TypeFEVariableOpt%matrix) + totalShape = 4 + s(1) = FEVariableSize(val, 1) + s(2) = FEVariableSize(val, 2) + s(3) = obj(1)%nips + s(4) = nipt + mylen = s(1) * s(2) * s(3) * s(4) -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation4_ -INTEGER(I4B) :: ii - -SELECT CASE (val%vartype) -CASE (Constant) - dim3 = SIZE(obj%N, 2) - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableConstant, & - val=interpol(:, :, 1), nrow=dim1, ncol=dim2) - DO ii = 2, dim3 - interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1) - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpace), & - interpol=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3) - ELSE - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableSpace, val=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3) - END IF -CASE (SpaceTime) - SELECT TYPE (obj) - TYPE IS (STElemShapeData_) - IF (val%DefineOn .EQ. Nodal) THEN - CALL GetInterpolation_(obj=obj, & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime), & - interpol=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3) - END IF END SELECT -END SELECT -END PROCEDURE matrix_getinterpolation4_ -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation_5 -! INTEGER(I4B) :: ii -! INTEGER(I4B), ALLOCATABLE :: s(:) -! REAL(DFP), ALLOCATABLE :: m3(:, :, :) -! !! main -! s = SHAPE(val) -! CALL Reallocate(interpol, s(1), s(2), SIZE(obj(1)%N, 2), SIZE(obj)) -! DO ii = 1, SIZE(obj) -! CALL getInterpolation(obj=obj(ii), interpol=m3, val=val) -! interpol(:, :, :, ii) = m3 -! END DO -! DEALLOCATE (m3, s) -!! -INTEGER(I4B) :: ii, jj -INTEGER(I4B), ALLOCATABLE :: s(:) -REAL(DFP), ALLOCATABLE :: m2(:, :) -!! -!! main -!! -s = SHAPE(val) -CALL Reallocate(interpol, s(1), s(2), SIZE(obj(1)%N, 2), SIZE(obj)) -!! -SELECT CASE (val%vartype) -!! -!! -!! -!! -CASE (Constant) - !! - m2 = Get(val, TypeFEVariableMatrix, TypeFEVariableConstant) - !! - DO jj = 1, SIZE(interpol, 4) - DO ii = 1, SIZE(interpol, 3) - interpol(:, :, ii, jj) = m2 - END DO - END DO - !! - DEALLOCATE (m2) -!! -!! -!! -!! -CASE (Space) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, :, :, ii) = Interpolation(obj(ii), & - & Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)) - END DO - !! - ELSE - !! - interpol(:, :, :, 1) = Get(val, TypeFEVariableMatrix, TypeFEVariableSpace) - !! - DO ii = 2, SIZE(obj) - interpol(:, :, :, ii) = interpol(:, :, :, 1) - END DO - !! - END IF -!! -!! -!! -!! -CASE (SpaceTime) - !! - IF (val%DefineOn .EQ. Nodal) THEN - !! - DO ii = 1, SIZE(obj) - interpol(:, :, :, ii) = STinterpolation(obj(ii), & - & Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime)) - END DO - !! - ELSE - interpol = Get(val, TypeFEVariableMatrix, typeFEVariableSpaceTime) - END IF -!! -!! -!! -!! -END SELECT -!! -END PROCEDURE matrix_getinterpolation_5 + CALL FEVariableInitiate(obj=ans, & + s=s(1:totalShape), & + defineon=TypeFEVariableOpt%quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=FEVariableGetRank(val), & + len=mylen) -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE matrix_getinterpolation5_ -INTEGER(I4B) :: ii, jj -dim1 = SIZE(val, 1) -dim2 = SIZE(val, 2) -dim3 = SIZE(obj(1)%N, 2) -dim4 = SIZE(obj) - -SELECT CASE (val%vartype) -CASE (Constant) - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableConstant, val=interpol(:, :, 1, 1), & - nrow=dim1, ncol=dim2) - DO jj = 1, dim3 - DO ii = 1, dim4 - IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE - interpol(1:dim1, 1:dim2, ii, jj) = interpol(1:dim1, 1:dim2, 1, 1) - END DO - END DO -CASE (Space) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, dim4 - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpace), & - interpol=interpol(:, :, :, ii), & - dim1=dim1, dim2=dim2, dim3=dim3) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableSpace, val=interpol(:, :, :, 1), & - dim1=dim1, dim2=dim2, dim3=dim3) - DO ii = 2, dim4 - interpol(1:dim1, 1:dim2, 1:dim3, ii) = & - interpol(1:dim1, 1:dim2, 1:dim3, 1) - END DO - END IF -CASE (SpaceTime) - IF (val%DefineOn .EQ. Nodal) THEN - DO ii = 1, dim4 - CALL GetInterpolation_(obj=obj(ii), & - val=Get(val, TypeFEVariableMatrix, & - TypeFEVariableSpaceTime), & - interpol=interpol(:, :, :, ii), & - dim1=dim1, dim2=dim2, dim3=dim3) - END DO - ELSE - CALL Get_(obj=val, rank=TypeFEVariableMatrix, & - vartype=TypeFEVariableSpaceTime, val=interpol, & - dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) - END IF -END SELECT -END PROCEDURE matrix_getinterpolation5_ - -!---------------------------------------------------------------------------- -! getinterpolation -!---------------------------------------------------------------------------- - -MODULE PROCEDURE master_getinterpolation_1 -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :) -!! main -!! -!! if val is a quadrature variable then do nothing -!! -IF (val%defineOn .EQ. Quadrature) THEN - interpol = val - RETURN + CALL GetInterpolation_(obj=obj, ans=ans, val=val) END IF -!! -!! if val is a nodal variable then interpolate -!! -SELECT CASE (val%rank) -CASE (Scalar) - CALL getInterpolation(obj=obj, interpol=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 +END PROCEDURE GetInterpolation2 !---------------------------------------------------------------------------- -! getInterpolation +! 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 GetInterpolation_2 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL, PARAMETER :: no = .FALSE. -MODULE PROCEDURE scalar_interpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE scalar_interpolation_1 +CALL GetInterpolation_(obj=obj, ans=ans, val=val, scale=one, & + addContribution=no) +END PROCEDURE GetInterpolation_2 !---------------------------------------------------------------------------- -! interpolationOfVector +! GetInterpolation_ !---------------------------------------------------------------------------- -MODULE PROCEDURE vector_interpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE vector_interpolation_1 +MODULE PROCEDURE GetInterpolation_2a +INTEGER(I4B) :: aa, nipt -!---------------------------------------------------------------------------- -! interpolationOfVector -!---------------------------------------------------------------------------- +nipt = SIZE(obj) -MODULE PROCEDURE matrix_interpolation_1 -interpol = MATMUL(val, obj%N) -END PROCEDURE matrix_interpolation_1 +DO aa = 1, nipt + CALL FEVariableGetInterpolation_(obj=val, N=obj(aa)%N, nns=obj(aa)%nns, & + nips=obj(aa)%nips, T=obj(aa)%T, & + nnt=obj(aa)%nnt, scale=scale, & + addContribution=addContribution, & + timeIndx=aa, ans=ans) +END DO +END PROCEDURE GetInterpolation_2a !---------------------------------------------------------------------------- ! 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 +MODULE PROCEDURE Interpolation1 +CALL GetInterpolation(obj=obj, val=val, ans=ans) +END PROCEDURE Interpolation1 END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 index ad274c688..3d8da941e 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 @@ -18,7 +18,9 @@ SUBMODULE(ElemShapeData_Lagrange) Methods USE InputUtility, ONLY: Input -USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate +USE ReferenceElement_Method, ONLY: & + Refelem_Initiate => Initiate, Refelem_GetFaceElemType => GetFaceElemType, & + Refelem_RefCoord_ => RefCoord_ USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE @@ -77,7 +79,8 @@ ALLOCATE (xij(3, nns), temp(nips, nns, 3)) CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType0, & - layout="VEFC", xij=refelemCoord(1:xidim, :), alpha=alpha, beta=beta, & + layout="VEFC", xij=refelemCoord(1:xidim, :), & + alpha=alpha, beta=beta, & lambda=lambda, ans=xij, nrow=indx(1), ncol=indx(2)) IF (PRESENT(coeff)) THEN @@ -149,11 +152,14 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeElemShapeData2 -CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, & +CALL LagrangeElemShapeData(obj=obj, quad=quad, nsd=refelem%nsd, & xidim=refelem%xidimension, elemType=refelem%name, & - refelemCoord=refelem%xij, domainName=refelem%domainName, order=order, & - ipType=ipType, basisType=basisType, coeff=coeff, firstCall=firstCall, & - alpha=alpha, beta=beta, lambda=lambda) + refelemCoord=refelem%xij, & + domainName=refelem%domainName, & + order=order, ipType=ipType, & + basisType=basisType, coeff=coeff, & + firstCall=firstCall, & + alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE LagrangeElemShapeData2 !---------------------------------------------------------------------------- @@ -161,9 +167,43 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeElemShapeData3 -CALL LagrangeElemShapeData2(obj=obj, quad=quad, refelem=refelem, & - order=order, ipType=ipType, basisType=basisType, coeff=coeff, & - firstCall=firstCall, alpha=alpha, beta=beta, lambda=lambda) +CALL LagrangeElemShapeData(obj=obj, quad=quad, refelem=refelem, & + order=order, ipType=ipType, & + basisType=basisType, coeff=coeff, & + firstCall=firstCall, alpha=alpha, & + beta=beta, lambda=lambda) END PROCEDURE LagrangeElemShapeData3 +!---------------------------------------------------------------------------- +! LagrangeFacetElemShapeData +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeFacetElemShapeData1 +INTEGER(I4B) :: faceElemType, faceXidim, tFaceNodes, nrow, ncol +REAL(DFP) :: faceRefelemCoord(3, 8) + +CALL LagrangeElemShapeData(obj=obj, quad=quad, nsd=nsd, xidim=xidim, & + elemType=elemType, refelemCoord=refelemCoord, & + domainName=domainName, order=order, & + ipType=ipType, basisType=basisType, & + coeff=coeff, firstCall=firstCall, & + alpha=alpha, beta=beta, lambda=lambda) + +CALL Refelem_GetFaceElemType(elemType=elemType, localFaceNumber=localFaceNumber, & + faceElemType=faceElemType, & + opt=2, tFaceNodes=tFaceNodes) + +CALL Refelem_RefCoord_(elemType=faceElemType, refElem=domainName, & + ans=faceRefelemCoord, nrow=nrow, ncol=ncol) + +faceXidim = xidim - 1 +CALL LagrangeElemShapeData(obj=facetElemsd, quad=facetQuad, & + nsd=nsd, xidim=faceXidim, & + elemType=faceElemType, & + refelemCoord=faceRefelemCoord(1:nrow, 1:ncol), & + domainName=domainName, order=order, & + ipType=ipType, basisType=basisType, & + alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE LagrangeFacetElemShapeData1 + END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 new file mode 100644 index 000000000..a8f653f24 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90 @@ -0,0 +1,380 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemshapeData_MatrixInterpolMethods) Methods +USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: FEVariableSize => Size, & + FEVariableGetInterpolation_ => GetInterpolation_ +USE BaseType, ONLY: TypeFEVariableMatrix, TypeFEVariableConstant, & + TypeFEVariableSpace, TypeFEVariableSpaceTime, & + TypeFEVariableOpt + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj%nips +CALL Reallocate(ans, dim1, dim2, dim3) +CALL GetInterpolation_(obj=obj, val=val, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj%nips +CALL GetInterpolation_(obj=obj, val=val, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1a +INTEGER(I4B) :: ips, ii, valNNS, minNNS + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj%nips + +IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +valNNS = SIZE(val, 3) +minNNS = MIN(valNNS, obj%nns) + +DO ips = 1, dim3 + DO ii = 1, minNNS + ans(1:dim1, 1:dim2, ips) = ans(1:dim1, 1:dim2, ips) + & + scale * val(1:dim1, 1:dim2, ii) * obj%N(ii, ips) + END DO +END DO +END PROCEDURE GetInterpolation_1a + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation2 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj%nips +CALL Reallocate(ans, dim1, dim2, dim3) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj%nips +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2a +LOGICAL(LGT), PARAMETER :: yes = .TRUE. +INTEGER(I4B) :: minNNT, valNNT, aa +REAL(DFP) :: myscale + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj%nips + +valNNT = SIZE(val, 4) +minNNT = MIN(valNNT, obj%nnt) + +IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +DO aa = 1, minNNT + myscale = obj%T(aa) * scale + CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, :, :, aa), & + dim1=dim1, dim2=dim2, dim3=dim3, scale=myscale, & + addContribution=yes) +END DO +END PROCEDURE GetInterpolation_2a + +!---------------------------------------------------------------------------- +! getSTinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation3 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +INTEGER(I4B) :: dim1, dim2, dim3, dim4 + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj(1)%nips +dim4 = SIZE(obj) + +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4, scale=one, addContribution=no) +END PROCEDURE GetInterpolation3 + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +dim1 = SIZE(val, 1) +dim2 = SIZE(val, 2) +dim3 = obj(1)%nips +dim4 = SIZE(obj) + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_3a +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3a +INTEGER(I4B) :: ipt + +dim1 = 0 +dim2 = 0 +dim3 = 0 +dim4 = SIZE(obj) + +DO ipt = 1, dim4 + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, :, ipt), & + val=val, dim1=dim1, dim2=dim2, dim3=dim3, & + scale=scale, addContribution=addContribution) +END DO +END PROCEDURE GetInterpolation_3a + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation4 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = FEVariableSize(val, 1) +dim2 = FEVariableSize(val, 2) +dim3 = obj%nips + +CALL Reallocate(ans, dim1, dim2, dim3) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_4 + +!---------------------------------------------------------------------------- +! GetInterpolation_4a +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4a +INTEGER(I4B) :: timeIndx0 +timeIndx0 = 1_I4B +IF (PRESENT(timeIndx)) timeIndx0 = timeIndx + +SELECT CASE (val%vartype) +CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableConstant, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + scale=scale, & + addContribution=addContribution, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpace, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + scale=scale, & + addContribution=addContribution, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (TypeFEVariableOpt%spacetime) + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpaceTime, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, timeIndx=timeIndx0) + + END SELECT + +END SELECT +END PROCEDURE GetInterpolation_4a + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4b +SELECT CASE (val%vartype) +CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableConstant, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + scale=scale, & + addContribution=addContribution, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpace, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + scale=scale, & + addContribution=addContribution, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeFEVariableOpt%spacetime) + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpaceTime, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + ans=ans, nrow=nrow, ncol=ncol) + + END SELECT + +END SELECT +END PROCEDURE GetInterpolation_4b + +!---------------------------------------------------------------------------- +! getinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation5 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +dim1 = FEVariableSIZE(val, 1) +dim2 = FEVariableSIZE(val, 2) +dim3 = obj(1)%nips +dim4 = SIZE(obj) + +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4, scale=one, addContribution=no) +END PROCEDURE GetInterpolation5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_5 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_5 + +!---------------------------------------------------------------------------- +! GetInterpolation_5a +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_5a +INTEGER(I4B) :: ipt + +dim1 = 0 +dim2 = 0 +dim3 = 0 +dim4 = SIZE(obj) +DO ipt = 1, dim4 + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, :, ipt), & + val=val, dim1=dim1, dim2=dim2, dim3=dim3, & + scale=scale, addContribution=addContribution, & + timeIndx=ipt) +END DO +END PROCEDURE GetInterpolation_5a + +!---------------------------------------------------------------------------- +! interpolationOfVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Interpolation1 +CALL GetInterpolation(obj=obj, val=val, ans=ans) +END PROCEDURE Interpolation1 + +!---------------------------------------------------------------------------- +! STinterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STInterpolation1 +CALL GetInterpolation(obj=obj, val=val, ans=ans) +END PROCEDURE STInterpolation1 + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 index c4819ecda..08eb339cf 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 @@ -16,201 +16,248 @@ ! SUBMODULE(ElemshapeData_ProjectionMethods) Methods -USE BaseMethod +USE FEVariable_Method, ONLY: GetInterpolation_ +USE ReallocateUtility, ONLY: Reallocate +USE MatmulUtility, ONLY: Matmul_ + IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! getProjectionOfdNdXt +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt_1 - !! Define internal variables -INTEGER(I4B) :: ii, nsd - !! - !! main - !! -CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3)) -nsd = SIZE(obj%dNdXt, 2) -DO ii = 1, SIZE(cdNdXt, 2) - cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), Val(1:nsd)) -END DO - !! -END PROCEDURE getProjectionOfdNdXt_1 +MODULE PROCEDURE GetProjectionOfdNdXt_1 +INTEGER(I4B) :: nrow, ncol + +nrow = obj%nns +ncol = obj%nips +CALL Reallocate(ans, nrow, ncol) + +CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, nrow=nrow, ncol=ncol) +END PROCEDURE GetProjectionOfdNdXt_1 !---------------------------------------------------------------------------- -! +! GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt1_ +MODULE PROCEDURE GetProjectionOfdNdXt1_ INTEGER(I4B) :: ii, nsd -nrow = SIZE(obj%dNdXt, 1) -ncol = SIZE(obj%dNdXt, 3) -nsd = SIZE(obj%dNdXt, 2) +nrow = obj%nns !!SIZE(obj%dNdXt, 1) +ncol = obj%nips !!SIZE(obj%dNdXt, 3) +nsd = obj%nsd !!SIZE(obj%dNdXt, 2) DO ii = 1, ncol - cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), Val(1:nsd)) + ans(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), c(1:nsd)) END DO - -END PROCEDURE getProjectionOfdNdXt1_ +END PROCEDURE GetProjectionOfdNdXt1_ !---------------------------------------------------------------------------- -! getProjectionOfdNdXt +! GetProjectionOfdNdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt_2 -INTEGER(I4B) :: ii, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) -CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3)) -nsd = SIZE(obj%dNdXt, 2) -DO ii = 1, SIZE(cdNdXt, 2) - cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), cbar(1:nsd, ii)) -END DO - !! -DEALLOCATE (cbar) - !! -END PROCEDURE getProjectionOfdNdXt_2 +MODULE PROCEDURE GetProjectionOfdNdXt_2 +INTEGER(I4B) :: nrow, ncol + +nrow = obj%nns +ncol = obj%nips +CALL Reallocate(ans, nrow, ncol) +CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, crank=crank, nrow=nrow, & + ncol=ncol) +END PROCEDURE GetProjectionOfdNdXt_2 !---------------------------------------------------------------------------- -! +! GetProjectionOfdNdXt_ !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt2_ -INTEGER(I4B) :: ii, nsd -REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) +MODULE PROCEDURE GetProjectionOfdNdXt2_ +INTEGER(I4B) :: ips, nsd, i1 +! REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3)) +REAL(DFP) :: cbar(3), T(0) -CALL GetInterpolation_(obj=obj, val=val, interpol=cbar, nrow=nrow, ncol=ncol) -nsd = nrow -nrow = SIZE(obj%dNdXt, 1) +nrow = obj%nns +ncol = obj%nips +nsd = obj%nsd +cbar = 0.0_DFP -DO ii = 1, ncol - cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), cbar(1:nsd, ii)) -END DO +! USE FEVariable_Method, only: FEVariableGetInterpolation_ => GetInterpolation_ +DO ips = 1, obj%nips + CALL GetInterpolation_( & + obj=c, rank=crank, N=obj%N, nns=obj%nns, spaceIndx=ips, timeIndx=0_I4B, & + T=T, nnt=0_I4B, scale=1.0_DFP, addContribution=.FALSE., ans=cbar, & + tsize=i1) -END PROCEDURE getProjectionOfdNdXt2_ + ans(1:nrow, ips) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ips), cbar(1:nsd)) +END DO +END PROCEDURE GetProjectionOfdNdXt2_ !---------------------------------------------------------------------------- ! getProjectionOfdNdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt_3 - !! Define internal variables -INTEGER(I4B) :: ii, nsd - !! - !! main - !! -CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3)) -nsd = SIZE(obj%dNdXt, 2) -DO ii = 1, SIZE(cdNdXt, 2) - cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), val(1:nsd, ii)) -END DO - !! -END PROCEDURE getProjectionOfdNdXt_3 +MODULE PROCEDURE GetProjectionOfdNdXt_3 +INTEGER(I4B) :: nrow, ncol + +nrow = obj%nns +ncol = obj%nips +CALL Reallocate(ans, nrow, ncol) +CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, nrow=nrow, ncol=ncol) +END PROCEDURE GetProjectionOfdNdXt_3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNdXt3_ -INTEGER(I4B) :: ii, nsd +MODULE PROCEDURE GetProjectionOfdNdXt3_ +INTEGER(I4B) :: ips, nsd -nrow = SIZE(obj%dNdXt, 1) -ncol = SIZE(obj%dNdXt, 3) -nsd = SIZE(obj%dNdXt, 2) +nrow = obj%nns +ncol = obj%nips +nsd = obj%nsd -DO ii = 1, ncol - cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), val(1:nsd, ii)) +DO ips = 1, obj%nips + ans(1:nrow, ips) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ips), c(1:nsd, ips)) END DO +END PROCEDURE GetProjectionOfdNdXt3_ -END PROCEDURE getProjectionOfdNdXt3_ +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetProjectionOfdNTdXt_1 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = obj%nns +dim2 = obj%nnt +dim3 = obj%nips + +CALL Reallocate(ans, dim1, dim2, dim3) +CALL GetProjectionOfdNTdXt_(obj=obj, ans=ans, c=c, dim1=dim1, dim2=dim2, & + dim3=dim3) +END PROCEDURE GetProjectionOfdNTdXt_1 !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt +! GetProjectionOfdNTdXt_ !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNTdXt_1 -INTEGER(I4B) :: ii, nsd - !! - !! main - !! -CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & - & SIZE(obj%dNTdXt, 4)) -nsd = SIZE(obj%dNTdXt, 3) - !! -DO ii = 1, SIZE(cdNTdXt, 3) - cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), Val(1:nsd)) +MODULE PROCEDURE GetProjectionOfdNTdXt1_ +INTEGER(I4B) :: ips, nsd, i1, i2 + +dim1 = obj%nns +dim2 = obj%nnt +dim3 = obj%nips +nsd = obj%nsd + +DO ips = 1, obj%nips + CALL Matmul_(a1=obj%dNTdXt(1:dim1, 1:dim2, 1:nsd, ips), & + a2=c(1:nsd), ans=ans(:, :, ips), nrow=i1, ncol=i2) END DO - !! -END PROCEDURE getProjectionOfdNTdXt_1 +END PROCEDURE GetProjectionOfdNTdXt1_ !---------------------------------------------------------------------------- -! getProjectionOfdNTdXt +! GetProjectionOfdNTdXt !---------------------------------------------------------------------------- -MODULE PROCEDURE getProjectionOfdNTdXt_2 - !! -INTEGER(I4B) :: ii, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) -CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), & - & SIZE(obj%dNTdXt, 4)) -nsd = SIZE(obj%dNTdXt, 3) - !! -DO ii = 1, SIZE(cdNTdXt, 3) - cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), cbar(1:nsd, ii)) +MODULE PROCEDURE GetProjectionOfdNTdXt_2 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = obj%nns +dim2 = obj%nnt +dim3 = obj%nips + +CALL Reallocate(ans, dim1, dim2, dim3) +CALL GetProjectionOfdNTdXt_(obj=obj, ans=ans, c=c, crank=crank, & + dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE GetProjectionOfdNTdXt_2 + +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetProjectionOfdNTdXt2_ +INTEGER(I4B) :: ips, nsd, i1, i2 +REAL(DFP) :: cbar(3) + +dim1 = obj%nns +dim2 = obj%nnt +dim3 = obj%nips +nsd = obj%nsd + +DO ips = 1, obj%nips + CALL GetInterpolation_( & + obj=c, rank=crank, N=obj%N, nns=obj%nns, spaceIndx=ips, timeIndx=1_I4B, & + T=obj%T, nnt=obj%nnt, scale=1.0_DFP, addContribution=.FALSE., ans=cbar, & + tsize=i1) + + CALL Matmul_(a1=obj%dNTdXt(1:dim1, 1:dim2, 1:nsd, ips), & + a2=cbar(1:nsd), ans=ans(:, :, ips), nrow=i1, ncol=i2) END DO - !! -DEALLOCATE (cbar) -END PROCEDURE getProjectionOfdNTdXt_2 - -!---------------------------------------------------------------------------- -! getProjectionOfdNTdXt -!---------------------------------------------------------------------------- - -MODULE PROCEDURE getProjectionOfdNTdXt_3 - !! -INTEGER(I4B) :: ii, jj, nsd -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) - !! - !! main - !! -CALL getInterpolation(obj=obj, val=val, interpol=cbar) - !! -CALL Reallocate(cdNTdXt, & - & SIZE(obj(1)%dNTdXt, 1), & - & SIZE(obj(1)%dNTdXt, 2), & - & SIZE(obj(1)%dNTdXt, 4), SIZE(obj)) - !! -! CALL Reallocate( & -! & cdNTdXt, & -! & SIZE(obj(1)%N, 1), & -! & SIZE(obj(1)%T), & -! & SIZE(obj(1)%N, 2), & -! & SIZE(obj) ) - !! -nsd = SIZE(obj(1)%dNTdXt, 3) - !! -DO jj = 1, SIZE(cbar, 3) - DO ii = 1, SIZE(cbar, 2) - !! - cdNTdXt(:, :, ii, jj) = MATMUL( & - & obj(jj)%dNTdXt(:, :, :, ii), & - & cbar(1:nsd, ii, jj)) - !! +END PROCEDURE GetProjectionOfdNTdXt2_ + +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetProjectionOfdNTdXt_3 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 + +dim1 = obj(1)%nns +dim2 = obj(1)%nnt +dim3 = obj(1)%nips +dim4 = SIZE(obj) +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL GetProjectionOfdNTdXt_(obj=obj, ans=ans, c=c, crank=crank, & + dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) +END PROCEDURE GetProjectionOfdNTdXt_3 + +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetProjectionOfdNTdXt3_ +INTEGER(I4B) :: ips, ipt, nsd, i1, i2 +REAL(DFP) :: cbar(3) + +dim1 = obj(1)%nns +dim2 = obj(1)%nnt +dim3 = obj(1)%nips +dim4 = SIZE(obj) +nsd = obj(1)%nsd + +DO ipt = 1, dim4 + DO ips = 1, obj(ipt)%nips + CALL GetInterpolation_( & + obj=c, rank=crank, N=obj(ipt)%N, nns=obj(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=obj(ipt)%T, nnt=obj(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1) + + CALL Matmul_(a1=obj(ipt)%dNTdXt(1:dim1, 1:dim2, 1:nsd, ips), & + a2=cbar(1:nsd), ans=ans(:, :, ips, ipt), nrow=i1, ncol=i2) END DO END DO - !! -DEALLOCATE (cbar) - !! -END PROCEDURE getProjectionOfdNTdXt_3 +END PROCEDURE GetProjectionOfdNTdXt3_ + +!---------------------------------------------------------------------------- +! GetProjectionOfdNTdXt_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetProjectionOfdNTdXt4_ +INTEGER(I4B) :: nsd, i1, i2 +REAL(DFP) :: cbar(3) + +nrow = obj(ips)%nns +ncol = obj(ips)%nnt +nsd = obj(ips)%nsd + +CALL GetInterpolation_( & + obj=c, rank=crank, N=obj(ipt)%N, nns=obj(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=obj(ipt)%T, nnt=obj(ipt)%nnt, & + scale=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1) + +CALL Matmul_(a1=obj(ipt)%dNTdXt(1:nrow, 1:ncol, 1:nsd, ips), & + a2=cbar(1:nsd), ans=ans, nrow=i1, ncol=i2) +END PROCEDURE GetProjectionOfdNTdXt4_ !---------------------------------------------------------------------------- ! diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 new file mode 100644 index 000000000..fb0c34c1d --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 @@ -0,0 +1,318 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemshapeData_ScalarInterpolMethods) Methods +USE ReallocateUtility, ONLY: Reallocate +USE BaseType, ONLY: TypeFEVariableOpt, TypeFEVariableScalar, & + TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableSpaceTime +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation1 +INTEGER(I4B) :: tsize +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & + tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) +END PROCEDURE GetInterpolation1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1 +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & + tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) +END PROCEDURE GetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1a +INTEGER(I4B) :: minNNS, valNNS, ips, ii + +tsize = obj%nips +valNNS = SIZE(val) +minNNS = MIN(valNNS, obj%nns) + +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +!ans(1:obj%nips) = MATMUL(val(1:minNNS), obj%N(1:minNNS, 1:obj%nips)) +DO ips = 1, obj%nips + DO ii = 1, minNNS + ans(ips) = ans(ips) + scale * val(ii) * obj%N(ii, ips) + END DO +END DO +END PROCEDURE GetInterpolation_1a + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation2 +INTEGER(I4B) :: tsize +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & + tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) +END PROCEDURE GetInterpolation2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2 +CALL GetInterpolation_(obj=obj, ans=ans, val=val, & + tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.) +END PROCEDURE GetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2a +INTEGER(I4B) :: minNNT, valNNT, aa +REAL(DFP) :: myscale + +tsize = 0 !! We will read tsize in the loop below +valNNT = SIZE(val, 2) +minNNT = MIN(valNNT, obj%nnt) + +IF (.NOT. addContribution) ans(1:obj%nips) = 0.0_DFP + +DO aa = 1, minNNT + myscale = obj%T(aa) * scale + CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, aa), & + tsize=tsize, scale=myscale, addContribution=.TRUE.) +END DO +END PROCEDURE GetInterpolation_2a + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation3 +INTEGER(I4B) :: nrow, ncol + +nrow = obj(1)%nips +ncol = SIZE(obj) +CALL Reallocate(ans, nrow, ncol) +CALL GetInterpolation_(obj=obj, ans=ans, & + val=val, nrow=nrow, ncol=ncol, scale=1.0_DFP, & + addContribution=.FALSE.) +END PROCEDURE GetInterpolation3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3 +CALL GetInterpolation_(obj=obj, ans=ans, & + val=val, nrow=nrow, ncol=ncol, scale=1.0_DFP, & + addContribution=.FALSE.) +END PROCEDURE GetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3a +INTEGER(I4B) :: ipt + +nrow = 0 !! We will read nrow in the loop below +ncol = SIZE(obj) + +DO ipt = 1, ncol + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, ipt), & + val=val, tsize=nrow, scale=scale, & + addContribution=addContribution) +END DO +END PROCEDURE GetInterpolation_3a + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation4 +INTEGER(I4B) :: tsize +CALL Reallocate(ans, obj%nips) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize) +END PROCEDURE GetInterpolation4 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation_4 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4a +INTEGER(I4B) :: timeIndx0 + +timeIndx0 = 1_I4B +IF (PRESENT(timeIndx)) timeIndx0 = timeIndx + +SELECT CASE (val%vartype) +CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableConstant, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + scale=scale, & + addContribution=addContribution, & + ans=ans, tsize=tsize) + +CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpace, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + scale=scale, & + addContribution=addContribution, & + ans=ans, tsize=tsize) + +CASE (TypeFEVariableOpt%spacetime) + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpaceTime, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + ans=ans, tsize=tsize, & + timeIndx=timeIndx0) + + END SELECT + +END SELECT +END PROCEDURE GetInterpolation_4a + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4b +SELECT CASE (val%vartype) +CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableConstant, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + scale=scale, & + addContribution=addContribution, & + ans=ans) + +CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpace, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + scale=scale, & + addContribution=addContribution, & + ans=ans) + +CASE (TypeFEVariableOpt%spaceTime) + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpaceTime, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + ans=ans) + + END SELECT +END SELECT +END PROCEDURE GetInterpolation_4b + +!---------------------------------------------------------------------------- +! GetInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation5 +INTEGER(I4B) :: nrow, ncol +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +nrow = obj(1)%nips +ncol = SIZE(obj) +CALL Reallocate(ans, nrow, ncol) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, & + ncol=ncol, scale=one, addContribution=no) +END PROCEDURE GetInterpolation5 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_5 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, & + ncol=ncol, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_5 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_5a +INTEGER(I4B) :: ipt + +nrow = 0 +ncol = SIZE(obj) + +DO ipt = 1, ncol + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, ipt), & + val=val, tsize=nrow, scale=scale, & + addContribution=addContribution, timeIndx=ipt) +END DO +END PROCEDURE GetInterpolation_5a + +!---------------------------------------------------------------------------- +! Interpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Interpolation1 +CALL GetInterpolation(obj=obj, ans=ans, val=val) +END PROCEDURE Interpolation1 + +!---------------------------------------------------------------------------- +! STInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STInterpolation1 +CALL GetInterpolation(obj=obj, ans=ans, val=val) +END PROCEDURE STInterpolation1 + +END SUBMODULE Methods diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 index 085d4e2ca..a56e93c53 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 @@ -17,11 +17,8 @@ SUBMODULE(ElemshapeData_SetMethods) Methods USE ProductUtility, ONLY: VectorProduct, OuterProd - USE InvUtility, ONLY: Det, Inv - USE ReallocateUtility, ONLY: Reallocate - USE MatmulUtility IMPLICIT NONE @@ -49,9 +46,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetBarycentricCoord -INTEGER(I4B) :: nns -obj%coord(1:obj%nsd, 1:obj%nips) = MATMUL(val(1:obj%nsd, :), & - N(:, 1:obj%nips)) +INTEGER(I4B) :: valNNS + +valNNS = SIZE(val, 2) +obj%coord(1:obj%nsd, 1:obj%nips) = MATMUL(val(1:obj%nsd, 1:valNNS), & + N(1:valNNS, 1:obj%nips)) END PROCEDURE elemsd_SetBarycentricCoord !---------------------------------------------------------------------------- @@ -59,7 +58,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE stsd_SetBarycentricCoord -! TODO: Improve this function by removing the temporary variable +! TODO: Improve this function by removing the temporary variable ! It is better to store a temporary variable in obj itself CALL SetBarycentricCoord(obj=obj, val=MATMUL(val, T), N=N) END PROCEDURE stsd_SetBarycentricCoord @@ -90,9 +89,12 @@ CASE (2) DO ips = 1, obj%nips - aa = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), obj%jacobian(1:obj%nsd, 1, ips)) - bb = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 2, ips), obj%jacobian(1:obj%nsd, 2, ips)) - ab = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), obj%jacobian(1:obj%nsd, 2, ips)) + aa = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), & + obj%jacobian(1:obj%nsd, 1, ips)) + bb = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 2, ips), & + obj%jacobian(1:obj%nsd, 2, ips)) + ab = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), & + obj%jacobian(1:obj%nsd, 2, ips)) obj%js(ips) = SQRT(aa * bb - ab * ab) END DO @@ -113,9 +115,7 @@ MODULE PROCEDURE elemsd_SetdNdXt ! Define internal variables INTEGER(I4B) :: ips - REAL(DFP) :: invJacobian(3, 3) - LOGICAL(LGT) :: abool abool = obj%nsd .NE. obj%xidim @@ -129,10 +129,9 @@ CALL Inv(InvA=invJacobian, A=obj%jacobian(1:obj%nsd, 1:obj%nsd, ips)) obj%dNdXt(1:obj%nns, 1:obj%nsd, ips) = & - MATMUL(obj%dNdXi(1:obj%nns, 1:obj%xidim, ips), & + MATMUL(obj%dNdXi(1:obj%nns, 1:obj%nsd, ips), & invJacobian(1:obj%nsd, 1:obj%nsd)) END DO - END PROCEDURE elemsd_SetdNdXt !---------------------------------------------------------------------------- @@ -140,8 +139,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_SetJacobian -obj%jacobian(1:obj%nsd, 1:obj%xidim, 1:obj%nips) = & - MATMUL(val(1:obj%nsd, :), dNdXi(:, 1:obj%xidim, 1:obj%nips)) +INTEGER(I4B) :: valNNS, minNNS, ips + +valNNS = SIZE(val, 2) +minNNS = MIN(valNNS, obj%nns) + +DO ips = 1, obj%nips + obj%jacobian(1:obj%nsd, 1:obj%xidim, ips) = MATMUL( & + val(1:obj%nsd, 1:minNNS), & + dNdXi(1:minNNS, 1:obj%xidim, ips)) +END DO END PROCEDURE elemsd_SetJacobian !---------------------------------------------------------------------------- @@ -237,32 +244,26 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Set2 -CALL SetJacobian(obj=cellobj, val=cellVal, dNdXi=celldNdXi) -CALL SetJs(obj=cellobj) -CALL SetdNdXt(obj=cellobj) -CALL SetBarycentricCoord(obj=cellobj, val=cellval, N=cellN) +call elemsd_Set1(obj=cellobj, val=cellval, N=cellN, dNdXi=celldNdXi) -CALL SetJacobian(obj=facetobj, val=cellVal(:, facetNptrs), & - dNdXi=facetdNdXi) +CALL SetJacobian(obj=facetobj, val=facetval, dNdXi=facetdNdXi) CALL SetJs(obj=facetobj) -CALL SetBarycentricCoord(obj=facetobj, val=cellval(:, facetNptrs), & - N=facetN) - +CALL SetBarycentricCoord(obj=facetobj, val=facetval, N=facetN) CALL SetNormal(obj=facetobj) ! gradient depends upon all nodes of the element ! therefore the SIZE( dNdXt, 1 ) = NNS of cell - ! CALL Reallocate( facetobj%dNdXt, SHAPE( cellobj%dNdXt) ) -facetobj%dNdXt = cellobj%dNdXt +! facetobj%dNdXt(1:facetobj%nns, 1:facetobj%nsd, 1:facetobj%nips) = & +! cellobj%dNdXt(1:cellobj%nns, 1:cellobj%nsd, 1:cellobj%nips) ! I am copying normal Js from facet to cell ! In this way, we can use cellobj to construct the element matrix +cellobj%normal(1:cellobj%nsd, 1:cellobj%nips) = & + facetobj%normal(1:facetobj%nsd, 1:facetobj%nips) -cellobj%normal = facetobj%normal -cellobj%Js = facetobj%Js -cellobj%Ws = facetobj%Ws - +cellobj%Js(1:cellobj%nips) = facetobj%Js(1:facetobj%nips) +cellobj%Ws(1:cellobj%nips) = facetobj%Ws(1:facetobj%nips) END PROCEDURE elemsd_Set2 !---------------------------------------------------------------------------- @@ -270,25 +271,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE elemsd_Set3 -! CALL Set( & - & facetobj=masterFacetObj, & - & cellobj=masterCellObj, & - & cellVal=masterCellVal, & - & cellN=masterCellN, & - & celldNdXi=masterCelldNdXi, & - & facetN=masterFacetN, & - & facetdNdXi=masterFacetdNdXi, facetNptrs=masterFacetNptrs) -! + facetobj=masterFacetObj, cellobj=masterCellObj, cellVal=masterCellVal, & + cellN=masterCellN, celldNdXi=masterCelldNdXi, facetN=masterFacetN, & + facetdNdXi=masterFacetdNdXi, facetval=masterFacetVal) + CALL Set( & - & facetobj=slaveFacetObj, & - & cellobj=slaveCellObj, & - & cellVal=slaveCellVal, & - & cellN=slaveCellN, & - & celldNdXi=slaveCelldNdXi, & - & facetN=slaveFacetN, & - & facetdNdXi=slaveFacetdNdXi, facetNptrs=slaveFacetNptrs) -! + facetobj=slaveFacetObj, cellobj=slaveCellObj, cellVal=slaveCellVal, & + cellN=slaveCellN, celldNdXi=slaveCelldNdXi, facetN=slaveFacetN, & + facetdNdXi=slaveFacetdNdXi, facetVal=slaveFacetVal) END PROCEDURE elemsd_Set3 !---------------------------------------------------------------------------- diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 index a9bda718e..251e2dc79 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90 @@ -35,7 +35,7 @@ & TypeFEVariableSpace) END IF !! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +CALL GetInterpolation(obj=obj, val=nu, ans=nubar) !! DO ii = 1, SIZE(h0) h0(ii) = h0(ii)**2 / nubar(ii) / 4.0_DFP @@ -66,7 +66,7 @@ & TypeFEVariableSpaceTime) END IF !! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +CALL GetInterpolation(obj=obj, val=nu, ans=nubar) !! DO ii = 1, SIZE(obj) h0(:, ii) = h0(:, ii)**2 / nubar(:, ii) / 4.0_DFP diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 index db36aea62..8e4751700 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 @@ -70,17 +70,18 @@ PURE SUBROUTINE elemsd_getSUPGParam_a(obj, tau, c, val, nu, k, & !! opt0 = INPUT(default=1_I4B, option=opt) !! - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c) + CALL GetProjectionOfdNdXt(obj=obj, ans=p, c=c, crank=TypeFEVariableVector) !! CALL GetUnitNormal(obj=obj, val=val, r=r) rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) + CALL GetProjectionOfdNdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) !! - CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) + CALL GetInterpolation(obj=obj, val=nu, ans=nubar) !! IF (PRESENT(k)) THEN - CALL GetInterpolation(obj=obj, val=k, interpol=kbar) - CALL GetInterpolation(obj=obj, val=phi, interpol=phibar) + CALL GetInterpolation(obj=obj, val=k, ans=kbar) + CALL GetInterpolation(obj=obj, val=phi, ans=phibar) ELSE ALLOCATE (kbar(SIZE(nubar))) ALLOCATE (phibar(SIZE(nubar))) @@ -129,7 +130,7 @@ END SUBROUTINE elemsd_getSUPGParam_a !---------------------------------------------------------------------------- PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, & - & phi, dt, opt) + phi, dt, opt) CLASS(STElemshapeData_), INTENT(IN) :: obj !! space-time element shape data TYPE(FEVariable_), INTENT(INOUT) :: tau @@ -174,7 +175,8 @@ PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, & !! opt0 = INPUT(option=opt, default=1_I4B) !! - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=obj, ans=p, c=c, & + crank=TypeFEVariableVector) !! !! make cdNTdxt + dNTdt !! @@ -182,12 +184,13 @@ PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, & !! CALL GetUnitNormal(obj=obj, val=val, r=r) rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) - CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) + CALL GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) + CALL GetInterpolation(obj=obj, val=nu, ans=nubar) !! IF (PRESENT(k)) THEN - CALL GetInterpolation(obj=obj, val=k, interpol=kbar) - CALL GetInterpolation(obj=obj, val=phi, interpol=phibar) + CALL GetInterpolation(obj=obj, val=k, ans=kbar) + CALL GetInterpolation(obj=obj, val=phi, ans=phibar) ELSE ALLOCATE (kbar(SIZE(nubar))) ALLOCATE (phibar(SIZE(nubar))) @@ -350,11 +353,12 @@ PURE SUBROUTINE elemsd_getSUPGParam_c(obj, tau, c, val, nu, k, & !! opt0 = INPUT(default=1_I4B, option=opt) !! - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c) + CALL GetProjectionOfdNdXt(obj=obj, ans=p, c=c, crank=TypeFEVariableVector) !! CALL GetUnitNormal(obj=obj, val=val, r=r) rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar) + CALL GetProjectionOfdNdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) !! IF (PRESENT(k)) THEN kbar = k @@ -399,7 +403,7 @@ END SUBROUTINE elemsd_getSUPGParam_c !---------------------------------------------------------------------------- PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, & - & phi, dt, opt) + phi, dt, opt) CLASS(STElemshapeData_), INTENT(IN) :: obj !! space-time element shape data TYPE(FEVariable_), INTENT(INOUT) :: tau @@ -440,7 +444,7 @@ PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, & !! opt0 = INPUT(default=1_I4B, option=opt) !! - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=obj, ans=p, c=c, crank=TypeFEVariableVector) !! !! make cdNTdxt + dNTdt !! @@ -448,7 +452,8 @@ PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, & !! CALL GetUnitNormal(obj=obj, val=val, r=r) rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace) - CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar) + CALL GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, & + crank=TypeFEVariableVector) !! IF (PRESENT(k)) THEN kbar = k diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 index 6d5a80042..296ab1a66 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 @@ -54,7 +54,7 @@ & TypeFEVariableSpace) END IF ! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +CALL GetInterpolation(obj=obj, val=nu, ans=nubar) CALL Reallocate(tau0, SIZE(h0)) ! DO ii = 1, SIZE(h0) @@ -120,7 +120,7 @@ ! nips = SIZE(h0, 1) ! -CALL GetInterpolation(obj=obj, val=nu, interpol=nubar) +CALL GetInterpolation(obj=obj, val=nu, ans=nubar) CALL Reallocate(tau0, nips, nipt) ! DO ipt = 1, nipt diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 index 15aa50970..ab2ba6137 100644 --- a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 +++ b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 @@ -29,7 +29,7 @@ REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) INTEGER(I4B) :: ii !! main -CALL getInterpolation(obj=obj, Val=val, Interpol=p) +CALL GetInterpolation(obj=obj, Val=val, ans=p) CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) CALL Reallocate(R, obj%nsd, obj%nips) pnorm = NORM2(dp, DIM=1) @@ -62,7 +62,7 @@ INTEGER(I4B) :: i !! main !! interpolate the vector -CALL getInterpolation(obj=obj, Interpol=p, Val=val) +CALL getInterpolation(obj=obj, ans=p, Val=val) !! get gradient of nodal values CALL getSpatialGradient(obj=obj, lg=dp, Val=val) pnorm = NORM2(p, DIM=1) @@ -106,9 +106,9 @@ PURE SUBROUTINE scalar_getUnitNormal_3(obj, r, val) ! Define internal variables REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:) INTEGER(I4B) :: ii -!! main - CALL getInterpolation(obj=obj, Val=val, Interpol=p) - CALL getSpatialGradient(obj=obj, lg=dp, Val=Val) + + CALL GetInterpolation(obj=obj, Val=val, ans=p) + CALL GetSpatialGradient(obj=obj, lg=dp, Val=Val) CALL Reallocate(R, obj%nsd, obj%nips) pnorm = NORM2(dp, DIM=1) !! @@ -140,7 +140,7 @@ PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val) INTEGER(I4B) :: i !! main !! interpolate the vector - CALL getInterpolation(obj=obj, Interpol=p, Val=val) + CALL getInterpolation(obj=obj, ans=p, Val=val) !! get gradient of nodal values CALL getSpatialGradient(obj=obj, lg=dp, Val=val) pnorm = NORM2(p, DIM=1) diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 new file mode 100644 index 000000000..daa1354f3 --- /dev/null +++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90 @@ -0,0 +1,361 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ElemshapeData_VectorInterpolMethods) Methods +USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: FEVariableSize => Size + +USE BaseType, ONLY: TypeFEVariableOpt, TypeFEVariableVector, & + TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableSpaceTime + +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ + +IMPLICIT NONE + +CONTAINS + +!--------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(val, 1) +ncol = obj%nips +CALL Reallocate(ans, nrow, ncol) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_1a +INTEGER(I4B) :: valNNS, minNNS +nrow = SIZE(val, 1) +ncol = obj%nips + +valNNS = SIZE(val, 2) +minNNS = MIN(valNNS, obj%nns) + +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP +ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + scale * MATMUL(val(1:nrow, 1:minNNS), & + obj%N(1:minNNS, 1:ncol)) +END PROCEDURE GetInterpolation_1a + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation2 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(val, 1) +ncol = obj%nips +CALL Reallocate(ans, nrow, ncol) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_2a +LOGICAL(LGT), PARAMETER :: yes = .TRUE. +INTEGER(I4B) :: minNNT, valNNT, aa +REAL(DFP) :: myscale + +nrow = SIZE(val, 1) +ncol = obj%nips + +valNNT = SIZE(val, 3) +minNNT = MIN(valNNT, obj%nnt) + +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +DO aa = 1, minNNT + myscale = obj%T(aa) * scale + CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, :, aa), nrow=nrow, & + ncol=ncol, scale=myscale, addContribution=yes) +END DO +END PROCEDURE GetInterpolation_2a + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation3 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = SIZE(val, 1) +dim2 = obj(1)%nips +dim3 = SIZE(obj) + +CALL Reallocate(ans, dim1, dim2, dim3) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_3a +INTEGER(I4B) :: ipt + +dim3 = SIZE(obj) + +DO ipt = 1, dim3 + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, ipt), & + val=val, nrow=dim1, ncol=dim2, scale=scale, & + addContribution=addContribution) +END DO +END PROCEDURE GetInterpolation_3a + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation4 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. +INTEGER(I4B) :: nrow, ncol + +nrow = FEVariableSize(val, 1) +ncol = obj%nips + +CALL Reallocate(ans, nrow, ncol) +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation4 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, & + scale=one, addContribution=no) +END PROCEDURE GetInterpolation_4 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4a +INTEGER(I4B) :: timeIndx0 +timeIndx0 = 1_I4B +IF (PRESENT(timeIndx)) timeIndx0 = timeIndx + +SELECT CASE (val%vartype) +CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableConstant, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + scale=scale, & + addContribution=addContribution, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeFEVariableOpt%space) + + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpace, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + scale=scale, & + addContribution=addContribution, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeFEVariableOpt%spacetime) + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpaceTime, & + N=obj%N, nns=obj%nns, nips=obj%nips, & + T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + ans=ans, nrow=nrow, ncol=ncol, & + timeIndx=timeIndx0) + + END SELECT + +END SELECT +END PROCEDURE GetInterpolation_4a + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_4b +SELECT CASE (val%vartype) +CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableConstant, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + scale=scale, & + addContribution=addContribution, & + ans=ans, tsize=tsize) + +CASE (TypeFEVariableOpt%space) + + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpace, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + scale=scale, & + addContribution=addContribution, & + ans=ans, tsize=tsize) + +CASE (TypeFEVariableOpt%spacetime) + + SELECT TYPE (obj); TYPE IS (STElemShapeData_) + CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpaceTime, & + N=obj%N, nns=obj%nns, & + spaceIndx=spaceIndx, & + timeIndx=timeIndx, & + T=obj%T, nnt=obj%nnt, & + scale=scale, & + addContribution=addContribution, & + ans=ans, tsize=tsize) + + END SELECT + +END SELECT +END PROCEDURE GetInterpolation_4b + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation5 +INTEGER(I4B) :: dim1, dim2, dim3 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +dim1 = FEVariableSIZE(val, 1) +dim2 = obj(1)%nips +dim3 = SIZE(obj) + +CALL Reallocate(ans, dim1, dim2, dim3) + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation5 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_5 +REAL(DFP), PARAMETER :: one = 1.0_DFP +LOGICAL(LGT), PARAMETER :: no = .FALSE. + +dim1 = FEVariableSIZE(val, 1) +dim2 = obj(1)%nips +dim3 = SIZE(obj) + +CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, & + dim3=dim3, scale=one, addContribution=no) +END PROCEDURE GetInterpolation_5 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetInterpolation_5a +INTEGER(I4B) :: ipt + +dim1 = 0 +dim2 = 0 +dim3 = SIZE(obj) +DO ipt = 1, dim3 + CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, ipt), & + val=val, nrow=dim1, ncol=dim2, & + scale=scale, addContribution=addContribution, & + timeIndx=ipt) +END DO +END PROCEDURE GetInterpolation_5a + +!---------------------------------------------------------------------------- +! Interpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Interpolation1 +CALL GetInterpolation(obj=obj, ans=ans, val=val) +END PROCEDURE Interpolation1 + +!---------------------------------------------------------------------------- +! STInterpolation +!---------------------------------------------------------------------------- + +MODULE PROCEDURE STInterpolation1 +CALL GetInterpolation(obj=obj, ans=ans, val=val) +END PROCEDURE STInterpolation1 + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt index ebcb11b22..46461d104 100644 --- a/src/submodules/FEVariable/CMakeLists.txt +++ b/src/submodules/FEVariable/CMakeLists.txt @@ -1,35 +1,39 @@ -# This program is a part of EASIFEM library -# Copyright (C) 2020-2021 Vikas Sharma, Ph.D +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D # -# This program is free software: you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation, either version 3 of the License, or -# (at your option) any later version. +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. # -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. # -# You should have received a copy of the GNU General Public License -# along with this program. If not, see +# You should have received a copy of the GNU General Public License along with +# this program. If not, see # -SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") -TARGET_SOURCES( - ${PROJECT_NAME} PRIVATE - ${src_path}/FEVariable_Method@ConstructorMethods.F90 - ${src_path}/FEVariable_Method@IOMethods.F90 - ${src_path}/FEVariable_Method@GetMethods.F90 - ${src_path}/FEVariable_Method@AdditionMethods.F90 - ${src_path}/FEVariable_Method@SubtractionMethods.F90 - ${src_path}/FEVariable_Method@MultiplicationMethods.F90 - ${src_path}/FEVariable_Method@DivisionMethods.F90 - ${src_path}/FEVariable_Method@PowerMethods.F90 - ${src_path}/FEVariable_Method@SqrtMethods.F90 - ${src_path}/FEVariable_Method@AbsMethods.F90 - ${src_path}/FEVariable_Method@DotProductMethods.F90 - ${src_path}/FEVariable_Method@Norm2Methods.F90 - ${src_path}/FEVariable_Method@EqualMethods.F90 - ${src_path}/FEVariable_Method@MeanMethods.F90 -) +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/FEVariable_AdditionMethod@Methods.F90 + ${src_path}/FEVariable_ConstructorMethod@Methods.F90 + ${src_path}/FEVariable_NodalVariableMethod@Methods.F90 + ${src_path}/FEVariable_QuadratureVariableMethod@Methods.F90 + ${src_path}/FEVariable_DivisionMethod@Methods.F90 + ${src_path}/FEVariable_MultiplicationMethod@Methods.F90 + ${src_path}/FEVariable_DotProductMethod@Methods.F90 + ${src_path}/FEVariable_SubtractionMethod@Methods.F90 + ${src_path}/FEVariable_MeanMethod@Methods.F90 + ${src_path}/FEVariable_UnaryMethod@Methods.F90 + ${src_path}/FEVariable_GetMethod@Methods.F90 + ${src_path}/FEVariable_IOMethod@Methods.F90 + ${src_path}/FEVariable_ScalarInterpolationMethod@Methods.F90 + ${src_path}/FEVariable_VectorInterpolationMethod@Methods.F90 + ${src_path}/FEVariable_MatrixInterpolationMethod@Methods.F90 + ${src_path}/FEVariable_InterpolationMethod@Methods.F90 + ${src_path}/FEVariable_SetMethod@ScalarMethods.F90 + ${src_path}/FEVariable_SetMethod@VectorMethods.F90 + ${src_path}/FEVariable_SetMethod@MatrixMethods.F90) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90 index 68d095928..2fc8a85ae 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90 @@ -15,11 +15,11 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) AdditionMethods - +SUBMODULE(FEVariable_AdditionMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, & Nodal, Quadrature + USE BaseType, ONLY: TypeFEVariableScalar, & TypeFEVariableVector, & TypeFEVariableMatrix, & @@ -30,6 +30,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ + IMPLICIT NONE @@ -103,5 +105,5 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE AdditionMethods +END SUBMODULE Methods #undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 new file mode 100644 index 000000000..f4c60f83e --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 @@ -0,0 +1,114 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_ConstructorMethod) Methods +USE ReallocateUtility, ONLY: Reallocate + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate1 +CALL Initiate(obj=obj, s=s, defineon=defineon, vartype=vartype, rank=rank, & + len=len) +obj%val(1:obj%len) = val(1:obj%len) +END PROCEDURE obj_Initiate1 + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate2 +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tsize + +obj%tshape = SIZE(s) +obj%isInit = .TRUE. +obj%s(1:obj%tshape) = s(1:obj%tshape) +obj%defineon = defineon +obj%vartype = vartype +obj%rank = rank +obj%len = len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len + +isok = ALLOCATED(obj%val) +IF (.NOT. isok) THEN + CALL Reallocate(obj%val, obj%capacity) + RETURN +END IF + +tsize = SIZE(obj%val) +IF (tsize .GE. obj%len) THEN + obj%capacity = tsize + obj%val(1:obj%capacity) = 0.0_DFP +ELSE + CALL Reallocate(obj%val, obj%capacity) +END IF + +END PROCEDURE obj_Initiate2 + +!---------------------------------------------------------------------------- +! Deallocate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Deallocate +obj%isInit = .FALSE. +obj%s = 0 +obj%tshape = 0 +obj%defineOn = 0 +obj%vartype = 0 +obj%rank = 0 +obj%len = 0 +obj%capacity = 0 +IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val) +END PROCEDURE obj_Deallocate + +!---------------------------------------------------------------------------- +! Copy +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Copy +LOGICAL(LGT) :: isok + +obj1%s = obj2%s +obj1%tshape = obj2%tshape +obj1%defineOn = obj2%defineOn +obj1%rank = obj2%rank +obj1%vartype = obj2%vartype +obj1%len = obj2%len +obj1%isInit = obj2%isInit + +IF (obj1%capacity .GE. obj1%len) THEN + obj1%val(1:obj1%len) = obj2%val(1:obj1%len) + RETURN +END IF + +obj1%capacity = TypeFEVariableOpt%capacityExpandFactor * obj1%len +CALL Reallocate(obj1%val, obj1%capacity) + +isok = ALLOCATED(obj2%val) +IF (isok) obj1%val(1:obj1%len) = obj2%val(1:obj1%len) +END PROCEDURE obj_Copy + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90 index 3046f33bf..287a9b1ca 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90 @@ -15,10 +15,11 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) DivisionMethods +SUBMODULE(FEVariable_DivisionMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, & Nodal, Quadrature + USE BaseType, ONLY: TypeFEVariableScalar, & TypeFEVariableVector, & TypeFEVariableMatrix, & @@ -29,6 +30,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ / IMPLICIT NONE @@ -126,4 +129,4 @@ !---------------------------------------------------------------------------- #undef _OP_ -END SUBMODULE DivisionMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90 new file mode 100644 index 000000000..11f39e0ca --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90 @@ -0,0 +1,287 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_DotProductMethod) Methods +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, Nodal, Quadrature + +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! DOT_PRODUCT +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_dot_product +! !! Internal variable +! REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:, :), r3(:, :, :), m3(:, :, :) +! INTEGER(I4B) :: jj, kk +! +! ! main +! SELECT CASE (obj1%vartype) +! +! CASE (constant) +! +! SELECT CASE (obj2%vartype) +! +! ! constant = constant DOT_PRODUCT constant +! CASE (constant) +! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable( & +! & DOT_PRODUCT(obj1%val(:), obj2%val(:)), & +! & typeFEVariableScalar, & +! & typeFEVariableConstant) +! ELSE +! ans = QuadratureVariable( & +! & DOT_PRODUCT(obj1%val(:), obj2%val(:)), & +! & typeFEVariableScalar, & +! & typeFEVariableConstant) +! END IF +! +! ! space= constant DOT_PRODUCT space +! CASE (space) +! +! r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) +! +! IF (obj2%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & MATMUL(obj1%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableSpace) +! ELSE +! ans = QuadratureVariable(& +! & MATMUL(obj1%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableSpace) +! END IF +! +! ! time=constant DOT_PRODUCT time +! CASE (time) +! +! r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) +! +! IF (obj2%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & MATMUL(obj1%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableTime) +! ELSE +! ans = QuadratureVariable(& +! & MATMUL(obj1%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableTime) +! END IF +! !! +! !! spacetime=constant DOT_PRODUCT spacetime +! !! +! CASE (spacetime) +! !! +! r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) +! !! +! IF (obj2%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & MATMUL(obj1%val, r3), & +! & typeFEVariableScalar, & +! & typeFEVariableSpaceTime) +! ELSE +! ans = QuadratureVariable(& +! & MATMUL(obj1%val, r3), & +! & typeFEVariableScalar, & +! & typeFEVariableSpaceTime) +! END IF +! !! +! END SELECT +! !! +! !! +! !! +! !! +! CASE (space) +! !! +! SELECT CASE (obj2%vartype) +! !! +! !! space=space DOT_PRODUCT constant +! !! +! CASE (constant) +! !! +! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) +! !! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & MATMUL(obj2%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableSpace) +! ELSE +! ans = QuadratureVariable(& +! & MATMUL(obj2%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableSpace) +! END IF +! !! +! !! space=space DOT_PRODUCT space +! !! +! CASE (space) +! !! +! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) +! m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) +! CALL Reallocate(r1, SIZE(r2, 2)) +! !! +! DO jj = 1, SIZE(r1) +! r1(jj) = DOT_PRODUCT(r2(:, jj), m2(:, jj)) +! END DO +! !! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable( & +! & r1, & +! & typeFEVariableScalar, & +! & typeFEVariableSpace) +! ELSE +! ans = QuadratureVariable( & +! & r1, & +! & typeFEVariableScalar, & +! & typeFEVariableSpace) +! END IF +! !! +! END SELECT +! !! +! !! +! !! +! !! +! CASE (time) +! !! +! SELECT CASE (obj2%vartype) +! !! +! !! time=time DOT_PRODUCT constant +! !! +! CASE (constant) +! !! +! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) +! !! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & MATMUL(obj2%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableTime) +! ELSE +! ans = QuadratureVariable(& +! & MATMUL(obj2%val, r2), & +! & typeFEVariableScalar, & +! & typeFEVariableTime) +! END IF +! !! +! !! time=time DOT_PRODUCT time +! !! +! CASE (time) +! !! +! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) +! m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) +! CALL Reallocate(r1, SIZE(r2, 2)) +! !! +! DO jj = 1, SIZE(r1) +! r1(jj) = DOT_PRODUCT(r2(:, jj), m2(:, jj)) +! END DO +! !! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable( & +! & r1, & +! & typeFEVariableScalar, & +! & typeFEVariableTime) +! ELSE +! ans = QuadratureVariable( & +! & r1, & +! & typeFEVariableScalar, & +! & typeFEVariableTime) +! END IF +! !! +! END SELECT +! !! +! CASE (spacetime) +! !! +! SELECT CASE (obj2%vartype) +! !! +! !! spacetime= spacetime DOT_PRODUCT constant +! !! +! CASE (constant) +! !! +! r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) +! CALL Reallocate(r2, SIZE(r3, 2), SIZE(r3, 3)) +! !! +! DO kk = 1, SIZE(r3, 3) +! DO jj = 1, SIZE(r3, 2) +! r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), obj2%val(:)) +! END DO +! END DO +! !! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & r2, & +! & typeFEVariableScalar, & +! & typeFEVariableSpaceTime) +! ELSE +! ans = QuadratureVariable(& +! & r2, & +! & typeFEVariableScalar, & +! & typeFEVariableSpaceTime) +! END IF +! !! +! !! spacetime=spacetime DOT_PRODUCT spacetime +! !! +! CASE (spacetime) +! !! +! r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) +! m3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) +! !! +! CALL Reallocate(r2, SIZE(r3, 2), SIZE(r3, 3)) +! !! +! DO kk = 1, SIZE(r3, 3) +! DO jj = 1, SIZE(r3, 2) +! r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), m3(:, jj, kk)) +! END DO +! END DO +! !! +! IF (obj1%defineon .EQ. nodal) THEN +! ans = NodalVariable(& +! & r2, & +! & typeFEVariableScalar, & +! & typeFEVariableSpaceTime) +! ELSE +! ans = QuadratureVariable(& +! & r2, & +! & typeFEVariableScalar, & +! & typeFEVariableSpaceTime) +! END IF +! !! +! END SELECT +! !! +! END SELECT +END PROCEDURE fevar_dot_product + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 similarity index 67% rename from src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 index dc39463e2..82e53bc5c 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 @@ -14,16 +14,78 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -SUBMODULE(FEVariable_Method) GetMethods - +SUBMODULE(FEVariable_GetMethod) Methods USE ReallocateUtility, ONLY: Reallocate +USE StringUtility, ONLY: UpperCase +USE BaseType, ONLY: feopt => TypeFEVariableOpt -USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, & - Time, SpaceTime, Nodal, Quadrature IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! Len +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_len +ans = obj%len +END PROCEDURE fevar_len + +!---------------------------------------------------------------------------- +! FEVariable_ToString +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FEVariable_ToChar + +SELECT CASE (name) +CASE (feopt%scalar) + ans = "Scalar" + +CASE (feopt%vector) + ans = "Vector" + +CASE (feopt%matrix) + ans = "Matrix" + +CASE DEFAULT + ans = "Scalar" + +END SELECT + +IF (PRESENT(isUpper)) THEN + IF (isUpper) THEN + ans = UpperCase(ans) + END IF +END IF + +END PROCEDURE FEVariable_ToChar + +!---------------------------------------------------------------------------- +! FEVariable_ToInteger +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FEVariable_ToInteger +CHARACTER(1) :: name0 + +name0 = name(1:1) + +SELECT CASE (name0) +CASE ("S", "s") + ans = feopt%scalar + +CASE ("V", "v") + ans = feopt%vector + +CASE ("M", "m") + ans = feopt%matrix + +CASE DEFAULT + ans = feopt%scalar + +END SELECT + +END PROCEDURE FEVariable_ToInteger + !---------------------------------------------------------------------------- ! GetLambdaFromYoungsModulus !---------------------------------------------------------------------------- @@ -46,49 +108,75 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Size -IF (PRESENT(dim)) THEN +LOGICAL(LGT) :: isok + +isok = PRESENT(dim) +IF (isok) THEN ans = obj%s(dim) ELSE ans = obj%len END IF END PROCEDURE fevar_Size +!---------------------------------------------------------------------------- +! GetTotalShape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_GetTotalShape +ans = obj%tshape +! SELECT CASE (obj%rank) +! CASE (feopt%scalar) +! SELECT CASE (obj%vartype) +! CASE (feopt%constant, feopt%space, feopt%time) +! ans = 1 +! CASE (feopt%spaceTime) +! ans = 2 +! END SELECT +! +! CASE (feopt%vector) +! SELECT CASE (obj%vartype) +! CASE (feopt%constant) +! ans = 1 +! CASE (feopt%space, feopt%time) +! ans = 2 +! CASE (feopt%spaceTime) +! ans = 3 +! END SELECT +! +! CASE (feopt%matrix) +! SELECT CASE (obj%vartype) +! CASE (feopt%constant) +! ans = 2 +! CASE (feopt%space, feopt%time) +! ans = 3 +! CASE (feopt%spaceTime) +! ans = 4 +! END SELECT +! +! END SELECT +END PROCEDURE fevar_GetTotalShape + !---------------------------------------------------------------------------- ! Shape !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Shape -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 +! INTEGER(I4B) :: tsize +! tsize = GetTotalShape(obj=obj) +CALL Reallocate(ans, obj%tshape) +ans(1:obj%tshape) = obj%s(1:obj%tshape) END PROCEDURE fevar_Shape +!---------------------------------------------------------------------------- +! Shape +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_GetShape +! tsize = GetTotalShape(obj=obj) +tsize = obj%tshape +ans(1:tsize) = obj%s(1:tsize) +END PROCEDURE fevar_GetShape + !---------------------------------------------------------------------------- ! rank !---------------------------------------------------------------------------- @@ -118,7 +206,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_isNodalVariable -ans = obj%defineon .EQ. nodal +ans = obj%defineon .EQ. feopt%nodal END PROCEDURE fevar_isNodalVariable !---------------------------------------------------------------------------- @@ -126,7 +214,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_isQuadratureVariable -ans = obj%defineon .NE. nodal +ans = obj%defineon .NE. feopt%nodal END PROCEDURE fevar_isQuadratureVariable !---------------------------------------------------------------------------- @@ -148,7 +236,6 @@ PURE SUBROUTINE Master_Get_vec_(obj, val, tsize) tsize = obj%len val(1:tsize) = obj%val(1:tsize) - END SUBROUTINE Master_Get_vec_ !---------------------------------------------------------------------------- @@ -200,13 +287,44 @@ PURE SUBROUTINE Master_get_mat3_(obj, val, dim1, dim2, dim3) END SUBROUTINE Master_get_mat3_ +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE Master_get_mat4_(obj, val, dim1, dim2, dim3, dim4) + CLASS(FEVariable_), INTENT(IN) :: obj + REAL(DFP), INTENT(INOUT) :: val(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + ! Internal variables + INTEGER(I4B) :: ii, jj, kk, ll, cnt + + dim1 = obj%s(1) + dim2 = obj%s(2) + dim3 = obj%s(3) + dim4 = obj%s(4) + + cnt = 0 + DO ll = 1, dim4 + DO kk = 1, dim3 + DO jj = 1, dim2 + DO ii = 1, dim1 + cnt = cnt + 1 + val(ii, jj, kk, ll) = obj%val(cnt) + END DO + END DO + END DO + END DO +END SUBROUTINE Master_get_mat4_ + !---------------------------------------------------------------------------- ! getNodalvalues !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Space +INTEGER(I4B) :: tsize ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Space !---------------------------------------------------------------------------- @@ -214,7 +332,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Space_ -CALL Master_Get_vec_(obj, val, tsize) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Space_ !---------------------------------------------------------------------------- @@ -222,8 +340,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Time +INTEGER(I4B) :: tsize ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Time !---------------------------------------------------------------------------- @@ -231,7 +350,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_Time_ -CALL Master_Get_vec_(obj, val, tsize) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Scalar_Time_ !---------------------------------------------------------------------------- @@ -239,19 +358,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_SpaceTime -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - - END DO -END DO - +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Scalar_SpaceTime !---------------------------------------------------------------------------- @@ -259,7 +368,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Scalar_SpaceTime_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Scalar_SpaceTime_ !---------------------------------------------------------------------------- @@ -267,8 +376,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Constant +INTEGER(I4B) :: tsize ALLOCATE (val(obj%len)) -val = obj%val(1:obj%len) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Vector_Constant !---------------------------------------------------------------------------- @@ -276,7 +386,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Constant_ -CALL Master_Get_vec_(obj, val, tsize) +CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize) END PROCEDURE Vector_Constant_ !---------------------------------------------------------------------------- @@ -284,18 +394,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Space -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO - +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Space !---------------------------------------------------------------------------- @@ -303,7 +404,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Space_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Space_ !---------------------------------------------------------------------------- @@ -311,17 +412,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Time -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Time !---------------------------------------------------------------------------- @@ -329,7 +422,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_Time_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Vector_Time_ !---------------------------------------------------------------------------- @@ -337,19 +430,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_SpaceTime -INTEGER(I4B) :: ii, jj, kk, cnt - +INTEGER(I4B) :: dim1, dim2, dim3 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Vector_SpaceTime !---------------------------------------------------------------------------- @@ -357,7 +440,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Vector_SpaceTime_ -CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Vector_SpaceTime_ !---------------------------------------------------------------------------- @@ -365,17 +448,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Constant -INTEGER(I4B) :: ii, jj, cnt - +INTEGER(I4B) :: nrow, ncol ALLOCATE (val(obj%s(1), obj%s(2))) - -cnt = 0 -DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj) = obj%val(cnt) - END DO -END DO +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Matrix_Constant !---------------------------------------------------------------------------- @@ -383,7 +458,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Constant_ -CALL Master_Get_mat_(obj, val, nrow, ncol) +CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol) END PROCEDURE Matrix_Constant_ !---------------------------------------------------------------------------- @@ -391,19 +466,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Space -INTEGER(I4B) :: ii, jj, kk, cnt - +INTEGER(I4B) :: dim1, dim2, dim3 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Space !---------------------------------------------------------------------------- @@ -411,7 +476,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Space_ -CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Space_ !---------------------------------------------------------------------------- @@ -419,19 +484,9 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Time -INTEGER(I4B) :: ii, jj, kk, cnt - +INTEGER(I4B) :: dim1, dim2, dim3 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3))) - -cnt = 0 -DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk) = obj%val(cnt) - END DO - END DO -END DO +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Time !---------------------------------------------------------------------------- @@ -439,7 +494,7 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_Time_ -CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3) +CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE Matrix_Time_ !---------------------------------------------------------------------------- @@ -447,21 +502,10 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_SpaceTime -INTEGER(I4B) :: ii, jj, kk, ll, cnt - +INTEGER(I4B) :: dim1, dim2, dim3, dim4 ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4))) - -cnt = 0 -DO ll = 1, obj%s(4) - DO kk = 1, obj%s(3) - DO jj = 1, obj%s(2) - DO ii = 1, obj%s(1) - cnt = cnt + 1 - val(ii, jj, kk, ll) = obj%val(cnt) - END DO - END DO - END DO -END DO +CALL Master_get_mat4_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) END PROCEDURE Matrix_SpaceTime !---------------------------------------------------------------------------- @@ -469,29 +513,12 @@ END SUBROUTINE Master_get_mat3_ !---------------------------------------------------------------------------- MODULE PROCEDURE Matrix_SpaceTime_ -INTEGER(I4B) :: ii, jj, kk, ll, cnt - -dim1 = obj%s(1) -dim2 = obj%s(2) -dim3 = obj%s(3) -dim4 = obj%s(4) - -cnt = 0 -DO ll = 1, dim4 - DO kk = 1, dim3 - DO jj = 1, dim2 - DO ii = 1, dim1 - cnt = cnt + 1 - val(ii, jj, kk, ll) = obj%val(cnt) - END DO - END DO - END DO -END DO - +CALL Master_get_mat4_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) END PROCEDURE Matrix_SpaceTime_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -END SUBMODULE GetMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 similarity index 90% rename from src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 index 276dd37c0..25d53c643 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) IOMethods +SUBMODULE(FEVariable_IOMethod) Methods USE Display_Method, ONLY: Util_Display => Display, ToString USE GlobalData, ONLY: Scalar, Vector, Matrix, & @@ -32,6 +32,8 @@ USE SafeSizeUtility, ONLY: SafeSize +USE FEVariable_Method, ONLY: GET, NodalVariable, QuadratureVariable + IMPLICIT NONE CONTAINS @@ -52,8 +54,9 @@ SELECT CASE (obj%varType) CASE (Constant) CALL Util_Display("VarType: Constant", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & - 'VALUE: ', unitno=unitno) + CALL Util_Display( & + GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), & + 'VALUE: ', unitno=unitno) CASE (Space) CALL Util_Display("VarType: Space", unitno=unitno) @@ -65,8 +68,9 @@ 'VALUE: ', unitno=unitno) CASE (SpaceTime) CALL Util_Display("VarType: Space & Time", unitno=unitno) - CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & - 'VALUE: ', unitno=unitno) + CALL Util_Display( & + GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), & + 'VALUE: ', unitno=unitno) CASE DEFAULT CALL Util_Display("VarType: UNKNOWN", unitno=unitno) @@ -128,11 +132,13 @@ END SELECT CALL Util_Display(obj%s, "s: ", unitno=unitno) +CALL Util_Display(obj%tshape, "tshape: ", unitno=unitno) CALL Util_Display(obj%defineOn, "defineOn: ", unitno=unitno) CALL Util_Display(obj%len, "len: ", unitno=unitno) CALL Util_Display(obj%capacity, "capacity: ", unitno=unitno) +CALL Util_Display(obj%isInit, "isInit: ", unitno=unitno) CALL Util_Display(SafeSize(obj%val), "Size of obj%val: ", unitno=unitno) END PROCEDURE fevar_Display -END SUBMODULE IOMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 new file mode 100644 index 000000000..65e187578 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 @@ -0,0 +1,201 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(FEVariable_InterpolationMethod) Methods +USE FEVariable_Method, ONLY: FEVariableCopy => Copy, & + FEVariableGetInterpolation_ => GetInterpolation_ +USE BaseType, ONLY: TypeFEVariableScalar, & + TypeFEVariableVector, & + TypeFEVariableMatrix, & + TypeFEVariableConstant, & + TypeFEVariableSpace, & + TypeFEVariableTime, & + TypeFEVariableSpaceTime + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FEVariableGetInterpolation_1 +INTEGER(I4B) :: timeIndx + +timeIndx = 1 + +! if val is a nodal variable then interpolate +SELECT CASE (obj%rank) + +CASE (TypeFEVariableOpt%scalar) + + SELECT CASE (obj%vartype) + CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableConstant, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + + CASE (TypeFEVariableOpt%space, TypeFEVariableOpt%spacetime) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpace, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + ! CASE (TypeFEVariableOpt%time) + + END SELECT + +CASE (TypeFEVariableOpt%vector) + + SELECT CASE (obj%vartype) + CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, & + vartype=TypeFEVariableConstant, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + + CASE (TypeFEVariableOpt%space, TypeFEVariableOpt%spacetime) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpace, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + ! CASE (TypeFEVariableOpt%time) + + END SELECT + +CASE (TypeFEVariableOpt%matrix) + + SELECT CASE (obj%vartype) + CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableConstant, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + + CASE (TypeFEVariableOpt%space, TypeFEVariableOpt%spacetime) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpace, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + ! CASE (TypeFEVariableOpt%time) + + END SELECT + +END SELECT + +END PROCEDURE FEVariableGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FEVariableGetInterpolation_2 +! if val is a nodal variable then interpolate +SELECT CASE (obj%rank) + +CASE (TypeFEVariableOpt%scalar) + + SELECT CASE (obj%vartype) + CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableConstant, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpace, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + ! CASE (TypeFEVariableOpt%time) + + CASE (TypeFEVariableOpt%spacetime) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, & + vartype=TypeFEVariableSpaceTime, & + N=N, nns=nns, nips=nips, & + T=T, nnt=nnt, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + + END SELECT + +CASE (TypeFEVariableOpt%vector) + + SELECT CASE (obj%vartype) + CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, & + vartype=TypeFEVariableConstant, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpace, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + ! CASE (TypeFEVariableOpt%time) + + CASE (TypeFEVariableOpt%spacetime) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, & + vartype=TypeFEVariableSpaceTime, & + N=N, nns=nns, nips=nips, & + T=T, nnt=nnt, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + + END SELECT + +CASE (TypeFEVariableOpt%matrix) + + SELECT CASE (obj%vartype) + CASE (TypeFEVariableOpt%constant) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableConstant, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + CASE (TypeFEVariableOpt%space) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpace, & + N=N, nns=nns, nips=nips, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + ! CASE (TypeFEVariableOpt%time) + + CASE (TypeFEVariableOpt%spacetime) + CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, & + vartype=TypeFEVariableSpaceTime, & + N=N, nns=nns, nips=nips, & + T=T, nnt=nnt, scale=scale, & + addContribution=addContribution, & + ans=ans, timeIndx=timeIndx) + + END SELECT + +END SELECT + +END PROCEDURE FEVariableGetInterpolation_2 + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 new file mode 100644 index 000000000..c00dba2ee --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 @@ -0,0 +1,571 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(FEVariable_MatrixInterpolationMethod) Methods +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableTime, TypeFEVariableSpaceTime +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixConstantGetInterpolation_1 +INTEGER(I4B) :: ips, ii, jj, indx + +dim1 = obj%s(1) +dim2 = obj%s(2) +dim3 = nips + +IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +DO ips = 1, dim3 + DO jj = 1, dim2 + DO ii = 1, dim1 + indx = (jj - 1) * dim1 + ii + ans(ii, jj, ips) = ans(ii, jj, ips) + scale * obj%val(indx) + END DO + END DO +END DO +END PROCEDURE MatrixConstantGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixConstantGetInterpolation_2 +INTEGER(I4B) :: tsize, ansStart, valStart, ii + +tsize = ans%s(1) * ans%s(2) * nips +ansStart = (timeIndx - 1) * tsize +IF (.NOT. addContribution) ans%val(ansStart + 1:ansStart + tsize) = 0.0_DFP + +valStart = 0 +DO ii = 1, tsize + ans%val(ansStart + ii) = ans%val(ansStart + ii) & + + scale * obj%val(valStart + ii) +END DO +END PROCEDURE MatrixConstantGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixConstantGetInterpolation_3 +INTEGER(I4B) :: ii, jj, indx + +nrow = obj%s(1) +ncol = obj%s(2) + +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +DO jj = 1, ncol + DO ii = 1, nrow + indx = (jj - 1) * nrow + ii + ans(ii, jj) = ans(ii, jj) + scale * obj%val(indx) + END DO +END DO +END PROCEDURE MatrixConstantGetInterpolation_3 + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal1_(ans, scale, N, nns, dim1, & + dim2, nips, val, valStart, & + valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, nips, dim1, dim2 + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: ips, ii, jj, inode, tsize, indx, a, b + + tsize = dim1 * dim2 + + DO ips = 1, nips + DO inode = 1, nns + a = (inode - 1) * tsize + + DO jj = 1, dim2 + b = (jj - 1) * dim1 + + DO ii = 1, dim1 + indx = a + b + ii + valStart + ans(ii, jj, ips) = ans(ii, jj, ips) & + + scale * N(inode, ips) * val(indx) + + END DO + END DO + END DO + END DO + + valEnd = valStart + nns * tsize +END SUBROUTINE MasterGetInterpolationFromNodal1_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal2_(ans, scale, N, nns, dim1, & + dim2, nips, val, valStart, & + valEnd, ansStart, ansEnd) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, nips, dim1, dim2 + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + INTEGER(I4B), INTENT(IN) :: ansStart + INTEGER(I4B), INTENT(OUT) :: ansEnd + + INTEGER(I4B) :: ips, jj, ival, jval, ians, jans, tsize + + tsize = dim1 * dim2 + + DO ips = 1, nips + ians = (ips - 1) * tsize + 1 + ansStart + jans = ips * tsize + ansStart + + DO jj = 1, nns + ival = (jj - 1) * tsize + 1 + valStart + jval = jj * tsize + valStart + + ans(ians:jans) = ans(ians:jans) & + + scale * N(jj, ips) * val(ival:jval) + END DO + END DO + + valEnd = valStart + nns * tsize + ansEnd = ansStart + nips * tsize +END SUBROUTINE MasterGetInterpolationFromNodal2_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal3_(ans, scale, N, nns, dim1, & + dim2, spaceIndx, & + val, valStart, valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, dim1, dim2, spaceIndx + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: ii, jj, inode, tsize, indx, a, b + + tsize = dim1 * dim2 + + DO inode = 1, nns + a = (inode - 1) * tsize + + DO jj = 1, dim2 + b = (jj - 1) * dim1 + + DO ii = 1, dim1 + indx = a + b + ii + valStart + ans(ii, jj) = ans(ii, jj) & + + scale * N(inode, spaceIndx) * val(indx) + + END DO + END DO + END DO + + valEnd = valStart + nns * tsize +END SUBROUTINE MasterGetInterpolationFromNodal3_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature1_(ans, scale, dim1, & + dim2, nips, val, & + valStart, valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: dim1, dim2, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: ips, ii, jj, tsize, indx, a, b + + tsize = dim1 * dim2 + + DO ips = 1, nips + a = (ips - 1) * tsize + + DO jj = 1, dim2 + b = (jj - 1) * dim1 + + DO ii = 1, dim1 + indx = a + b + ii + valStart + ans(ii, jj, ips) = ans(ii, jj, ips) + scale * val(indx) + + END DO + END DO + END DO + + valEnd = valStart + nips * tsize +END SUBROUTINE MasterGetInterpolationFromQuadrature1_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolationFromQuadrature_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature2_(ans, scale, dim1, & + dim2, nips, val, & + valStart, valEnd, & + ansStart, ansEnd) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: dim1, dim2, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + INTEGER(I4B), INTENT(IN) :: ansStart + INTEGER(I4B), INTENT(OUT) :: ansEnd + + INTEGER(I4B) :: ii, tsize + + tsize = nips * dim1 * dim2 + valEnd = valStart + tsize + ansEnd = ansStart + tsize + + DO ii = 1, tsize + ans(ansStart + ii) = ans(ansStart + ii) + scale * val(valStart + ii) + END DO +END SUBROUTINE MasterGetInterpolationFromQuadrature2_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature3_(ans, scale, dim1, & + dim2, spaceIndx, val, & + valStart, valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: dim1, dim2, spaceIndx + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: ii, jj, tsize, indx, a, b + + tsize = dim1 * dim2 + + a = (spaceIndx - 1) * tsize + DO jj = 1, dim2 + b = (jj - 1) * dim1 + + DO ii = 1, dim1 + indx = a + b + ii + valStart + ans(ii, jj) = ans(ii, jj) + scale * val(indx) + END DO + END DO + + valEnd = valStart + tsize +END SUBROUTINE MasterGetInterpolationFromQuadrature3_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%defineon is nodal +! Nodal Matrix Space +! Convert nodal values to quadrature values by using N(:,:) +! make sure nns .LE. obj%len +! +! obj%defineon is quadrature +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len +MODULE PROCEDURE MatrixSpaceGetInterpolation_1 +INTEGER(I4B) :: valEnd + +dim1 = obj%s(1) +dim2 = obj%s(2) +dim3 = nips + +IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=scale, N=N, & + nns=nns, nips=nips, val=obj%val, & + dim1=dim1, dim2=dim2, & + valStart=0, valEnd=valEnd) + +CASE (TypeFEVariableOpt%quadrature) + + CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, & + nips=nips, dim1=dim1, & + dim2=dim2, val=obj%val, & + valStart=0, valEnd=valEnd) + +END SELECT +END PROCEDURE MatrixSpaceGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixSpaceGetInterpolation_2 +INTEGER(I4B) :: valStart, valEnd, ansStart, ansEnd, dim1, dim2, dim3, tsize + +dim1 = ans%s(1) +dim2 = ans%s(2) +dim3 = nips + +tsize = dim1 * dim2 * dim3 +ansStart = (timeIndx - 1) * tsize +ansEnd = ansStart + tsize +valStart = 0 + +IF (.NOT. addContribution) ans%val(ansStart + 1:ansEnd) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=scale, N=N, & + nns=nns, dim1=dim1, dim2=dim2, & + nips=nips, val=obj%val, & + valStart=valStart, valEnd=valEnd, & + ansStart=ansStart, ansEnd=ansEnd) + +CASE (TypeFEVariableOpt%quadrature) + + CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, & + nips=nips, dim1=dim1, & + dim2=dim2, val=obj%val, & + valStart=valStart, & + valEnd=valEnd, & + ansStart=ansStart, & + ansEnd=ansEnd) + +END SELECT +END PROCEDURE MatrixSpaceGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixSpaceGetInterpolation_3 +INTEGER(I4B) :: valEnd + +nrow = obj%s(1) +ncol = obj%s(2) +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=scale, N=N, & + nns=nns, val=obj%val, & + dim1=nrow, dim2=ncol, & + valStart=0, valEnd=valEnd, & + spaceIndx=spaceIndx) + +CASE (TypeFEVariableOpt%quadrature) + + CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, & + dim1=nrow, dim2=ncol, & + val=obj%val, & + spaceIndx=spaceIndx, & + valStart=0, valEnd=valEnd) + +END SELECT +END PROCEDURE MatrixSpaceGetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! Convert nodal values to quadrature values by using N +! make sure nns .LE. obj%len +! obj%s(1) denotes the nsd in ans +! obj%s(2) should be atleast nns +! obj%s(3) should be atleast nnt +! +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len +MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_1 +INTEGER(I4B) :: aa, valStart, valEnd +REAL(DFP) :: myscale + +dim1 = obj%s(1) +dim2 = obj%s(2) +dim3 = nips + +IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + valEnd = 0 + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = valEnd + CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=myscale, N=N, & + nns=nns, dim1=dim1, dim2=dim2, & + nips=nips, val=obj%val, & + valStart=valStart, valEnd=valEnd) + END DO + +CASE (TypeFEVariableOpt%quadrature) + + valStart = nips * dim1 * dim2 * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, & + dim1=dim1, dim2=dim2, & + nips=nips, val=obj%val, & + valStart=valStart, & + valEnd=valEnd) + +END SELECT +END PROCEDURE MatrixSpaceTimeGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_2 +INTEGER(I4B) :: aa, valStart, valEnd, ansStart, ansEnd, dim1, dim2, dim3, & + tsize +REAL(DFP) :: myscale + +dim1 = obj%s(1) +dim2 = obj%s(2) +dim3 = nips + +tsize = dim1 * dim2 * dim3 +ansStart = (timeIndx - 1) * tsize +ansEnd = ansStart + tsize +valStart = 0 + +IF (.NOT. addContribution) ans%val(ansStart + 1:ansEnd) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + valEnd = 0 + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = valEnd + CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=myscale, N=N, & + nns=nns, dim1=dim1, dim2=dim2, & + nips=nips, val=obj%val, & + valStart=valStart, valEnd=valEnd, & + ansStart=ansStart, ansEnd=ansEnd) + END DO + +CASE (TypeFEVariableOpt%quadrature) + + valStart = tsize * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, & + dim1=dim1, dim2=dim2, & + nips=nips, val=obj%val, & + valStart=valStart, & + valEnd=valEnd, & + ansStart=ansStart, & + ansEnd=ansEnd) + +END SELECT +END PROCEDURE MatrixSpaceTimeGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_3 +INTEGER(I4B) :: aa, valStart, valEnd +REAL(DFP) :: myscale + +nrow = obj%s(1) +ncol = obj%s(2) + +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + valEnd = 0 + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = valEnd + CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=myscale, N=N, & + nns=nns, dim1=nrow, dim2=ncol, & + spaceIndx=spaceIndx, val=obj%val, & + valStart=valStart, valEnd=valEnd) + END DO + +CASE (TypeFEVariableOpt%quadrature) + + valStart = obj%s(3) * nrow * ncol * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, & + dim1=nrow, dim2=ncol, & + spaceIndx=spaceIndx, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd) + +END SELECT +END PROCEDURE MatrixSpaceTimeGetInterpolation_3 + +!---------------------------------------------------------------------------- +! MatrixInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MatrixGetInterpolation_3 +INTEGER(I4B) :: vartype +vartype = obj%varType +SELECT CASE (vartype) +CASE (TypeFEVariableOpt%constant) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableConstant, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, & + addContribution=addContribution, ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeFEVariableOpt%space) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableSpace, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, & + addContribution=addContribution, ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeFEVariableOpt%time) + +CASE (TypeFEVariableOpt%spacetime) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableSpaceTime, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, & + addContribution=addContribution, ans=ans, nrow=nrow, ncol=ncol) +END SELECT +END PROCEDURE MatrixGetInterpolation_3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 b/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 similarity index 97% rename from src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 index 979dc3e8f..7ff5c9dba 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) MeanMethods +SUBMODULE(FEVariable_MeanMethod) Methods USE IntegerUtility, ONLY: Get1DIndexFortran USE GlobalData, ONLY: Scalar, Vector, Matrix, & @@ -30,6 +30,8 @@ TypeFEVariableTime, & TypeFEVariableSpaceTime +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + IMPLICIT NONE CONTAINS @@ -38,7 +40,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE fevar_Mean1 -REAL(DFP) :: val0 SELECT CASE (obj%rank) CASE (scalar) IF (obj%defineOn .EQ. NODAL) THEN @@ -173,4 +174,4 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE MeanMethods +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@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@DotProductMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 deleted file mode 100644 index a1b1f1ab1..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 +++ /dev/null @@ -1,282 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(FEVariable_Method) DotProductMethods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! DOT_PRODUCT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_dot_product -!! Internal variable -REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:,:), r3(:, :, :), m3(:,:,:) -INTEGER(I4B) :: jj, kk -!! -!! main -!! -SELECT CASE (obj1%vartype) -!! -!! -!! -!! -CASE (constant) -!! - SELECT CASE (obj2%vartype) - !! - !! constant = constant DOT_PRODUCT constant - !! - CASE (constant) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & DOT_PRODUCT(obj1%val(:), obj2%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - ELSE - ans = QuadratureVariable( & - & DOT_PRODUCT(obj1%val(:), obj2%val(:)), & - & typeFEVariableScalar, & - & typeFEVariableConstant) - END IF - !! - !! space= constant DOT_PRODUCT space - !! - CASE (space) - !! - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & MATMUL(obj1%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & MATMUL(obj1%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF - !! - !! time=constant DOT_PRODUCT time - !! - CASE (time) - !! - r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & MATMUL(obj1%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & MATMUL(obj1%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF - !! - !! spacetime=constant DOT_PRODUCT spacetime - !! - CASE (spacetime) - !! - r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) - !! - IF( obj2%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & MATMUL(obj1%val, r3), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & MATMUL(obj1%val, r3), & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (space) -!! - SELECT CASE (obj2%vartype) - !! - !! space=space DOT_PRODUCT constant - !! - CASE (constant) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & MATMUL(obj2%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable(& - & MATMUL(obj2%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF - !! - !! space=space DOT_PRODUCT space - !! - CASE (space) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace) - m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace) - CALL Reallocate(r1, size(r2, 2)) - !! - DO jj = 1, size(r1) - r1( jj ) = DOT_PRODUCT(r2(:, jj), m2(:, jj)) - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & r1, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - ELSE - ans = QuadratureVariable( & - & r1, & - & typeFEVariableScalar, & - & typeFEVariableSpace) - END IF - !! - END SELECT -!! -!! -!! -!! -CASE (time) -!! - SELECT CASE (obj2%vartype) - !! - !! time=time DOT_PRODUCT constant - !! - CASE (constant) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & MATMUL(obj2%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable(& - & MATMUL(obj2%val, r2), & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF - !! - !! time=time DOT_PRODUCT time - !! - CASE (time) - !! - r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime) - m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime) - CALL Reallocate(r1, size(r2, 2)) - !! - DO jj = 1, size(r1) - r1( jj ) = DOT_PRODUCT(r2(:, jj), m2(:, jj)) - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable( & - & r1, & - & typeFEVariableScalar, & - & typeFEVariableTime) - ELSE - ans = QuadratureVariable( & - & r1, & - & typeFEVariableScalar, & - & typeFEVariableTime) - END IF - !! - END SELECT -!! -CASE (spacetime) - !! - SELECT CASE (obj2%vartype) - !! - !! spacetime= spacetime DOT_PRODUCT constant - !! - CASE (constant) - !! - r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) - CALL Reallocate( r2, size(r3,2), size(r3,3) ) - !! - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), obj2%val(:)) - END DO - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! - !! spacetime=spacetime DOT_PRODUCT spacetime - !! - CASE (spacetime) - !! - r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime) - m3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime) - !! - CALL Reallocate( r2, size(r3,2), size(r3,3) ) - !! - DO kk = 1, SIZE(r3, 3) - DO jj = 1, SIZE(r3, 2) - r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), m3(:,jj,kk)) - END DO - END DO - !! - IF( obj1%defineon .EQ. nodal ) THEN - ans = NodalVariable(& - & r2, & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - ELSE - ans = QuadratureVariable(& - & r2, & - & typeFEVariableScalar, & - & typeFEVariableSpaceTime) - END IF - !! - END SELECT - !! -END SELECT -END PROCEDURE fevar_dot_product - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE DotProductMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 deleted file mode 100644 index 6dbcbef79..000000000 --- a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 +++ /dev/null @@ -1,56 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -#define _ELEM_METHOD_ SQRT - -SUBMODULE(FEVariable_Method) SqrtMethods -USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & - Scalar, Vector, Matrix, & - Nodal, Quadrature -USE BaseType, ONLY: TypeFEVariableScalar, & - TypeFEVariableVector, & - TypeFEVariableMatrix, & - TypeFEVariableConstant, & - TypeFEVariableSpace, & - TypeFEVariableTime, & - TypeFEVariableSpaceTime - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! SQRT -!---------------------------------------------------------------------------- - -MODULE PROCEDURE fevar_sqrt -SELECT CASE (obj%rank) -CASE (scalar) -#include "./include/ScalarElemMethod.F90" -CASE (vector) -#include "./include/VectorElemMethod.F90" -CASE (matrix) -#include "./include/MatrixElemMethod.F90" -END SELECT -END PROCEDURE fevar_sqrt - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE SqrtMethods - -#undef _ELEM_METHOD_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90 index 2c72ac268..348971c5c 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90 @@ -15,8 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) MultiplicationMethods - +SUBMODULE(FEVariable_MultiplicationMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, Nodal, Quadrature @@ -30,6 +29,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ * IMPLICIT NONE @@ -105,4 +106,5 @@ !---------------------------------------------------------------------------- #undef _OP_ -END SUBMODULE MultiplicationMethods + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 new file mode 100644 index 000000000..74f844b55 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 @@ -0,0 +1,565 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_NodalVariableMethod) Methods +USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Constant +INTEGER(I4B) :: s(1) + +s(1) = 1 +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%scalar, len=1) +obj%val(1) = val +END PROCEDURE Nodal_Scalar_Constant + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Space +INTEGER(I4B) :: s(1) + +s(1) = SIZE(val) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +obj%val(1:obj%len) = val +END PROCEDURE Nodal_Scalar_Space + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Space2 +INTEGER(I4B) :: s(1) + +s(1) = tsize +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +obj%val(1:obj%len) = 0.0_DFP +END PROCEDURE Nodal_Scalar_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Time +INTEGER(I4B) :: s(1) + +s(1) = SIZE(val) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +obj%val(1:obj%len) = val +END PROCEDURE Nodal_Scalar_Time + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_Time2 +INTEGER(I4B) :: s(1) + +s(1) = tsize +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +END PROCEDURE Nodal_Scalar_Time2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_SpaceTime +INTEGER(I4B) :: s(2), tsize, ii, jj, kk +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%scalar, len=tsize) + +kk = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + kk = kk + 1 + obj%val(kk) = val(ii, jj) + END DO +END DO +END PROCEDURE Nodal_Scalar_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_SpaceTime2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%scalar, len=tsize, & + val=val) +END PROCEDURE Nodal_Scalar_SpaceTime2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Scalar_SpaceTime3 +INTEGER(I4B) :: tsize, s(2) + +s(1) = nrow +s(2) = ncol +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%scalar, len=tsize) +END PROCEDURE Nodal_Scalar_SpaceTime3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Constant +INTEGER(I4B) :: s(1), tsize + +tsize = SIZE(val) +s(1) = tsize + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%vector, len=tsize, & + val=val) +END PROCEDURE Nodal_Vector_Constant + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Constant2 +INTEGER(I4B) :: s(1) + +s(1) = tsize + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%vector, len=tsize) +END PROCEDURE Nodal_Vector_Constant2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Space +INTEGER(I4B) :: s(2), tsize, ii, jj, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%vector, len=tsize) + +cnt = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO +END PROCEDURE Nodal_Vector_Space + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Space2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%vector, len=tsize, val=val) + +END PROCEDURE Nodal_Vector_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Space3 +INTEGER(I4B) :: s(2), tsize + +s(1) = nrow +s(2) = ncol +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%vector, len=tsize) +END PROCEDURE Nodal_Vector_Space3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Time +INTEGER(I4B) :: s(2), tsize, ii, jj, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%vector, len=tsize) + +cnt = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO +END PROCEDURE Nodal_Vector_Time + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Time2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%vector, len=tsize, val=val) +END PROCEDURE Nodal_Vector_Time2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_Time3 +INTEGER(I4B) :: tsize, s(2) + +s(1) = nrow +s(2) = ncol +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%vector, len=tsize) +END PROCEDURE Nodal_Vector_Time3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime +INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%vector, len=tsize) + +cnt = 0 +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE Nodal_Vector_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%vector, len=tsize, & + val=val) +END PROCEDURE Nodal_Vector_SpaceTime2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Vector_SpaceTime3 +INTEGER(I4B) :: tsize, s(3) + +s(1) = dim1 +s(2) = dim2 +s(3) = dim3 +tsize = s(1) * s(2) * s(3) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%vector, len=tsize) +END PROCEDURE Nodal_Vector_SpaceTime3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Constant +INTEGER(I4B) :: s(2), tsize, ii, jj, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO +END PROCEDURE Nodal_Matrix_Constant + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Constant2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%matrix, len=tsize, val=val) +END PROCEDURE Nodal_Matrix_Constant2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Constant3 +INTEGER(I4B) :: s(2), tsize + +s(1) = nrow +s(2) = ncol +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%matrix, len=tsize) +END PROCEDURE Nodal_Matrix_Constant3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Space +INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO kk = 1, s(3) + DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE Nodal_Matrix_Space + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Space2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%matrix, & + len=tsize, val=val) +END PROCEDURE Nodal_Matrix_Space2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Space3 +INTEGER(I4B) :: tsize, s(3) + +s(1) = dim1 +s(2) = dim2 +s(3) = dim3 + +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%matrix, len=tsize) +END PROCEDURE Nodal_Matrix_Space3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Time +INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE Nodal_Matrix_Time + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Time2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) * s(3) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%matrix, & + len=tsize, val=val) +END PROCEDURE Nodal_Matrix_Time2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_Time3 +INTEGER(I4B) :: tsize, s(3) + +s(1) = dim1 +s(2) = dim2 +s(3) = dim3 + +tsize = s(1) * s(2) * s(3) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%matrix, len=tsize) +END PROCEDURE Nodal_Matrix_Time3 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime +INTEGER(I4B) :: s(4), tsize, ii, jj, kk, ll, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) * s(4) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO ll = 1, SIZE(val, 4) + DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk, ll) + END DO + END DO + END DO +END DO +END PROCEDURE Nodal_Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime2 +INTEGER(I4B) :: tsize + +tsize = PRODUCT(s) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%matrix, len=tsize, val=val) +END PROCEDURE Nodal_Matrix_SpaceTime2 + +!---------------------------------------------------------------------------- +! NodalVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Nodal_Matrix_SpaceTime3 +INTEGER(I4B) :: tsize, s(4) + +s(1) = dim1 +s(2) = dim2 +s(3) = dim3 +s(4) = dim4 +tsize = PRODUCT(s) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%matrix, len=tsize) +END PROCEDURE Nodal_Matrix_SpaceTime3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 new file mode 100644 index 000000000..3b4327b2d --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 @@ -0,0 +1,472 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_QuadratureVariableMethod) Methods +USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Constant +INTEGER(I4B) :: s(1) + +s(1) = 1 +CALL FEVariableInitiate(obj=obj, s=s, & + defineon=TypeFEVariableOpt%quadrature, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%scalar, len=1) +obj%val(1) = val +END PROCEDURE Quadrature_Scalar_Constant + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Space +INTEGER(I4B) :: s(1) + +s(1) = SIZE(val) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +obj%val(1:obj%len) = val +END PROCEDURE Quadrature_Scalar_Space + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Space2 +INTEGER(I4B) :: s(1) + +s(1) = tsize +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +obj%val(1:obj%len) = 0.0_DFP +END PROCEDURE Quadrature_Scalar_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Time +INTEGER(I4B) :: s(1) + +s(1) = SIZE(val) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%scalar, len=s(1)) +obj%val(1:obj%len) = val +END PROCEDURE Quadrature_Scalar_Time + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_Time2 +INTEGER(I4B) :: s(1) + +s(1) = tsize +CALL FEVariableInitiate( & + obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, len=s(1), & + vartype=TypeFEVariableOpt%time, rank=TypeFEVariableOpt%scalar) +obj%val(1:obj%len) = 0.0_DFP +END PROCEDURE Quadrature_Scalar_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_SpaceTime +INTEGER(I4B) :: s(2), tsize, ii, jj, kk +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%scalar, len=tsize) + +kk = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + kk = kk + 1 + obj%val(kk) = val(ii, jj) + END DO +END DO +END PROCEDURE Quadrature_Scalar_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_SpaceTime2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) + +CALL FEVariableInitiate( & + obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, len=tsize, val=val, & + vartype=TypeFEVariableOpt%spacetime, rank=TypeFEVariableOpt%scalar) +END PROCEDURE Quadrature_Scalar_SpaceTime2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Scalar_SpaceTime3 +INTEGER(I4B) :: tsize, s(2) + +s(1) = nrow +s(2) = ncol +tsize = s(1) * s(2) + +CALL FEVariableInitiate( & + obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, len=tsize, & + vartype=TypeFEVariableOpt%spacetime, rank=TypeFEVariableOpt%scalar) +END PROCEDURE Quadrature_Scalar_SpaceTime3 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Constant +INTEGER(I4B) :: s(1), tsize + +tsize = SIZE(val) +s(1) = tsize + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%vector, len=tsize, & + val=val) +END PROCEDURE Quadrature_Vector_Constant + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Space +INTEGER(I4B) :: s(2), tsize, ii, jj, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%vector, len=tsize) + +cnt = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO +END PROCEDURE Quadrature_Vector_Space + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Space2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%vector, len=tsize, val=val) + +END PROCEDURE Quadrature_Vector_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Space3 +INTEGER(I4B) :: s(2), tsize + +s(1) = nrow +s(2) = ncol +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%vector, len=tsize) + +obj%val(1:obj%len) = 0.0_DFP +END PROCEDURE Quadrature_Vector_Space3 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Time +INTEGER(I4B) :: s(2), tsize, ii, jj, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%vector, len=tsize) + +cnt = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO +END PROCEDURE Quadrature_Vector_Time + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_Time2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%vector, len=tsize, val=val) + +END PROCEDURE Quadrature_Vector_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_SpaceTime +INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%vector, len=tsize) + +cnt = 0 +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE Quadrature_Vector_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_SpaceTime2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%vector, len=tsize, & + val=val) +END PROCEDURE Quadrature_Vector_SpaceTime2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Vector_SpaceTime3 +INTEGER(I4B) :: tsize, s(3) + +s(1) = dim1 +s(2) = dim2 +s(3) = dim3 +tsize = dim1 * dim2 * dim3 + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%vector, len=tsize) + +END PROCEDURE Quadrature_Vector_SpaceTime3 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Constant +INTEGER(I4B) :: s(2), tsize, ii, jj, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj) + END DO +END DO + +END PROCEDURE Quadrature_Matrix_Constant + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Constant2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%constant, & + rank=TypeFEVariableOpt%matrix, len=tsize, val=val) +END PROCEDURE Quadrature_Matrix_Constant2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Space +INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO kk = 1, s(3) + DO jj = 1, s(2) + DO ii = 1, s(1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE Quadrature_Matrix_Space + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Space2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) * s(3) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%space, & + rank=TypeFEVariableOpt%matrix, & + len=tsize, val=val) +END PROCEDURE Quadrature_Matrix_Space2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Time +INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE Quadrature_Matrix_Time + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_Time2 +INTEGER(I4B) :: tsize + +tsize = s(1) * s(2) * s(3) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%time, & + rank=TypeFEVariableOpt%matrix, & + len=tsize, val=val) + +END PROCEDURE Quadrature_Matrix_Time2 + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_SpaceTime +INTEGER(I4B) :: s(4), tsize, ii, jj, kk, ll, cnt + +s = SHAPE(val) +tsize = s(1) * s(2) * s(3) * s(4) + +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%matrix, len=tsize) + +cnt = 0 +DO ll = 1, SIZE(val, 4) + DO kk = 1, SIZE(val, 3) + DO jj = 1, SIZE(val, 2) + DO ii = 1, SIZE(val, 1) + cnt = cnt + 1 + obj%val(cnt) = val(ii, jj, kk, ll) + END DO + END DO + END DO +END DO +END PROCEDURE Quadrature_Matrix_SpaceTime + +!---------------------------------------------------------------------------- +! QuadratureVariable +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Quadrature_Matrix_SpaceTime2 +INTEGER(I4B) :: tsize + +tsize = PRODUCT(s) +CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, & + vartype=TypeFEVariableOpt%spacetime, & + rank=TypeFEVariableOpt%matrix, len=tsize, val=val) +END PROCEDURE Quadrature_Matrix_SpaceTime2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 new file mode 100644 index 000000000..97c1e39dd --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 @@ -0,0 +1,347 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_ScalarInterpolationMethod) Methods +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableSpaceTime, TypeFEVariableTime +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarConstantGetInterpolation_1 +INTEGER(I4B) :: ii + +tsize = nips +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +DO ii = 1, tsize + ans(ii) = ans(ii) + scale * obj%val(1) +END DO +END PROCEDURE ScalarConstantGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarConstantGetInterpolation_2 +INTEGER(I4B) :: ii, ansStart + +ansStart = (timeIndx - 1) * ans%s(1) +IF (.NOT. addContribution) ans%val(ansStart + 1:ansStart + nips) = 0.0_DFP + +DO ii = 1, nips + ans%val(ansStart + ii) = ans%val(ansStart + ii) + scale * obj%val(1) +END DO +END PROCEDURE ScalarConstantGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarConstantGetInterpolation_3 +IF (.NOT. addContribution) ans = 0.0_DFP +ans = ans + scale * obj%val(1) +END PROCEDURE ScalarConstantGetInterpolation_3 + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolation1_(ans, scale, N, nns, nips, val, & + valStart, ansStart) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart, ansStart + + INTEGER(I4B) :: ips, ii + + DO ips = 1, nips + DO ii = 1, nns + ans(ansStart + ips) = ans(ansStart + ips) & + + scale * N(ii, ips) * val(valStart + ii) + END DO + END DO + +END SUBROUTINE MasterGetInterpolation1_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolation3_(ans, scale, N, nns, spaceIndx, val, & + valStart) + REAL(DFP), INTENT(INOUT) :: ans + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, spaceIndx + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + + INTEGER(I4B) :: ii + + DO ii = 1, nns + ans = ans + scale * N(ii, spaceIndx) * val(valStart + ii) + END DO +END SUBROUTINE MasterGetInterpolation3_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarSpaceGetInterpolation_1 +INTEGER(I4B) :: ips + +tsize = nips +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + !! convert nodal values to quadrature values by using N + !! make sure nns .LE. obj%len + + CALL MasterGetInterpolation1_(ans=ans, scale=scale, N=N, nns=nns, & + nips=nips, val=obj%val, valStart=0, & + ansStart=0) + +CASE (TypeFEVariableOpt%quadrature) + !! No need for interpolation, just returnt the quadrature values + !! make sure nips .LE. obj%len + + DO ips = 1, tsize + ans(ips) = ans(ips) + scale * obj%val(ips) + END DO + +END SELECT + +END PROCEDURE ScalarSpaceGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarSpaceGetInterpolation_2 +INTEGER(I4B) :: ips, ansStart, valStart + +ansStart = (timeIndx - 1) * ans%s(1) +valStart = 0 + +IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + CALL MasterGetInterpolation1_(ans=ans%val, scale=scale, N=N, & + nns=nns, nips=nips, val=obj%val, & + valStart=valStart, ansStart=ansStart) + + ans%s(1) = nips + ans%len = nips + +CASE (TypeFEVariableOpt%quadrature) + DO ips = 1, nips + ans%val(ansStart + ips) = ans%val(ansStart + ips) + scale * obj%val(ips) + END DO + +END SELECT + +END PROCEDURE ScalarSpaceGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%defineon is nodal +! convert nodal values to quadrature values by using N +! make sure nns .LE. obj%len +! +! obj%defineon is quadrature +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len +MODULE PROCEDURE ScalarSpaceGetInterpolation_3 +IF (.NOT. addContribution) ans = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + CALL MasterGetInterpolation3_(ans=ans, scale=scale, N=N, nns=nns, & + spaceIndx=spaceIndx, val=obj%val, valStart=0) + +CASE (TypeFEVariableOpt%quadrature) + ans = ans + scale * obj%val(spaceIndx) + +END SELECT +END PROCEDURE ScalarSpaceGetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_1 +INTEGER(I4B) :: aa, valStart, ansStart +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +tsize = nips +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +ansStart = 0 + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + !! convert nodal values to quadrature values by using N + !! make sure nns .LE. obj%len + !! obj%s(1) should be atleast nns + !! obj%s(2) should be atleast nnt + + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = (aa - 1) * obj%s(1) + CALL MasterGetInterpolation1_(ans=ans, scale=myscale, N=N, nns=nns, & + nips=nips, val=obj%val, valStart=valStart, & + ansStart=ansStart) + END DO + +CASE (TypeFEVariableOpt%quadrature) + !! No need for interpolation, just returnt the quadrature values + !! make sure nips .LE. obj%len + + valStart = (timeIndx - 1) * obj%s(1) + DO aa = 1, tsize + ans(aa) = ans(aa) + scale * obj%val(valStart + aa) + END DO + +END SELECT + +END PROCEDURE ScalarSpaceTimeGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_2 +INTEGER(I4B) :: aa, valStart, ansStart +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +ansStart = (timeIndx - 1) * ans%s(1) +IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP + +SELECT CASE (obj%defineon) + +CASE (TypeFEVariableOpt%nodal) + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = (aa - 1) * obj%s(1) + CALL MasterGetInterpolation1_(ans=ans%val, scale=myscale, N=N, nns=nns, & + nips=nips, val=obj%val, valStart=valStart, & + ansStart=ansStart) + END DO + +CASE (TypeFEVariableOpt%quadrature) + valStart = (timeIndx - 1) * obj%s(1) + DO aa = 1, nips + ans%val(ansStart + aa) = ans%val(ansStart + aa) & + + scale * obj%val(valStart + aa) + END DO + +END SELECT + +END PROCEDURE ScalarSpaceTimeGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%defineon is nodal +! convert nodal values to quadrature values by using N +! make sure nns .LE. obj%len +! obj%s(1) should be atleast nns +! obj%s(2) should be atleast nnt +! +! obj%defineon is quadrature +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len + +MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_3 +INTEGER(I4B) :: aa, valStart +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +IF (.NOT. addContribution) ans = 0.0_DFP + +SELECT CASE (obj%defineon) + +CASE (TypeFEVariableOpt%nodal) + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = (aa - 1) * obj%s(1) + CALL MasterGetInterpolation3_(ans=ans, scale=myscale, N=N, nns=nns, & + spaceIndx=spaceIndx, val=obj%val, & + valStart=valStart) + END DO + +CASE (TypeFEVariableOpt%quadrature) + valStart = (timeIndx - 1) * obj%s(1) + ans = ans + scale * obj%val(valStart + spaceIndx) + +END SELECT +END PROCEDURE ScalarSpaceTimeGetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ScalarGetInterpolation_3 +INTEGER(I4B) :: vartype + +vartype = obj%varType + +SELECT CASE (vartype) +CASE (TypeFEVariableOpt%constant) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableConstant, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, & + addContribution=addContribution, ans=ans) + +CASE (TypeFEVariableOpt%space) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableSpace, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, & + addContribution=addContribution, ans=ans) + +CASE (TypeFEVariableOpt%time) + ! CALL GetInterpolation_( & + ! obj=obj, rank=rank, N=N, nns=nns, spaceIndx=spaceIndx, & + ! timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, & + ! addContribution=addContribution, ans=ans) + +CASE (TypeFEVariableOpt%spacetime) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableSpaceTime, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, & + addContribution=addContribution, ans=ans) + +END SELECT + +END PROCEDURE ScalarGetInterpolation_3 + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 new file mode 100644 index 000000000..5349d382f --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 @@ -0,0 +1,155 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(FEVariable_SetMethod) MatrixMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set7 +INTEGER(I4B) :: ii, jj, cnt + +obj%s(1:2) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) + +cnt = 0 + +IF (addContribution) THEN + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj) + END DO + END DO +ELSE + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj) + END DO + END DO +END IF +END PROCEDURE obj_Set7 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set8 +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%s(1:3) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) * obj%s(3) + +cnt = 0 +IF (addContribution) THEN + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk) + END DO + END DO + END DO +ELSE + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj, kk) + END DO + END DO + END DO +END IF +END PROCEDURE obj_Set8 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set9 +INTEGER(I4B) :: ii, jj, kk, ll, cnt + +obj%s(1:4) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) * obj%s(3) * obj%s(4) + +cnt = 0 +IF (addContribution) THEN + DO ll = 1, obj%s(4) + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk, ll) + END DO + END DO + END DO + END DO +ELSE + DO ll = 1, obj%s(4) + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj, kk, ll) + END DO + END DO + END DO + END DO +END IF +END PROCEDURE obj_Set9 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set12 +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%s(1:3) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) * obj%s(3) + +cnt = 0 +IF (addContribution) THEN + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk) + END DO + END DO + END DO +ELSE + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj, kk) + END DO + END DO + END DO +END IF +END PROCEDURE obj_Set12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE MatrixMethods diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 new file mode 100644 index 000000000..54ca3060d --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 @@ -0,0 +1,98 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_SetMethod) ScalarMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set1 +obj%len = 1 +obj%s(1) = obj%len +IF (addContribution) THEN + obj%val(1) = obj%val(1) + scale * val +ELSE + obj%val(1) = scale * val +END IF +END PROCEDURE obj_Set1 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set2 +obj%len = SIZE(val) +obj%s(1) = obj%len +IF (addContribution) THEN + obj%val(1:obj%len) = obj%val(1:obj%len) + scale * val(1:obj%len) +ELSE + obj%val(1:obj%len) = scale * val(1:obj%len) +END IF +END PROCEDURE obj_Set2 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set3 +INTEGER(I4B) :: ii, jj, cnt + +obj%s(1:2) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) + +cnt = 0 + +IF (addContribution) THEN + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj) + END DO + END DO +ELSE + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj) + END DO + END DO +END IF +END PROCEDURE obj_Set3 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set10 +obj%len = SIZE(val) +obj%s(1) = obj%len +IF (addContribution) THEN + obj%val(1:obj%len) = obj%val(1:obj%len) + scale * val(1:obj%len) +ELSE + obj%val(1:obj%len) = scale * val(1:obj%len) +END IF +END PROCEDURE obj_Set10 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE ScalarMethods diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 new file mode 100644 index 000000000..1d26f32cf --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 @@ -0,0 +1,131 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_SetMethod) VectorMethods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set4 +obj%len = SIZE(val) +obj%s(1) = SIZE(val) +IF (addContribution) THEN + obj%val(1:obj%len) = obj%val(1:obj%len) + scale * val(1:obj%len) +ELSE + obj%val(1:obj%len) = scale * val(1:obj%len) +END IF +END PROCEDURE obj_Set4 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set5 +INTEGER(I4B) :: ii, jj, cnt + +obj%s(1:2) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) + +cnt = 0 + +IF (addContribution) THEN + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj) + END DO + END DO +ELSE + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj) + END DO + END DO +END IF +END PROCEDURE obj_Set5 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set6 +INTEGER(I4B) :: ii, jj, kk, cnt + +obj%s(1:3) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) * obj%s(3) + +cnt = 0 +IF (addContribution) THEN + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk) + END DO + END DO + END DO +ELSE + DO kk = 1, obj%s(3) + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj, kk) + END DO + END DO + END DO +END IF +END PROCEDURE obj_Set6 + +!---------------------------------------------------------------------------- +! Set +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Set11 +INTEGER(I4B) :: ii, jj, cnt + +obj%s(1:2) = SHAPE(val) +obj%len = obj%s(1) * obj%s(2) + +cnt = 0 + +IF (addContribution) THEN + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj) + END DO + END DO +ELSE + DO jj = 1, obj%s(2) + DO ii = 1, obj%s(1) + cnt = cnt + 1 + obj%val(cnt) = scale * val(ii, jj) + END DO + END DO +END IF +END PROCEDURE obj_Set11 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE VectorMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90 similarity index 96% rename from src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 rename to src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90 index ab1f27b03..809c3a34b 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) SubtractionMethods +SUBMODULE(FEVariable_SubtractionMethod) Methods USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & Scalar, Vector, Matrix, & @@ -30,6 +30,8 @@ USE ReallocateUtility, ONLY: Reallocate +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get + #define _OP_ - IMPLICIT NONE @@ -138,5 +140,5 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE SubtractionMethods +END SUBMODULE Methods #undef _OP_ diff --git a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 b/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 similarity index 51% rename from src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 rename to src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 index 558a09ecd..5697bd0fc 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 +++ b/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 @@ -15,12 +15,11 @@ ! along with this program. If not, see ! -SUBMODULE(FEVariable_Method) Norm2Methods -USE IntegerUtility, ONLY: Get1DIndexFortran - -USE GlobalData, ONLY: Scalar, Vector, Matrix, & - Constant, Space, Time, & - SpaceTime, Nodal, Quadrature +SUBMODULE(FEVariable_UnaryMethod) Methods +USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) +USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, & + Scalar, Vector, Matrix, & + Nodal, Quadrature USE BaseType, ONLY: TypeFEVariableScalar, & TypeFEVariableVector, & @@ -30,12 +29,119 @@ TypeFEVariableTime, & TypeFEVariableSpaceTime +USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get +USE IntegerUtility, ONLY: Get1DIndexFortran USE ReallocateUtility, ONLY: Reallocate IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! Abs +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Abs +SELECT CASE (obj%rank) + +#define _ELEM_METHOD_ ABS +CASE (scalar) +#include "./include/ScalarElemMethod.F90" + +CASE (vector) +#include "./include/VectorElemMethod.F90" + +CASE (matrix) +#include "./include/MatrixElemMethod.F90" + +END SELECT +#undef _ELEM_METHOD_ + +END PROCEDURE fevar_Abs + +!---------------------------------------------------------------------------- +! Power +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Power +SELECT CASE (obj%rank) +CASE (scalar) +#include "./include/ScalarPower.F90" +CASE (vector) +#include "./include/VectorPower.F90" +CASE (matrix) +#include "./include/MatrixPower.F90" +END SELECT +END PROCEDURE fevar_Power + +!---------------------------------------------------------------------------- +! Sqrt +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_Sqrt +#define _ELEM_METHOD_ SQRT + +SELECT CASE (obj%rank) +CASE (scalar) +#include "./include/ScalarElemMethod.F90" +CASE (vector) +#include "./include/VectorElemMethod.F90" +CASE (matrix) +#include "./include/MatrixElemMethod.F90" +END SELECT + +#define _ELEM_METHOD_ SQRT +END PROCEDURE fevar_Sqrt + +!---------------------------------------------------------------------------- +! IsEqual +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_IsEqual +!! Internal variable +ans = .FALSE. +IF (obj1%len .NE. obj2%len) RETURN +IF (obj1%defineon .NE. obj2%defineon) RETURN +IF (obj1%rank .NE. obj2%rank) RETURN +IF (obj1%varType .NE. obj2%varType) RETURN +IF (ANY(obj1%s .NE. obj2%s)) RETURN + +IF (ALL(obj1%val(1:obj1%len) .APPROXEQ.obj2%val(1:obj2%len))) ans = .TRUE. +!! +END PROCEDURE fevar_IsEqual + +!---------------------------------------------------------------------------- +! NotEqual +!---------------------------------------------------------------------------- + +MODULE PROCEDURE fevar_NotEqual +ans = .FALSE. +IF (.NOT. ALL(obj1%val.APPROXEQ.obj2%val)) THEN + ans = .TRUE. + RETURN +END IF + +IF (obj1%defineon .NE. obj2%defineon) THEN + ans = .TRUE. + RETURN +END IF + +IF (obj1%rank .NE. obj2%rank) THEN + ans = .TRUE. + RETURN +END IF + +IF (obj1%varType .NE. obj2%varType) THEN + ans = .TRUE. + RETURN +END IF + +IF (ANY(obj1%s .NE. obj2%s)) THEN + ans = .TRUE. + RETURN +END IF +END PROCEDURE fevar_NotEqual + !---------------------------------------------------------------------------- ! NORM2 !---------------------------------------------------------------------------- @@ -120,4 +226,5 @@ ! !---------------------------------------------------------------------------- -END SUBMODULE Norm2Methods +END SUBMODULE Methods + diff --git a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 new file mode 100644 index 000000000..e2dfa8d19 --- /dev/null +++ b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 @@ -0,0 +1,543 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(FEVariable_VectorInterpolationMethod) Methods +USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, & + TypeFEVariableTime, TypeFEVariableSpaceTime +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal1_(ans, scale, N, nns, nsd, & + nips, val, valStart, valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, nsd, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: ips, jj, istart, iend + + DO ips = 1, nips + DO jj = 1, nns + istart = (jj - 1) * nsd + 1 + valStart + iend = jj * nsd + valStart + ans(1:nsd, ips) = ans(1:nsd, ips) & + + scale * N(jj, ips) * val(istart:iend) + END DO + END DO + + valEnd = valStart + nns * nsd + +END SUBROUTINE MasterGetInterpolationFromNodal1_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal2_(ans, scale, N, nns, nsd, & + nips, val, valStart, valEnd, & + ansStart, ansEnd) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, nsd, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + INTEGER(I4B), INTENT(IN) :: ansStart + INTEGER(I4B), INTENT(OUT) :: ansEnd + + INTEGER(I4B) :: ips, jj, ival, jval, ians, jans + + DO ips = 1, nips + ians = (ips - 1) * nsd + 1 + ansStart + jans = ips * nsd + ansStart + + DO jj = 1, nns + ival = (jj - 1) * nsd + 1 + valStart + jval = jj * nsd + valStart + ans(ians:jans) = ans(ians:jans) & + + scale * N(jj, ips) * val(ival:jval) + END DO + END DO + + valEnd = valStart + nns * nsd + ansEnd = ansStart + nips * nsd + +END SUBROUTINE MasterGetInterpolationFromNodal2_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromNodal3_(ans, scale, N, nns, nsd, & + spaceIndx, val, valStart, & + valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + REAL(DFP), INTENT(IN) :: N(:, :) + INTEGER(I4B), INTENT(IN) :: nns, nsd, spaceIndx + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: jj, istart, iend + + DO jj = 1, nns + istart = (jj - 1) * nsd + 1 + valStart + iend = jj * nsd + valStart + ans(1:nsd) = ans(1:nsd) & + + scale * N(jj, spaceIndx) * val(istart:iend) + END DO + + valEnd = valStart + nns * nsd + +END SUBROUTINE MasterGetInterpolationFromNodal3_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature1_(ans, scale, nsd, & + nips, val, valStart, & + valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: nsd, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: ips, istart, iend + + DO ips = 1, nips + istart = (ips - 1) * nsd + 1 + valStart + iend = ips * nsd + valStart + ans(1:nsd, ips) = ans(1:nsd, ips) + scale * val(istart:iend) + END DO + + valEnd = valStart + nips * nsd + +END SUBROUTINE MasterGetInterpolationFromQuadrature1_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature2_(ans, scale, nsd, & + nips, val, valStart, & + valEnd, ansStart, & + ansEnd) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: nsd, nips + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + INTEGER(I4B), INTENT(IN) :: ansStart + INTEGER(I4B), INTENT(OUT) :: ansEnd + + INTEGER(I4B) :: ii, tsize + + tsize = nips * nsd + valEnd = valStart + tsize + ansEnd = ansStart + tsize + + DO ii = 1, tsize + ans(ansStart + ii) = ans(ansStart + ii) + scale * val(valStart + ii) + END DO +END SUBROUTINE MasterGetInterpolationFromQuadrature2_ + +!---------------------------------------------------------------------------- +! MasterGetInterpolation_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE MasterGetInterpolationFromQuadrature3_(ans, scale, nsd, & + spaceIndx, val, & + valStart, valEnd) + REAL(DFP), INTENT(INOUT) :: ans(:) + REAL(DFP), INTENT(IN) :: scale + INTEGER(I4B), INTENT(IN) :: nsd, spaceIndx + REAL(DFP), INTENT(IN) :: val(:) + INTEGER(I4B), INTENT(IN) :: valStart + INTEGER(I4B), INTENT(OUT) :: valEnd + + INTEGER(I4B) :: istart, iend + + istart = (spaceIndx - 1) * nsd + 1 + valStart + iend = spaceIndx * nsd + valStart + ans(1:nsd) = ans(1:nsd) + scale * val(istart:iend) + + valEnd = valStart + nsd +END SUBROUTINE MasterGetInterpolationFromQuadrature3_ + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorConstantGetInterpolation_1 +INTEGER(I4B) :: ii + +nrow = obj%s(1) +ncol = nips +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +DO ii = 1, ncol + ans(1:nrow, ii) = ans(1:nrow, ii) + scale * obj%val(1:nrow) +END DO +END PROCEDURE VectorConstantGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorConstantGetInterpolation_2 +INTEGER(I4B) :: ii, ansStart, valStart, tsize + +tsize = ans%s(1) * ans%s(2) +ansStart = (timeIndx - 1) * tsize +IF (.NOT. addContribution) ans%val(ansStart + 1:ansStart + tsize) = 0.0_DFP + +valStart = 0 + +DO ii = 1, tsize + ans%val(ansStart + ii) = ans%val(ansStart + ii) & + + scale * obj%val(valStart + ii) +END DO +END PROCEDURE VectorConstantGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorConstantGetInterpolation_3 +tsize = obj%s(1) +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP +ans(1:tsize) = ans(1:tsize) + scale * obj%val(1:tsize) +END PROCEDURE VectorConstantGetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorSpaceGetInterpolation_1 +INTEGER(I4B) :: valEnd + +nrow = obj%s(1) +ncol = nips +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + !! Nodal Vector Space + !! Convert nodal values to quadrature values by using N(:,:) + !! make sure nns .LE. obj%len + + CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=scale, N=N, nns=nns, & + nsd=nrow, nips=nips, val=obj%val, & + valStart=0, valEnd=valEnd) + +CASE (TypeFEVariableOpt%quadrature) + !! No need for interpolation, just returnt the quadrature values + !! make sure nips .LE. obj%len + + CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, & + nsd=nrow, nips=nips, & + val=obj%val, valStart=0, & + valEnd=valEnd) + +END SELECT + +END PROCEDURE VectorSpaceGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! Following points should be noted +! obj%s(1) and ans%s(1) should be same +! ans%s(2) and nips should be same +! when obj var type is quadrature, then nips should be same as obj%s(2) +MODULE PROCEDURE VectorSpaceGetInterpolation_2 +INTEGER(I4B) :: ansStart, valStart, valEnd, ansEnd, nsd + +nsd = obj%s(1) +ansStart = (timeIndx - 1) * ans%s(1) * ans%s(2) +ansEnd = ansStart + ans%s(1) * ans%s(2) +valStart = 0 + +IF (.NOT. addContribution) ans%val(1 + ansStart:ansEnd) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=scale, N=N, & + nns=nns, nsd=nsd, nips=nips, & + val=obj%val, & + valStart=valStart, valEnd=valEnd, & + ansStart=ansStart, ansEnd=ansEnd) + +CASE (TypeFEVariableOpt%quadrature) + CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, & + nsd=nsd, nips=nips, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd, & + ansStart=ansStart, & + ansEnd=ansEnd) + +END SELECT +END PROCEDURE VectorSpaceGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%defineon is nodal +! +! Nodal Vector Space +! Convert nodal values to quadrature values by using N(:,:) +! make sure nns .LE. obj%len +! +! obj%defineon is quadrature +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len +MODULE PROCEDURE VectorSpaceGetInterpolation_3 +INTEGER(I4B) :: valEnd + +tsize = obj%s(1) +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=scale, N=N, nns=nns, & + nsd=tsize, spaceIndx=spaceIndx, & + val=obj%val, valStart=0, & + valEnd=valEnd) + +CASE (TypeFEVariableOpt%quadrature) + CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, & + nsd=tsize, & + spaceIndx=spaceIndx, & + val=obj%val, valStart=0, & + valEnd=valEnd) + +END SELECT + +END PROCEDURE VectorSpaceGetInterpolation_3 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorSpaceTimeGetInterpolation_1 +INTEGER(I4B) :: aa, valStart, valEnd +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +nrow = obj%s(1) +ncol = nips +IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + !! Convert nodal values to quadrature values by using N + !! make sure nns .LE. obj%len + !! obj%s(1) denotes the nsd in ans + !! obj%s(2) should be atleast nns + !! obj%s(3) should be atleast nnt + + valEnd = 0 + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = valEnd + CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=myscale, N=N, & + nns=nns, nsd=nrow, nips=nips, & + val=obj%val, valStart=valStart, & + valEnd=valEnd) + END DO + +CASE (TypeFEVariableOpt%quadrature) + !! No need for interpolation, just returnt the quadrature values + !! make sure nips .LE. obj%len + + valStart = nips * nrow * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, & + nsd=nrow, nips=nips, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd) + +END SELECT + +END PROCEDURE VectorSpaceTimeGetInterpolation_1 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! Convert nodal values to quadrature values by using N +! make sure nns .LE. obj%len +! obj%s(1) denotes the nsd in ans +! obj%s(2) should be atleast nns +! obj%s(3) should be atleast nnt +! +! No need for interpolation, just returnt the quadrature values +! make sure nips .LE. obj%len +MODULE PROCEDURE VectorSpaceTimeGetInterpolation_2 +INTEGER(I4B) :: ansStart, ansEnd, valStart, valEnd, nsd, aa +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +nsd = obj%s(1) +ansStart = (timeIndx - 1) * ans%s(1) * ans%s(2) +ansEnd = ansStart + ans%s(1) * ans%s(2) +valStart = 0 + +SELECT CASE (obj%defineon) + +CASE (TypeFEVariableOpt%nodal) + valEnd = 0 + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = valEnd + CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=myscale, N=N, & + nns=nns, nsd=nsd, nips=nips, & + val=obj%val, valStart=valStart, & + valEnd=valEnd, ansStart=ansStart, & + ansEnd=ansEnd) + END DO + +CASE (TypeFEVariableOpt%quadrature) + valStart = nips * nsd * (timeIndx - 1) + ansStart = nips * nsd * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, & + nsd=nsd, nips=nips, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd, & + ansStart=ansStart, & + ansEnd=ansEnd) + +END SELECT + +END PROCEDURE VectorSpaceTimeGetInterpolation_2 + +!---------------------------------------------------------------------------- +! GetInterpolation_ +!---------------------------------------------------------------------------- + +! obj%defineon is nodal +! +! Convert nodal values to quadrature values by using N +! +! make sure nns .LE. obj%len +! obj%s(1) denotes the nsd in ans +! obj%s(2) should be atleast nns +! obj%s(3) should be atleast nnt +! +! obj%defineon is quadrature +! +! No need for interpolation, just return the quadrature values +! make sure nips .LE. obj%len +MODULE PROCEDURE VectorSpaceTimeGetInterpolation_3 +INTEGER(I4B) :: aa, valStart, valEnd +REAL(DFP) :: myscale +LOGICAL(LGT), PARAMETER :: yes = .TRUE. + +tsize = obj%s(1) +IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP + +SELECT CASE (obj%defineon) +CASE (TypeFEVariableOpt%nodal) + + valEnd = 0 + DO aa = 1, nnt + myscale = scale * T(aa) + valStart = valEnd + CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=myscale, N=N, & + nns=nns, nsd=tsize, & + spaceIndx=spaceIndx, & + val=obj%val, valStart=valStart, & + valEnd=valEnd) + END DO + +CASE (TypeFEVariableOpt%quadrature) + + valStart = obj%s(2) * tsize * (timeIndx - 1) + CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, & + nsd=tsize, & + spaceIndx=spaceIndx, & + val=obj%val, & + valStart=valStart, & + valEnd=valEnd) + +END SELECT + +END PROCEDURE VectorSpaceTimeGetInterpolation_3 + +!---------------------------------------------------------------------------- +! VectorGetInterpolation_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VectorGetInterpolation_3 +INTEGER(I4B) :: vartype + +vartype = obj%varType + +SELECT CASE (vartype) +CASE (TypeFEVariableOpt%constant) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableConstant, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, ans=ans, & + tsize=tsize, addContribution=addContribution) + +CASE (TypeFEVariableOpt%space) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableSpace, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, ans=ans, & + tsize=tsize, addContribution=addContribution) + +CASE (TypeFEVariableOpt%time) + ! CALL GetInterpolation_( & + ! obj=obj, rank=rank, vartype=TypeFEVariableTime, N=N, nns=nns, & + ! spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, ans=ans, & + ! tsize=tsize, addContribution=addContribution) + +CASE (TypeFEVariableOpt%spacetime) + CALL GetInterpolation_( & + obj=obj, rank=rank, vartype=TypeFEVariableSpaceTime, N=N, nns=nns, & + spaceIndx=spaceIndx, timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, & + ans=ans, tsize=tsize, addContribution=addContribution) + +END SELECT +END PROCEDURE VectorGetInterpolation_3 + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE Methods diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90 index bb2d804b9..7e8491cc5 100644 --- a/src/submodules/FEVariable/src/include/matrix_constant.F90 +++ b/src/submodules/FEVariable/src/include/matrix_constant.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 @@ -17,3 +18,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = Constant +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_constant2.F90 b/src/submodules/FEVariable/src/include/matrix_constant2.F90 index 062b751b9..c3d68affd 100644 --- a/src/submodules/FEVariable/src/include/matrix_constant2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = Constant +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90 index 0cd267920..d17e017ff 100644 --- a/src/submodules/FEVariable/src/include/matrix_space.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space.F90 @@ -1,11 +1,11 @@ INTEGER(I4B) :: ii, jj, kk, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 - DO kk = 1, SIZE(val, 3) DO jj = 1, SIZE(val, 2) DO ii = 1, SIZE(val, 1) @@ -19,3 +19,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = Space +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_space2.F90 b/src/submodules/FEVariable/src/include/matrix_space2.F90 index d9cd89b84..e3a3720ad 100644 --- a/src/submodules/FEVariable/src/include/matrix_space2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = Space +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90 index 3a6463630..271a623c6 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90 @@ -1,11 +1,10 @@ INTEGER(I4B) :: ii, jj, kk, ll, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 - DO ll = 1, SIZE(val, 4) DO kk = 1, SIZE(val, 3) DO jj = 1, SIZE(val, 2) @@ -21,3 +20,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = SpaceTime +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 index 416f4d703..d56b5d2b9 100644 --- a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90 @@ -1,5 +1,5 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +8,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = SpaceTime +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_time.F90 b/src/submodules/FEVariable/src/include/matrix_time.F90 index a4b831d86..3ed2f7abe 100644 --- a/src/submodules/FEVariable/src/include/matrix_time.F90 +++ b/src/submodules/FEVariable/src/include/matrix_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, kk, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 @@ -19,3 +20,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = Time +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/matrix_time2.F90 b/src/submodules/FEVariable/src/include/matrix_time2.F90 index aaa1007bb..802a8533d 100644 --- a/src/submodules/FEVariable/src/include/matrix_time2.F90 +++ b/src/submodules/FEVariable/src/include/matrix_time2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Matrix obj%varType = Time +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/scalar_constant.F90 b/src/submodules/FEVariable/src/include/scalar_constant.F90 index 628f7a7b6..196477a21 100644 --- a/src/submodules/FEVariable/src/include/scalar_constant.F90 +++ b/src/submodules/FEVariable/src/include/scalar_constant.F90 @@ -1,8 +1,10 @@ obj%len = 1 -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1) = val obj%s(1) = 1 obj%defineOn = _DEFINEON_ obj%rank = Scalar obj%varType = Constant +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90 index c43d15d52..1a61a03f9 100644 --- a/src/submodules/FEVariable/src/include/scalar_space.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space.F90 @@ -1,8 +1,9 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%s(1) = obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val -obj%s(1) = SIZE(val) obj%defineOn = _DEFINEON_ obj%rank = SCALAR obj%varType = Space +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/scalar_space_time.F90 b/src/submodules/FEVariable/src/include/scalar_space_time.F90 index 75ee2a726..1f52da872 100644 --- a/src/submodules/FEVariable/src/include/scalar_space_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, kk obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) kk = 0 @@ -16,3 +17,4 @@ obj%defineOn = _DEFINEON_ obj%rank = SCALAR obj%varType = SpaceTime +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 index e85818d99..5b654bea4 100644 --- a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -10,3 +11,5 @@ obj%defineOn = _DEFINEON_ obj%rank = SCALAR obj%varType = SpaceTime +obj%isInit = .TRUE. + diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90 index 1a7b0d3e3..293b2879a 100644 --- a/src/submodules/FEVariable/src/include/scalar_time.F90 +++ b/src/submodules/FEVariable/src/include/scalar_time.F90 @@ -1,8 +1,9 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%s(1) = obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val -obj%s(1) = SIZE(val) obj%defineOn = _DEFINEON_ obj%rank = SCALAR obj%varType = Time +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_constant.F90 b/src/submodules/FEVariable/src/include/vector_constant.F90 index 42125ac15..47e1ca5f0 100644 --- a/src/submodules/FEVariable/src/include/vector_constant.F90 +++ b/src/submodules/FEVariable/src/include/vector_constant.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = Constant +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_space.F90 b/src/submodules/FEVariable/src/include/vector_space.F90 index 2d6a663ef..173945c30 100644 --- a/src/submodules/FEVariable/src/include/vector_space.F90 +++ b/src/submodules/FEVariable/src/include/vector_space.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 @@ -16,3 +17,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = Space +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_space2.F90 b/src/submodules/FEVariable/src/include/vector_space2.F90 index a2e7c5cbf..44cb5b65d 100644 --- a/src/submodules/FEVariable/src/include/vector_space2.F90 +++ b/src/submodules/FEVariable/src/include/vector_space2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = Space +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90 index e8ee7a797..20db18d8c 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time.F90 @@ -1,11 +1,11 @@ INTEGER(I4B) :: ii, jj, kk, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 - DO kk = 1, SIZE(val, 3) DO jj = 1, SIZE(val, 2) DO ii = 1, SIZE(val, 1) @@ -19,3 +19,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = SpaceTime +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_space_time2.F90 b/src/submodules/FEVariable/src/include/vector_space_time2.F90 index a671d1408..448ee6c8d 100644 --- a/src/submodules/FEVariable/src/include/vector_space_time2.F90 +++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = SpaceTime +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_time.F90 b/src/submodules/FEVariable/src/include/vector_time.F90 index 7cc4a4a7f..fa00f6144 100644 --- a/src/submodules/FEVariable/src/include/vector_time.F90 +++ b/src/submodules/FEVariable/src/include/vector_time.F90 @@ -1,7 +1,8 @@ INTEGER(I4B) :: ii, jj, cnt obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) cnt = 0 @@ -16,3 +17,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = TIME +obj%isInit = .TRUE. diff --git a/src/submodules/FEVariable/src/include/vector_time2.F90 b/src/submodules/FEVariable/src/include/vector_time2.F90 index b3e52b512..580deb7a7 100644 --- a/src/submodules/FEVariable/src/include/vector_time2.F90 +++ b/src/submodules/FEVariable/src/include/vector_time2.F90 @@ -1,5 +1,6 @@ obj%len = SIZE(val) -obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len +obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len ALLOCATE (obj%val(obj%capacity)) obj%val(1:obj%len) = val(1:obj%len) @@ -8,3 +9,4 @@ obj%defineOn = _DEFINEON_ obj%rank = Vector obj%varType = TIME +obj%isInit = .TRUE. diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 index e6d2ef714..3c6252ec0 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 @@ -38,13 +38,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP !! @@ -89,13 +89,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = masterC1 * muMaster slaveC1 = slaveC1 * muSlave @@ -141,15 +141,15 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! -CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! masterC1 = masterC1 * muMaster slaveC1 = slaveC1 * muSlave @@ -194,23 +194,17 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! -CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster) +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) !! -CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave) +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, val=muSlave) !! DO ips = 1, nips slaveips = quadMap(ips) @@ -254,28 +248,19 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=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) + & ans=slaveC1, & + & c=slaveElemsd%normal) + !! +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) + !! +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, val=muSlave) + !! +CALL GetInterpolation(obj=masterElemSD, ans=tauBar, val=tauvar) !! DO ips = 1, nips slaveips = quadMap(ips) diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 index 584a75829..7ea38ee45 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 @@ -35,8 +35,8 @@ CALL Reallocate(ans, nns, nns) CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal) + & ans=C1, & + & c=elemsd%normal) realval = elemsd%js * elemsd%ws * elemsd%thickness DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -62,8 +62,8 @@ CALL Reallocate(ans, nns, nns) CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal) + & ans=C1, & + & c=elemsd%normal) realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -89,9 +89,9 @@ CALL Reallocate(ans, nns, nns) CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=C1, & - & val=elemsd%normal) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) + & ans=C1, & + & c=elemsd%normal) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -115,8 +115,8 @@ 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 getProjectionOfdNdXt(obj=elemsd, ans=C1, c=elemsd%normal) +CALL getInterpolation(obj=elemsd, ans=muBar, val=mu) realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar DO ips = 1, nips ans(:, :) = ans(:, :) & @@ -141,9 +141,9 @@ 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) +CALL getProjectionOfdNdXt(obj=elemsd, ans=C1, c=elemsd%normal) +CALL getInterpolation(obj=elemsd, ans=muBar, val=mu) +CALL getInterpolation(obj=elemsd, ans=tauBar, val=tauvar) realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar DO ips = 1, nips ans(:, :) = ans(:, :) & diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 index d48566e36..79953118f 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 @@ -47,8 +47,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness !! @@ -96,8 +96,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -145,10 +145,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar !! @@ -196,10 +196,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar !! @@ -247,11 +247,11 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 index f9979feae..e83caaab5 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 @@ -44,8 +44,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! CALL Reallocate(m4, nns2, nns1, nsd1, nsd2) !! @@ -94,8 +94,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -142,11 +142,11 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar !! @@ -193,10 +193,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar !! @@ -243,11 +243,11 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & -& cdNdXt=masterC1, & -& val=elemsd%normal) +& ans=masterC1, & +& c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 index 41aaef053..4a69f9768 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 @@ -51,13 +51,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! DO ips = 1, nips slaveips = quadMap(ips) @@ -120,13 +120,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -192,13 +192,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -269,22 +269,22 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=muMasterBar, & + & ans=muMasterBar, & & val=muMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=muSlaveBar, & + & ans=muSlaveBar, & & val=muSlave) !! DO ips = 1, nips @@ -350,22 +350,22 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=tauMasterBar, & + & ans=tauMasterBar, & & val=tauMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=tauSlaveBar, & + & ans=tauSlaveBar, & & val=tauSlave) !! masterC1 = muMaster * masterC1 @@ -437,32 +437,32 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=muMasterBar, & + & ans=muMasterBar, & & val=muMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=muSlaveBar, & + & ans=muSlaveBar, & & val=muSlave) !! CALL getInterpolation( & & obj=masterElemSD, & - & interpol=tauMasterBar, & + & ans=tauMasterBar, & & val=tauMaster) !! CALL getInterpolation( & & obj=slaveElemSD, & - & interpol=tauSlaveBar, & + & ans=tauSlaveBar, & & val=tauSlave) !! DO ips = 1, nips diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 index cf3741f65..3636a0eec 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 @@ -35,15 +35,15 @@ nips = SIZE(masterElemSD%dNdXt, 3) nns2 = SIZE(slaveElemSD%dNdXt, 1) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! i3 = eye(nsd) !! @@ -101,15 +101,15 @@ nips = SIZE(masterElemSD%dNdXt, 3) nns2 = SIZE(slaveElemSD%dNdXt, 1) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! -CALL getProjectionOfdNdXt( & +CALL GetProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! i3 = eye(nsd) !! @@ -170,15 +170,15 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! -CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! i3 = eye(nsd) !! @@ -240,18 +240,18 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=masterElemSD%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemSD, & - & cdNdXt=slaveC1, & - & val=slaveElemSD%normal) + & ans=slaveC1, & + & c=slaveElemSD%normal) !! -CALL getInterpolation(obj=masterElemSD, interpol=muMasterBar, & - & val=muMaster) -CALL getInterpolation(obj=slaveElemSD, interpol=muSlaveBar, & - & val=muSlave) +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, & + val=muMaster) +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, & + val=muSlave) !! i3 = eye(nsd) !! @@ -313,19 +313,19 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemSD, & - & cdNdXt=masterC1, & - & val=masterElemSD%normal) + & ans=masterC1, & + & c=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) + & ans=slaveC1, & + & c=slaveElemSD%normal) + !! +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, & + val=muMaster) +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, & + val=muSlave) +CALL GetInterpolation(obj=masterElemSD, ans=taubar, val=tauvar) !! i3 = eye(nsd) !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 index 7c67006be..b0a7cc320 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 @@ -35,8 +35,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! ALLOCATE (ans(nns1, nns2)) ans = 0.0_DFP @@ -72,8 +72,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar !! @@ -106,10 +106,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 index ef4a4f7ee..e509dccb4 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 @@ -109,7 +109,7 @@ & cdNdXt=masterC1, & & val=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 index bf1ab204f..6ccf5d388 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 @@ -34,10 +34,7 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt( & - & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) +CALL GetProjectionOfdNdXt(obj=elemsd, ans=masterC1, c=elemsd%normal) !! CALL Reallocate(G12, nns1, nsd, nsd) CALL Reallocate(m4, nns1, nns1, nsd, nsd) @@ -84,8 +81,8 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & - & val=elemsd%normal) +CALL getProjectionOfdNdXt(obj=elemsd, ans=masterC1, & + c=elemsd%normal) !! CALL Reallocate(G12, nns1, nsd, nsd) CALL Reallocate(m4, nns1, nns1, nsd, nsd) @@ -132,10 +129,10 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, & - & val=elemsd%normal) +CALL getProjectionOfdNdXt(obj=elemsd, ans=masterC1, & + c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu !! @@ -182,8 +179,8 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) -CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) +CALL GetProjectionOfdNdXt(obj=elemsd, ans=masterC1, c=elemsd%normal) +CALL GetInterpolation(obj=elemsd, ans=muBar, val=mu) !! CALL Reallocate(G12, nns1, nsd, nsd) CALL Reallocate(m4, nns1, nns1, nsd, nsd) @@ -231,9 +228,9 @@ nsd = SIZE(elemsd%dNdXt, 2) nips = SIZE(elemsd%dNdXt, 3) !! -CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal) -CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu) -CALL getInterpolation(obj=elemsd, interpol=tauBar, val=tauvar) +CALL GetProjectionOfdNdXt(obj=elemsd, ans=masterC1, c=elemsd%normal) +CALL GetInterpolation(obj=elemsd, ans=muBar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=tauBar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 index 9756a37c1..32deda6dc 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 @@ -49,8 +49,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness !! @@ -107,8 +107,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -165,10 +165,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar !! @@ -225,10 +225,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar !! @@ -287,11 +287,11 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 index fa6f400a6..2a3877858 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 @@ -49,8 +49,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness !! @@ -109,8 +109,8 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu !! @@ -169,10 +169,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar !! @@ -231,10 +231,10 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) +CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar !! @@ -293,11 +293,11 @@ !! CALL getProjectionOfdNdXt( & & obj=elemsd, & - & cdNdXt=masterC1, & - & val=elemsd%normal) + & ans=masterC1, & + & c=elemsd%normal) !! -CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu) -CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar) +CALL getInterpolation(obj=elemsd, ans=mubar, val=mu) +CALL getInterpolation(obj=elemsd, ans=taubar, val=tauvar) !! realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar !! diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 index 7d5da6e4f..1e66637a7 100644 --- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 +++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 @@ -55,13 +55,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! DO ips = 1, nips !! @@ -139,13 +139,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -226,13 +226,13 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -315,23 +315,17 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! -CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=muMasterBar, & - & val=muMaster) +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) !! -CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=muSlaveBar, & - & val=muSlave) +CALL getInterpolation(obj=slaveElemSD, ans=muSlaveBar, val=muSlave) !! DO ips = 1, nips masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) @@ -417,23 +411,17 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=masterElemsd%normal) !! CALL getProjectionOfdNdXt( & & obj=slaveElemsd, & - & cdNdXt=slaveC1, & - & val=slaveElemsd%normal) + & ans=slaveC1, & + & c=slaveElemsd%normal) !! -CALL getInterpolation( & - & obj=masterElemSD, & - & interpol=tauMasterBar, & - & val=tauMaster) +CALL GetInterpolation(obj=masterElemSD, ans=tauMasterBar, val=tauMaster) !! -CALL getInterpolation( & - & obj=slaveElemSD, & - & interpol=tauSlaveBar, & - & val=tauSlave) +CALL GetInterpolation(obj=slaveElemSD, ans=tauSlaveBar, val=tauSlave) !! masterC1 = muMaster * masterC1 slaveC1 = muSlave * slaveC1 @@ -520,33 +508,21 @@ !! CALL getProjectionOfdNdXt( & & obj=masterElemsd, & - & cdNdXt=masterC1, & - & val=masterElemsd%normal) + & ans=masterC1, & + & c=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) + & ans=slaveC1, & + & c=slaveElemsd%normal) + !! +CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster) + !! +CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, val=muSlave) + !! +CALL GetInterpolation(obj=masterElemSD, ans=tauMasterBar, val=tauMaster) + !! +CALL GetInterpolation(obj=slaveElemSD, ans=tauSlaveBar, val=tauSlave) !! DO ips = 1, nips masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips) diff --git a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 index c090b621c..a55659e63 100644 --- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 +++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90 @@ -1,5 +1,6 @@ ! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com ! ! This program is free software: you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by @@ -13,10 +14,19 @@ ! ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -! SUBMODULE(ForceVector_Method) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate +USE ProductUtility, ONLY: OuterProd_ +USE ProductUtility, ONLY: OTimesTilda_ +USE FEVariable_Method, ONLY: FEVariableSize => Size +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ +USE BaseType, ONLY: math => TypeMathOpt + +#ifdef DEBUG_VER +USE Display_Method, ONLY: Display +#endif + IMPLICIT NONE CONTAINS @@ -24,177 +34,527 @@ ! ForceVector !---------------------------------------------------------------------------- +MODULE PROCEDURE ForceVector1 +INTEGER(I4B) :: tsize +CALL Reallocate(ans, test%nns) +CALL ForceVector_(test=test, ans=ans, tsize=tsize) +END PROCEDURE ForceVector1 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + MODULE PROCEDURE ForceVector_1 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP) :: realval INTEGER(I4B) :: ips -! main -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(test%N, 1)) +tsize = test%nns +ans(1:tsize) = 0.0_DFP -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) +DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO -DEALLOCATE (realval) END PROCEDURE ForceVector_1 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- +MODULE PROCEDURE ForceVector2 +INTEGER(I4B) :: tsize +tsize = test%nns +CALL Reallocate(ans, tsize) +CALL ForceVector_(test=test, c=c, crank=crank, ans=ans, tsize=tsize) +END PROCEDURE ForceVector2 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + MODULE PROCEDURE ForceVector_2 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) +REAL(DFP) :: realval, T(0), cbar INTEGER(I4B) :: ips -! main -CALL GetInterpolation(obj=test, interpol=realval, val=c) -realval = test%js * test%ws * test%thickness * realval -CALL Reallocate(ans, SIZE(test%N, 1)) +tsize = test%nns -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) +ans(1:tsize) = math%zero + +DO ips = 1, test%nips + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=cbar) + + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * cbar + + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO -DEALLOCATE (realval) END PROCEDURE ForceVector_2 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_2b +MODULE PROCEDURE ForceVector3 +INTEGER(I4B) :: nrow, ncol + +nrow = FEVariableSize(c, 1) +ncol = test%nns +CALL Reallocate(ans, nrow, ncol) +CALL ForceVector_(test=test, c=c, crank=crank, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE ForceVector3 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_3 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips +REAL(DFP) :: realval, cbar(3), T(0) +INTEGER(I4B) :: ips, i1, i2 + +nrow = FEVariableSize(c, 1) +ncol = test%nns +ans(1:nrow, 1:ncol) = 0.0_DFP -realval = test%js * test%ws * test%thickness * c -CALL Reallocate(ans, SIZE(test%N, 1)) +DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=cbar, tsize=i1) + + CALL OuterProd_(a=cbar(1:nrow), b=test%N(1:ncol, ips), & + anscoeff=math%one, scale=realval, & + ans=ans, nrow=i1, ncol=i2) END DO +END PROCEDURE ForceVector_3 + +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector4 +INTEGER(I4B) :: dim1, dim2, dim3 +dim1 = FEVariableSize(c, 1) +dim2 = FEVariableSize(c, 2) +dim3 = test%nns +CALL Reallocate(ans, dim1, dim2, dim3) +CALL ForceVector_(test=test, c=c, crank=crank, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3) +END PROCEDURE ForceVector4 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- -DEALLOCATE (realval) +MODULE PROCEDURE ForceVector_4 +REAL(DFP) :: cbar(3, 3), realval, T(0) +INTEGER(I4B) :: ips, i1, i2, i3 + +dim1 = FEVariableSize(c, 1) +dim2 = FEVariableSize(c, 2) +dim3 = test%nns + +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP -END PROCEDURE ForceVector_2b +DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=cbar, nrow=i1, ncol=i2) + + CALL OuterProd_(a=cbar(1:dim1, 1:dim2), b=test%N(1:dim3, ips), & + anscoeff=math%one, scale=realval, & + ans=ans, dim1=i1, dim2=i2, dim3=i3) +END DO +END PROCEDURE ForceVector_4 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_3 -! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :) +MODULE PROCEDURE ForceVector5 +INTEGER(I4B) :: tsize +tsize = test%nns +CALL Reallocate(ans, tsize) +CALL ForceVector_(test=test, c1=c1, c2=c2, c1rank=c1rank, c2rank=c2rank, & + ans=ans, tsize=tsize) +END PROCEDURE ForceVector5 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_5 +REAL(DFP) :: c1bar, c2bar, realval, T(0) INTEGER(I4B) :: ips -! main -CALL GetInterpolation(obj=test, interpol=cbar, val=c) -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1)) +tsize = test%nns +ans(1:tsize) = 0.0_DFP + +DO ips = 1, test%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=c2bar) -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(cbar(:, ips), test%N(:, ips)) + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) & + * c1bar * c2bar + + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO +END PROCEDURE ForceVector_5 -DEALLOCATE (realval, cbar) -END PROCEDURE ForceVector_3 +!---------------------------------------------------------------------------- +! ForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector6 +INTEGER(I4B) :: nrow, ncol +nrow = FEVariableSize(c2, 1) +ncol = test%nns +CALL Reallocate(ans, nrow, ncol) +CALL ForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE ForceVector6 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_6 +! Define internal variable +REAL(DFP) :: realval, c1bar, c2bar(3), T(0) +INTEGER(I4B) :: ips, i1, i2 + +nrow = FEVariableSize(c2, 1) +ncol = test%nns +ans(1:nrow, 1:ncol) = 0.0_DFP + +DO ips = 1, test%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=c2bar, tsize=i1) + + realval = c1bar * test%js(ips) * test%ws(ips) * test%thickness(ips) + + CALL OuterProd_(a=c2bar(1:nrow), b=test%N(1:ncol, ips), & + anscoeff=math%one, scale=realval, & + ans=ans, nrow=i1, ncol=i2) +END DO +END PROCEDURE ForceVector_6 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_4 +MODULE PROCEDURE ForceVector7 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = FEVariableSize(c2, 1) +dim2 = FEVariableSize(c2, 2) +dim3 = test%nns +CALL Reallocate(ans, dim1, dim2, dim3) +CALL ForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3) +END PROCEDURE ForceVector7 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_7 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -INTEGER(I4B) :: ips +REAL(DFP) :: c2bar(3, 3), realval, c1bar, T(0) +INTEGER(I4B) :: ips, i1, i2, i3 ! main -CALL GetInterpolation(obj=test, interpol=cbar, val=c) -realval = test%js * test%ws * test%thickness -CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), SIZE(test%N, 1)) +dim1 = FEVariableSize(c2, 1) +dim2 = FEVariableSize(c2, 2) +dim3 = test%nns +ans(1:dim1, 1:dim2, 1:dim3) = math%zero -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(cbar(:, :, ips), test%N(:, ips)) -END DO +DO ips = 1, test%nips -DEALLOCATE (realval, cbar) -END PROCEDURE ForceVector_4 + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2) + + realval = c1bar * test%js(ips) * test%ws(ips) * test%thickness(ips) + + CALL OuterProd_(a=c2bar(1:dim1, 1:dim2), b=test%N(1:dim3, ips), & + anscoeff=math%one, scale=realval, & + ans=ans, dim1=i1, dim2=i2, dim3=i3) +END DO +END PROCEDURE ForceVector_7 !---------------------------------------------------------------------------- ! ForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_5 +MODULE PROCEDURE ForceVector8 +INTEGER(I4B) :: tsize +tsize = test%nns +CALL Reallocate(ans, tsize) +CALL ForceVector_(test=test, c=c, ans=ans, tsize=tsize) +END PROCEDURE ForceVector8 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_8 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:) INTEGER(I4B) :: ips +REAL(DFP) :: realval -! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar * c2bar -CALL Reallocate(ans, SIZE(test%N, 1)) +tsize = test%nns +ans(1:tsize) = 0.0_DFP -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test%N(:, ips) +DO ips = 1, test%nips + realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c(ips) + ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips) END DO - -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_5 +END PROCEDURE ForceVector_8 !---------------------------------------------------------------------------- -! ForceVector +! ForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_6 +MODULE PROCEDURE ForceVector_9 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) INTEGER(I4B) :: ips +REAL(DFP) :: realval -! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test%N, 1)) +tsize = nns +ans(1:tsize) = 0.0_DFP -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips), test%N(:, ips)) +DO ips = 1, nips + realval = js(ips) * ws(ips) * thickness(ips) * c(ips) + ans(1:tsize) = ans(1:tsize) + realval * N(1:tsize, ips) END DO +END PROCEDURE ForceVector_9 -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_6 +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_10 +LOGICAL(LGT) :: donothing +INTEGER(I4B) :: a, b, mynns + +IF (.NOT. skipVertices) THEN + CALL ForceVector_( & + N=N, js=js, ws=ws, thickness=thickness, nns=nns, nips=nips, c=c, & + ans=ans, tsize=tsize) + RETURN +END IF + +donothing = nns .LE. tVertices +IF (donothing) THEN + tsize = 0 + RETURN +END IF + +a = tVertices + 1 +b = nns +mynns = nns - tVertices + +CALL ForceVector_( & + N=N(a:b, :), js=js, ws=ws, thickness=thickness, nns=mynns, nips=nips, c=c, & + ans=ans, tsize=tsize) +END PROCEDURE ForceVector_10 !---------------------------------------------------------------------------- -! ForceVector +! ForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE ForceVector_7 +MODULE PROCEDURE ForceVector_11 +! Define internal variable +INTEGER(I4B) :: ips, ipt +REAL(DFP) :: realval + +tsize = nns * nnt +ans(1:tsize) = 0.0_DFP + +DO ipt = 1, nipt + DO ips = 1, nips + realval = js(ips) * ws(ips) * spaceThickness(ips) * c(ips, ipt) * & + wt(ipt) * jt(ipt) * timeThickness(ipt) + CALL OTimesTilda_(a=timeN(1:nnt, ipt), b=spaceN(1:nns, ips), & + anscoeff=math%one, scale=realval, ans=ans, tsize=tsize) + END DO +END DO +END PROCEDURE ForceVector_11 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_12 +LOGICAL(LGT) :: donothing +INTEGER(I4B) :: a, b, d, e, mynns, mynnt + +IF (.NOT. skipVertices) THEN + CALL ForceVector_( & + spaceN=spaceN, timeN=timeN, js=js, ws=ws, jt=jt, wt=wt, & + spaceThickness=spaceThickness, timeThickness=timeThickness, nns=nns, & + nnt=nnt, nips=nips, nipt=nipt, c=c, ans=ans, tsize=tsize) + RETURN +END IF + +donothing = (nns .LE. tSpaceVertices) .OR. (nnt .LE. tTimeVertices) +IF (donothing) THEN + tsize = 0 + RETURN +END IF + +a = tSpaceVertices + 1 +b = nns +mynns = nns - tSpaceVertices + +d = tTimeVertices + 1 +e = nnt +mynnt = nnt - tTimeVertices + +CALL ForceVector_( & + spaceN=spaceN(a:b, :), timeN=timeN(d:e, :), js=js, ws=ws, jt=jt, wt=wt, & + spaceThickness=spaceThickness, timeThickness=timeThickness, nns=mynns, & + nnt=mynnt, nips=nips, nipt=nipt, c=c, ans=ans, tsize=tsize) +END PROCEDURE ForceVector_12 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_13 ! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) INTEGER(I4B) :: ips +REAL(DFP) :: realval -! main -CALL GetInterpolation(obj=test, interpol=c1bar, val=c1) -CALL GetInterpolation(obj=test, interpol=c2bar, val=c2) -realval = test%js * test%ws * test%thickness * c1bar -CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test%N, 1)) +tsize = nns +ans(1:tsize) = 0.0_DFP -DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD(c2bar(:, :, ips), test%N(:, ips)) +DO ips = 1, nips + realval = js(ips) * ws(ips) * thickness(ips) + ans(1:tsize) = ans(1:tsize) + realval * N(1:tsize, ips) END DO +END PROCEDURE ForceVector_13 -DEALLOCATE (realval, c1bar, c2bar) -END PROCEDURE ForceVector_7 +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_14 +LOGICAL(LGT) :: donothing +INTEGER(I4B) :: a, b, mynns + +IF (.NOT. skipVertices) THEN + CALL ForceVector_( & + N=N, js=js, ws=ws, thickness=thickness, nns=nns, nips=nips, & + ans=ans, tsize=tsize) + RETURN +END IF + +donothing = nns .LE. tVertices +IF (donothing) THEN + tsize = 0 + RETURN +END IF + +a = tVertices + 1 +b = nns +mynns = nns - tVertices + +CALL ForceVector_( & + N=N(a:b, :), js=js, ws=ws, thickness=thickness, nns=mynns, nips=nips, & + ans=ans, tsize=tsize) +END PROCEDURE ForceVector_14 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_15 +! Define internal variable +INTEGER(I4B) :: ips, ipt +REAL(DFP) :: realval + +tsize = nns * nnt +ans(1:tsize) = 0.0_DFP + +DO ipt = 1, nipt + DO ips = 1, nips + realval = js(ips) * ws(ips) * spaceThickness(ips) * & + wt(ipt) * jt(ipt) * timeThickness(ipt) + CALL OTimesTilda_(a=timeN(1:nnt, ipt), b=spaceN(1:nns, ips), & + anscoeff=math%one, scale=realval, ans=ans, tsize=tsize) + END DO +END DO +END PROCEDURE ForceVector_15 + +!---------------------------------------------------------------------------- +! ForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ForceVector_16 +LOGICAL(LGT) :: donothing +INTEGER(I4B) :: a, b, d, e, mynns, mynnt + +IF (.NOT. skipVertices) THEN + CALL ForceVector_( & + spaceN=spaceN, timeN=timeN, js=js, ws=ws, jt=jt, wt=wt, & + spaceThickness=spaceThickness, timeThickness=timeThickness, nns=nns, & + nnt=nnt, nips=nips, nipt=nipt, ans=ans, tsize=tsize) + RETURN +END IF + +donothing = (nns .LE. tSpaceVertices) .OR. (nnt .LE. tTimeVertices) +IF (donothing) THEN + tsize = 0 + RETURN +END IF + +a = tSpaceVertices + 1 +b = nns +mynns = nns - tSpaceVertices + +d = tTimeVertices + 1 +e = nnt +mynnt = nnt - tTimeVertices + +CALL ForceVector_( & + spaceN=spaceN(a:b, :), timeN=timeN(d:e, :), js=js, ws=ws, jt=jt, wt=wt, & + spaceThickness=spaceThickness, timeThickness=timeThickness, nns=mynns, & + nnt=mynnt, nips=nips, nipt=nipt, ans=ans, tsize=tsize) +END PROCEDURE ForceVector_16 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt index 74342d10f..d49cf928f 100644 --- a/src/submodules/Geometry/CMakeLists.txt +++ b/src/submodules/Geometry/CMakeLists.txt @@ -26,14 +26,4 @@ target_sources( ${src_path}/ReferenceElement_Method@LocalNodeCoordsMethods.F90 ${src_path}/ReferenceElement_Method@EnquireMethods.F90 ${src_path}/ReferenceElement_Method@VTKMethods.F90 - ${src_path}/ReferencePoint_Method@Methods.F90 - ${src_path}/ReferenceLine_Method@Methods.F90 - ${src_path}/Line_Method@Methods.F90 - ${src_path}/ReferenceTriangle_Method@Methods.F90 - ${src_path}/Triangle_Method@Methods.F90 - ${src_path}/Plane_Method@Methods.F90 - ${src_path}/ReferenceQuadrangle_Method@Methods.F90 - ${src_path}/ReferenceTetrahedron_Method@Methods.F90 - ${src_path}/ReferenceHexahedron_Method@Methods.F90 - ${src_path}/ReferencePrism_Method@Methods.F90 - ${src_path}/ReferencePyramid_Method@Methods.F90) + ${src_path}/Plane_Method@Methods.F90) diff --git a/src/submodules/Geometry/src/Line_Method@Methods.F90 b/src/submodules/Geometry/src/Line_Method@Methods.F90 deleted file mode 100644 index 93e5046f8..000000000 --- a/src/submodules/Geometry/src/Line_Method@Methods.F90 +++ /dev/null @@ -1,339 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -SUBMODULE(Line_Method) Methods -USE BaseMethod -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE line_exp_is_degenerate_nd -ans = (all(p1(1:dim_num) == p2(1:dim_num))) -END PROCEDURE line_exp_is_degenerate_nd - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE line_exp2imp_2d -integer(i4b), parameter :: dim_num = 2 -real(dfp) norm -! -! Take care of degenerate cases. -! -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - return -end if - -a = p2(2) - p1(2) -b = p1(1) - p2(1) -c = p2(1) * p1(2) - p1(1) * p2(2) - -norm = a * a + b * b + c * c - -if (0.0D+00 < norm) then - a = a / norm - b = b / norm - c = c / norm -end if - -if (a < 0.0D+00) then - a = -a - b = -b - c = -c -end if - -END PROCEDURE line_exp2imp_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure line_imp_is_degenerate_2d -ans = (a * a + b * b == 0.0D+00) -end procedure line_imp_is_degenerate_2d - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure lines_imp_int_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) a(dim_num, dim_num + 1) -integer(kind=4) info -! -p(1:dim_num) = 0.0D+00 -! -! Refuse to handle degenerate lines. -! -if (line_imp_is_degenerate_2d(a1, b1, c1)) then - ival = -1 - return -end if -! -if (line_imp_is_degenerate_2d(a2, b2, c2)) then - ival = -2 - return -end if -! -! Set up and solve a linear system. -! -a(1, 1) = a1 -a(1, 2) = b1 -a(1, 3) = -c1 -a(2, 1) = a2 -a(2, 2) = b2 -a(2, 3) = -c2 -! -call r8mat_solve(2, 1, a, info) -! -! If the inverse exists, then the lines intersect at the solution point. -! -if (info == 0) then - - ival = 1 - p(1:dim_num) = a(1:dim_num, 3) -! -! If the inverse does not exist, then the lines are parallel -! or coincident. Check for parallelism by seeing if the -! C entries are in the same ratio as the A or B entries. -! -else - ival = 0 - if (a1 == 0.0D+00) then - if (b2 * c1 == c2 * b1) then - ival = 2 - end if - else - if (a2 * c1 == c2 * a1) then - ival = 2 - end if - end if -end if -! -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure line_exp_perp_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) bot -real(kind=8) t -! -flag = .false. -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - flag = .true. - p4(1:2) = r8_huge() - return -end if -! -bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) -! -! (P3-P1) dot (P2-P1) = Norm(P3-P1) * Norm(P2-P1) * Cos(Theta). -! -! (P3-P1) dot (P2-P1) / Norm(P3-P1)^2 = normalized coordinate T -! of the projection of (P3-P1) onto (P2-P1). -! -t = sum((p1(1:dim_num) - p3(1:dim_num)) & - * (p1(1:dim_num) - p2(1:dim_num))) / bot -! -p4(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -! -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure lines_exp_int_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) a1 -real(kind=8) a2 -real(kind=8) b1 -real(kind=8) b2 -real(kind=8) c1 -real(kind=8) c2 -logical(kind=4) point_1 -logical(kind=4) point_2 -! -ival = 0 -p(1:dim_num) = 0.0D+00 -! -! Check whether either line is a point. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - point_1 = .true. -else - point_1 = .false. -end if - -if (all(q1(1:dim_num) == q2(1:dim_num))) then - point_2 = .true. -else - point_2 = .false. -end if -! -! Convert the lines to ABC format. -! -if (.not. point_1) then - call line_exp2imp_2d(p1, p2, a1, b1, c1) -end if - -if (.not. point_2) then - call line_exp2imp_2d(q1, q2, a2, b2, c2) -end if -! -! Search for intersection of the lines. -! -if (point_1 .and. point_2) then - if (all(p1(1:dim_num) == q1(1:dim_num))) then - ival = 1 - p(1:dim_num) = p1(1:dim_num) - end if -else if (point_1) then - if (a2 * p1(1) + b2 * p1(2) == c2) then - ival = 1 - p(1:dim_num) = p1(1:dim_num) - end if -else if (point_2) then - if (a1 * q1(1) + b1 * q1(2) == c1) then - ival = 1 - p(1:dim_num) = q1(1:dim_num) - end if -else - call lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) -end if -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure segment_point_dist_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) bot -real(kind=8) pn(dim_num) -real(kind=8) t -! -! If the line segment is actually a point, then the answer is easy. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - t = 0.0D+00 -else - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - t = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / bot - t = max(t, 0.0D+00) - t = min(t, 1.0D+00) -end if -! -pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure segment_point_dist_3d -integer(i4b), parameter :: dim_num = 3 -real(dfp) bot -real(dfp) pn(dim_num) -real(dfp) t -! -! If the line segment is actually a point, then the answer is easy. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - t = 0.0D+00 -else - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - t = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / bot - t = max(t, 0.0D+00) - t = min(t, 1.0D+00) -end if - -pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure line_exp_point_dist_signed_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) a -real(kind=8) b -real(kind=8) c -! -! If the explicit line degenerates to a point, the computation is easy. -! -if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then - dist_signed = sqrt(sum((p1(1:dim_num) - p(1:dim_num))**2)) -! -! Convert the explicit line to the implicit form A * P(1) + B * P(2) + C = 0. -! This makes the computation of the signed distance to (X,Y) easy. -! -else - a = p2(2) - p1(2) - b = p1(1) - p2(1) - c = p2(1) * p1(2) - p1(1) * p2(2) - dist_signed = (a * p(1) + b * p(2) + c) / sqrt(a * a + b * b) -end if -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -module procedure segment_point_near_2d -integer(kind=4), parameter :: dim_num = 2 -real(kind=8) bot -! -! If the line segment is actually a point, then the answer is easy. -! -if (all(p1(1:dim_num) == p2(1:dim_num))) then - t = 0.0D+00 -else - bot = sum((p2(1:dim_num) - p1(1:dim_num))**2) - t = sum((p(1:dim_num) - p1(1:dim_num)) & - * (p2(1:dim_num) - p1(1:dim_num))) / bot - t = max(t, 0.0D+00) - t = min(t, 1.0D+00) -end if -! -pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) -dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2)) -end procedure - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -#include "./inc/aux.inc" - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 index cfd0697ba..6bed1f443 100644 --- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 +++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 @@ -479,43 +479,85 @@ SELECT CASE (topo) CASE (Line) - CALL GetFaceElemType_Line(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Triangle) - CALL GetFaceElemType_Triangle(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Quadrangle) - CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Tetrahedron) - CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Hexahedron) - CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Prism) - CALL GetFaceElemType_Prism(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) CASE (Pyramid) - CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, opt=opt, & tFaceNodes=tFaceNodes, elemType=elemType) END SELECT END PROCEDURE GetFaceElemType1 +!---------------------------------------------------------------------------- +! GetFaceElemType +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType2 +INTEGER(I4B) :: topo + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (Line) + CALL GetFaceElemType_Line(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +CASE (Triangle) + CALL GetFaceElemType_Triangle(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +CASE (Quadrangle) + CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +CASE (Tetrahedron) + CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +CASE (Hexahedron) + CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +CASE (Prism) + CALL GetFaceElemType_Prism(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +CASE (Pyramid) + CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, opt=opt, & + tFaceNodes=tFaceNodes, elemType=elemType, & + localFaceNumber=localFaceNumber) + +END SELECT +END PROCEDURE GetFaceElemType2 + !---------------------------------------------------------------------------- ! MeasureSimplex !---------------------------------------------------------------------------- diff --git a/src/submodules/Hexahedron/CMakeLists.txt b/src/submodules/Hexahedron/CMakeLists.txt new file mode 100644 index 000000000..6347b7b77 --- /dev/null +++ b/src/submodules/Hexahedron/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferenceHexahedron_Method@Methods.F90 + ${src_path}/HexahedronInterpolationUtility@Methods.F90) diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Hexahedron/src/HexahedronInterpolationUtility@Methods.F90 similarity index 100% rename from src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 rename to src/submodules/Hexahedron/src/HexahedronInterpolationUtility@Methods.F90 diff --git a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90 similarity index 96% rename from src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 rename to src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90 index fadad220e..e3a0cb997 100644 --- a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 +++ b/src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90 @@ -598,7 +598,7 @@ ! GetFaceElemType_Hexahedron !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Hexahedron +MODULE PROCEDURE GetFaceElemType_Hexahedron1 INTEGER(I4B) :: elemType0 elemType0 = Input(default=Hexahedron8, option=elemType) @@ -621,7 +621,31 @@ IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 16_I4B END SELECT -END PROCEDURE GetFaceElemType_Hexahedron +END PROCEDURE GetFaceElemType_Hexahedron1 + +!---------------------------------------------------------------------------- +! GetFaceElemType_Hexahedron +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Hexahedron2 +SELECT CASE (elemType) +CASE (Hexahedron8) + faceElemType = Quadrangle4 + tFaceNodes = 4_I4B + +CASE (Hexahedron20) + faceElemType = Quadrangle8 + tFaceNodes = 8_I4B + +CASE (Hexahedron27) + faceElemType = Quadrangle9 + tFaceNodes = 9_I4B + +CASE (Hexahedron64) + faceElemType = Quadrangle16 + tFaceNodes = 16_I4B +END SELECT +END PROCEDURE GetFaceElemType_Hexahedron2 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 index cefd52e88..b063bfde7 100644 --- a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 +++ b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 @@ -20,7 +20,9 @@ ! summary: This submodule contains the contructor methods for [[IntVector_]] SUBMODULE(IntVector_ConstructorMethod) Methods -USE BaseMethod +USE IntVector_SetMethod, ONLY: SetTotalDimension +USE ReallocateUtility, ONLY: Util_Reallocate => Reallocate + IMPLICIT NONE CONTAINS @@ -29,216 +31,268 @@ ! !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_shape -IF (ALLOCATED(obj%Val)) THEN - Ans(1) = SIZE(obj%Val) -ELSE - Ans = 0 -END IF -END PROCEDURE intVec_shape +MODULE PROCEDURE obj_shape +LOGICAL(LGT) :: isok + +ans = 0 +isok = ALLOCATED(obj%val) +IF (isok) ans(1) = SIZE(obj%val) +END PROCEDURE obj_shape !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_Size -IF (ALLOCATED(obj%Val)) THEN - Ans = SIZE(obj%Val) -ELSE - Ans = 0 -END IF -END PROCEDURE intVec_Size +MODULE PROCEDURE obj_Size +LOGICAL(LGT) :: isok + +ans = 0 +isok = ALLOCATED(obj%val) +IF (isok) ans = SIZE(obj%val) +END PROCEDURE obj_Size !---------------------------------------------------------------------------- ! getTotalDimension !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_getTotalDimension +MODULE PROCEDURE obj_getTotalDimension ans = obj%tDimension -END PROCEDURE IntVec_getTotalDimension +END PROCEDURE obj_getTotalDimension !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_AllocateData -CALL Reallocate(obj%Val, Dims) -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_AllocateData +MODULE PROCEDURE obj_AllocateData +CALL Util_Reallocate(obj%val, dims) +CALL SetTotalDimension(obj, 1_I4B) +END PROCEDURE obj_AllocateData !---------------------------------------------------------------------------- ! Reallocate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_Reallocate -IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. row) THEN - DEALLOCATE (obj) - ALLOCATE (obj(row)) - END IF -ELSE +MODULE PROCEDURE obj_Reallocate +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tsize + +isok = ALLOCATED(obj) +IF (.NOT. isok) THEN ALLOCATE (obj(row)) + RETURN END IF -END PROCEDURE intVec_Reallocate + +tsize = SIZE(obj) +isok = tsize .NE. row +IF (isok) THEN + DEALLOCATE (obj) + ALLOCATE (obj(row)) +END IF +END PROCEDURE obj_Reallocate !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_Deallocate -IF (ALLOCATED(obj%Val)) DEALLOCATE (obj%Val) -END PROCEDURE intVec_Deallocate +MODULE PROCEDURE obj_Deallocate +LOGICAL(LGT) :: isok +obj%tDimension = 0_I4B +isok = ALLOCATED(obj%val) +IF (isok) DEALLOCATE (obj%val) +END PROCEDURE obj_Deallocate !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate1 -CALL ALLOCATE (obj, tSize) -END PROCEDURE intVec_initiate1 +MODULE PROCEDURE obj_initiate1 +CALL obj_AllocateData(obj=obj, dims=tSize) +END PROCEDURE obj_initiate1 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate2 +MODULE PROCEDURE obj_initiate2 INTEGER(I4B) :: n, i +LOGICAL(LGT) :: isok + n = SIZE(tSize) -IF (ALLOCATED(obj)) THEN - IF (SIZE(obj) .NE. n) THEN - DEALLOCATE (obj) - ALLOCATE (obj(n)) - END IF -ELSE +isok = ALLOCATED(obj) + +IF (.NOT. isok) THEN + ALLOCATE (obj(n)) + DO i = 1, n + CALL obj_AllocateData(obj=obj(i), dims=tSize(i)) + END DO + RETURN +END IF + +i = SIZE(obj) +isok = i .NE. n +IF (isok) THEN + DEALLOCATE (obj) ALLOCATE (obj(n)) END IF + DO i = 1, n - CALL ALLOCATE (obj(i), tSize(i)) + CALL obj_AllocateData(obj=obj(i), dims=tSize(i)) END DO -END PROCEDURE intVec_initiate2 +END PROCEDURE obj_initiate2 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate3 -IF (ALLOCATED(obj%Val)) DEALLOCATE (obj%Val) -ALLOCATE (obj%Val(a:b)) -obj%Val = 0 -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate3 +MODULE PROCEDURE obj_initiate3 +LOGICAL(LGT) :: isok + +isok = ALLOCATED(obj%val) +IF (isok) DEALLOCATE (obj%val) +ALLOCATE (obj%val(a:b)) +obj%val(a:b) = 0 +CALL SetTotalDimension(obj, 1_I4B) +END PROCEDURE obj_initiate3 !---------------------------------------------------------------------------- ! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate4a -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4a +MODULE PROCEDURE obj_initiate4a +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4a + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate4b -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4b +MODULE PROCEDURE obj_initiate4b +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4b -MODULE PROCEDURE intVec_initiate4c -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4c +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate4d -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate4d +MODULE PROCEDURE obj_initiate4c +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4c !---------------------------------------------------------------------------- -! Initiate +! Initiate !---------------------------------------------------------------------------- -MODULE PROCEDURE intVec_initiate5a -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate5a +MODULE PROCEDURE obj_initiate4d +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate4d -MODULE PROCEDURE intVec_initiate5b -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE intVec_initiate5b +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate5a +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate5a + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_initiate5b +#include "./include/Initiate4.F90" +END PROCEDURE obj_initiate5b + +!---------------------------------------------------------------------------- +! Initiate +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_Initiate6 +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tsize + +obj%tDimension = obj2%tDimension +isok = ALLOCATED(obj2%val) +IF (isok) THEN + tsize = SIZE(obj2%val) + CALL Util_Reallocate(obj%val, tsize) + CALL Copy_(x=obj%val, y=obj2%val) +END IF + +END PROCEDURE obj_Initiate6 !---------------------------------------------------------------------------- ! Vector !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_Constructor1 -CALL ALLOCATE (obj, tSize) -END PROCEDURE IntVec_Constructor1 +MODULE PROCEDURE obj_Constructor1 +CALL obj_AllocateData(obj=obj, dims=tSize) +END PROCEDURE obj_Constructor1 !---------------------------------------------------------------------------- ! Vector_Pointer !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_Constructor2 -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor2 +MODULE PROCEDURE obj_Constructor2 +CALL Initiate(obj=obj, val=val) +END PROCEDURE obj_Constructor2 !---------------------------------------------------------------------------- ! Vector_Pointer !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_Constructor3 -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor3 +MODULE PROCEDURE obj_Constructor3 +CALL Initiate(obj=obj, val=val) +END PROCEDURE obj_Constructor3 !---------------------------------------------------------------------------- ! Vector_Pointer !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_Constructor_1 +MODULE PROCEDURE obj_Constructor_1 ALLOCATE (obj) -CALL ALLOCATE (obj, tSize) -END PROCEDURE IntVec_Constructor_1 +CALL Initiate(obj=obj, tsize=tsize) +END PROCEDURE obj_Constructor_1 !---------------------------------------------------------------------------- ! Vector !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_Constructor_2 +MODULE PROCEDURE obj_Constructor_2 ALLOCATE (obj) -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor_2 +CALL Initiate(obj=obj, val=val) +END PROCEDURE obj_Constructor_2 !---------------------------------------------------------------------------- ! Vector !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_Constructor_3 +MODULE PROCEDURE obj_Constructor_3 ALLOCATE (obj) -obj%Val = Val -CALL setTotalDimension(obj, 1_I4B) -END PROCEDURE IntVec_Constructor_3 +CALL Initiate(obj=obj, val=val) +END PROCEDURE obj_Constructor_3 !---------------------------------------------------------------------------- ! Assignment !---------------------------------------------------------------------------- -MODULE PROCEDURE IntVec_assign_a -IF (ALLOCATED(obj%Val)) THEN - Val = obj%Val -END IF -END PROCEDURE IntVec_assign_a +MODULE PROCEDURE obj_assign_a +LOGICAL(LGT) :: isok +INTEGER(I4B) :: tsize + +isok = ALLOCATED(obj%val) +IF (.NOT. isok) RETURN + +tsize = SIZE(obj%val) +CALL Util_Reallocate(val, tsize) +CALL Copy_(x=val, y=obj%val) +END PROCEDURE obj_assign_a !---------------------------------------------------------------------------- ! Convert !---------------------------------------------------------------------------- MODULE PROCEDURE obj_convert_int -IF (ALLOCATED(From%Val)) THEN - To = From%Val -END IF +CALL obj_assign_a(val=to, obj=from) END PROCEDURE obj_convert_int !---------------------------------------------------------------------------- @@ -247,12 +301,13 @@ MODULE PROCEDURE obj_Copy_Int8 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO - END PROCEDURE obj_Copy_Int8 !---------------------------------------------------------------------------- @@ -261,9 +316,11 @@ MODULE PROCEDURE obj_Copy_Int16 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO END PROCEDURE obj_Copy_Int16 @@ -274,9 +331,11 @@ MODULE PROCEDURE obj_Copy_Int32 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO END PROCEDURE obj_Copy_Int32 @@ -287,9 +346,11 @@ MODULE PROCEDURE obj_Copy_Int64 INTEGER(I4B) :: tsize, ii + tsize = SIZE(y) -CALL Reallocate(x, tsize) -DO ii = 1, tsize +CALL Util_Reallocate(x, tsize) + +DO CONCURRENT(ii=1:tsize) x(ii) = y(ii) END DO END PROCEDURE obj_Copy_Int64 @@ -299,11 +360,10 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Copy1_ -INTEGER(I4B) :: xx, yy +INTEGER(I4B) :: yy -DO yy = y_start, y_end - xx = x_start + yy - y_start - x(xx) = y(yy) +DO CONCURRENT(yy=y_start:y_end) + x(x_start + yy - y_start) = y(yy) END DO END PROCEDURE obj_Copy1_ diff --git a/src/submodules/IntVector/src/include/Initiate4.F90 b/src/submodules/IntVector/src/include/Initiate4.F90 new file mode 100644 index 000000000..cddc52d4c --- /dev/null +++ b/src/submodules/IntVector/src/include/Initiate4.F90 @@ -0,0 +1,8 @@ +INTEGER(I4B) :: tsize, ii + +tsize = SIZE(val) +CALL Util_Reallocate(obj%val, tsize) +DO ii = 1, tsize + obj%val(ii) = INT(val(ii), kind=I4B) +END DO +CALL SetTotalDimension(obj, 1_I4B) diff --git a/src/submodules/Line/CMakeLists.txt b/src/submodules/Line/CMakeLists.txt new file mode 100644 index 000000000..430382110 --- /dev/null +++ b/src/submodules/Line/CMakeLists.txt @@ -0,0 +1,29 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/Line_Method@Methods.F90 + ${src_path}/ReferenceLine_Method@Methods.F90 + ${src_path}/LineInterpolationUtility@Methods.F90 + ${src_path}/LineInterpolationUtility@BasisMethods.F90 + ${src_path}/LineInterpolationUtility@OrthogonalMethods.F90 + ${src_path}/LineInterpolationUtility@LagrangeMethods.F90 + ${src_path}/LineInterpolationUtility@HierarchicalMethods.F90 + ${src_path}/LineInterpolationUtility@QuadratureMethods.F90 + ${src_path}/LineInterpolationUtility@InterpolationMethods.F90) diff --git a/src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90 new file mode 100644 index 000000000..067dc1854 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90 @@ -0,0 +1,328 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) BasisMethods +USE BaseType, ONLY: polyopt => TypePolynomialOpt +USE Display_Method, ONLY: ToString +USE StringUtility, ONLY: UpperCase +USE InputUtility, ONLY: Input +USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, & + EvalAllOrthopol_ + +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "LineInterpolationUtility@BasisMethods.F90" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! EvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line1 +INTEGER(I4B) :: tsize +CALL BasisEvalAll_Line1_( & + order=order, x=x, ans=ans, tsize=tsize, refline=refline, & + basistype=basistype, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE BasisEvalAll_Line1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BasisEvalAll_Line1_()" +LOGICAL(LGT) :: isok +CHARACTER(1) :: astr +#endif + +INTEGER(I4B) :: ii, basisType0, nrow, ncol +REAL(DFP) :: temp(1, 100), x1(1) + +tsize = order + 1 + +#ifdef DEBUG_VER +isok = astr .EQ. "B" +CALL AssertError1(isok, myName, modName, __LINE__, & + "refLine should be BIUNIT") +#endif + +basisType0 = Input(default=polyopt%Monomial, option=basisType) + +SELECT CASE (basisType0) + +CASE (polyopt%Monomial) + ans(1) = 1.0_DFP + DO ii = 1, order + ans(ii + 1) = ans(ii) * x + END DO + +CASE DEFAULT + +#ifdef DEBUG_VER + IF (basisType0 .EQ. polyopt%Jacobi) THEN + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for basisType=Jacobi") + END IF + + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + msg="lambda should be present for basisType=Ultraspherical") + END IF + + isok = order + 1 .LE. SIZE(temp, 2) + CALL AssertError1(isok, myName, modName, __LINE__, & + "order+1 is greater than number of col in temp") +#endif + + x1(1) = x + CALL EvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, alpha=alpha, & + beta=beta, lambda=lambda, ans=temp, nrow=nrow, & + ncol=ncol) + + ans(1:tsize) = temp(1, 1:tsize) + +END SELECT + +END PROCEDURE BasisEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! BasisGradientEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line1 +INTEGER(I4B) :: tsize +CALL BasisGradientEvalAll_Line1_( & + order=order, x=x, refLine=refLine, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, tsize=tsize) +END PROCEDURE BasisGradientEvalAll_Line1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BasisGradientEvalAll_Line1_()" +LOGICAL(LGT) :: isok +#endif + +INTEGER(I4B) :: ii, basisType0 +CHARACTER(1) :: astr +REAL(DFP) :: areal, breal, x1(1), temp(1, order + 1) + +tsize = order + 1 + +astr = UpperCase(refline(1:1)) + +#ifdef DEBUG_VER +isok = astr .EQ. "B" +CALL AssertError1(isok, myName, modName, __LINE__, & + "refline should be BIUNIT") +#endif + +basisType0 = Input(default=polyopt%Monomial, option=basisType) + +SELECT CASE (basisType0) + +CASE (polyopt%Monomial) + ans(1) = 0.0_DFP + DO ii = 1, order + areal = REAL(ii, kind=DFP) + breal = x**(ii - 1) + ans(ii + 1) = areal * breal + END DO + +CASE DEFAULT + +#ifdef DEBUG_VER + IF (basisType0 .EQ. polyopt%Jacobi) THEN + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for basisType=Jacobi") + END IF + + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for basisType=Ultraspherical") + END IF +#endif + + x1(1) = x + CALL GradientEvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=temp, nrow=ii, ncol=tsize) + + ans(1:tsize) = temp(1, 1:tsize) +END SELECT + +END PROCEDURE BasisGradientEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! BasisGradientEvalAll_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line2 +INTEGER(I4B) :: nrow, ncol +CALL BasisGradientEvalAll_Line2_( & + order=order, x=x, ans=ans, nrow=nrow, ncol=ncol, refLine=refLine, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE BasisGradientEvalAll_Line2 + +!---------------------------------------------------------------------------- +! BasisGradientEvalAll_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisGradientEvalAll_Line2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BasisGradientEvalAll_Line2_()" +LOGICAL(LGT) :: isok +#endif + +INTEGER(I4B) :: ii, basisType0, jj +REAL(DFP) :: areal, breal +CHARACTER(1) :: astr + +nrow = SIZE(x) +ncol = 1 + order + +astr = UpperCase(refLine(1:1)) + +#ifdef DEBUG_VER +isok = astr .EQ. "B" +CALL AssertError1(isok, myName, modName, __LINE__, & + "refLine should be Biunit") +#endif + +basisType0 = Input(default=polyopt%Monomial, option=basisType) + +SELECT CASE (basisType0) + +CASE (polyopt%Monomial) + ans(1:nrow, 1) = 0.0_DFP + + DO ii = 1, order + areal = REAL(ii, kind=dfp) + DO jj = 1, nrow + breal = x(jj)**(ii - 1) + ans(jj, ii + 1) = areal * breal + END DO + END DO + +CASE DEFAULT + +#ifdef DEBUG_VER + IF (basisType0 .EQ. polyopt%Jacobi) THEN + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for basisType=Jacobi") + END IF + + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for basisType=Ultraspherical") + END IF +#endif + + CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) + +END SELECT +END PROCEDURE BasisGradientEvalAll_Line2_ + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line2 +INTEGER(I4B) :: nrow, ncol +CALL BasisEvalAll_Line2_( & + order=order, x=x, ans=ans, nrow=nrow, ncol=ncol, refline=refline, & + basistype=basistype, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE BasisEvalAll_Line2 + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE BasisEvalAll_Line2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BasisEvalAll_Line2_()" +LOGICAL(LGT) :: isok +CHARACTER(1) :: astr +#endif + +INTEGER(I4B) :: ii, basisType0 + +nrow = SIZE(x) +ncol = order + 1 + +#ifdef DEBUG_VER +astr = UpperCase(refline(1:1)) +isok = astr .EQ. "B" +CALL AssertError1(isok, myName, modName, __LINE__, & + "refLine should be Biunit") +#endif + +basisType0 = Input(default=polyopt%Monomial, option=basisType) + +SELECT CASE (basisType0) + +CASE (polyopt%Monomial) + ans(1:nrow, 1) = 1.0_DFP + DO ii = 1, order + ans(1:nrow, ii + 1) = ans(1:nrow, ii) * x + END DO + +CASE DEFAULT + +#ifdef DEBUG_VER + IF (basisType0 .EQ. polyopt%Jacobi) THEN + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for basisType=Jacobi") + END IF + + IF (basisType0 .EQ. polyopt%Ultraspherical) THEN + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for basisType=Ultraspherical") + END IF +#endif + + CALL EvalAllOrthopol_(n=order, x=x, orthopol=basisType0, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) +END SELECT +END PROCEDURE BasisEvalAll_Line2_ + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE BasisMethods diff --git a/src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90 new file mode 100644 index 000000000..8e72a1b32 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90 @@ -0,0 +1,170 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) HierarchicalMethods +USE BaseType, ONLY: polyopt => TypePolynomialOpt +USE StringUtility, ONLY: UpperCase +USE MappingUtility, ONLY: FromUnitLine2BiUnitLine_ +USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, & + EvalAllOrthopol_ +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "LineInterpolationUtility@HierarchicalMethods.F90" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Line1 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Line1_(order=order, xij=xij, refLine=refLine, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Line1 + +!---------------------------------------------------------------------------- +! BasisEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Line1_ +INTEGER(I4B), PARAMETER :: orient = 1 +CALL HeirarchicalBasis_Line2_(order=order, xij=xij, refLine=refLine, & + orient=orient, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Line2_ +CHARACTER(1) :: astr +REAL(DFP) :: temp(SIZE(xij, 2)), o1 +INTEGER(I4B) :: ii, k + +o1 = REAL(orient, kind=DFP) +astr = UpperCase(refLine(1:1)) + +SELECT CASE (astr) +CASE ("U") + CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=nrow) + CALL EvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, ans=ans, & + nrow=nrow, ncol=ncol) + +CASE ("B") + CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=polyopt%Lobatto, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE DEFAULT + nrow = 0 + ncol = 0 +END SELECT + +DO CONCURRENT(k=2:order, ii=1:nrow) + ans(ii, k + 1) = (o1**k) * ans(ii, k + 1) +END DO +END PROCEDURE HeirarchicalBasis_Line2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalGradientBasis_Line1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalGradientBasis_Line1_( & + order=order, xij=xij, refLine=refLine, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3) +END PROCEDURE HeirarchicalGradientBasis_Line1 + +!---------------------------------------------------------------------------- +! HeirarchicalGradientBasis_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalGradientBasis_Line1_ +INTEGER(I4B), PARAMETER :: orient = 1 +CALL HeirarchicalGradientBasis_Line2_( & + order=order, xij=xij, refLine=refLine, orient=orient, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalGradientBasis_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalGradientBasis_Line2 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = SIZE(xij, 2) +dim2 = order + 1 +dim3 = 1 +ALLOCATE (ans(dim1, dim2, dim3)) +CALL HeirarchicalGradientBasis_Line2_( & + order=order, xij=xij, refLine=refLine, orient=orient, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalGradientBasis_Line2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalGradientBasis_Line2_ +CHARACTER(1) :: astr +REAL(DFP) :: temp(SIZE(xij, 2)), o1 +INTEGER(I4B) :: ii, jj, k + +o1 = REAL(orient, kind=DFP) +astr = UpperCase(refLine(1:1)) + +dim3 = 1 + +SELECT CASE (astr) + +CASE ("U") + CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=dim1) + CALL GradientEvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, & + ans=ans(:, :, 1), nrow=dim1, ncol=dim2) + + DO CONCURRENT(ii=1:dim1, jj=1:dim2) + ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP + END DO + +CASE ("B") + CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & + orthopol=polyopt%Lobatto, ans=ans(:, :, 1), & + nrow=dim1, ncol=dim2) + +CASE DEFAULT + dim1 = 0; dim2 = 0; dim3 = 0 + RETURN +END SELECT + +DO CONCURRENT(k=2:order, ii=1:dim1) + ans(ii, k + 1, 1) = (o1**(k - 1)) * ans(ii, k + 1, 1) +END DO + +END PROCEDURE HeirarchicalGradientBasis_Line2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE HierarchicalMethods diff --git a/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 new file mode 100644 index 000000000..db12306a6 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 @@ -0,0 +1,550 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) InterpolationMethods +USE BaseType, ONLY: ipopt => TypeInterpolationOpt +USE MappingUtility, ONLY: FromBiunitLine2Segment_ +USE LegendrePolynomialUtility, ONLY: LegendreQuadrature +USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature +USE JacobiPolynomialUtility, ONLY: JacobiQuadrature +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature +USE SortUtility, ONLY: HeapSort + +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "LineInterpolationUtility@InterpolationMethods.F90" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! ToVEFC_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE ToVEFC_Line +REAL(DFP) :: t1 +INTEGER(I4B) :: np +LOGICAL(LGT) :: isok +np = SIZE(pt) +t1 = pt(np) +isok = np .GT. 2 +IF (isok) THEN + pt(3:np) = pt(2:np - 1) + pt(2) = t1 +END IF +END PROCEDURE ToVEFC_Line + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line1 +INTEGER(I4B) :: tsize +LOGICAL(LGT) :: isok + +isok = order .LE. 1_I4B +IF (isok) THEN + ALLOCATE (ans(0)) + RETURN +END IF + +tsize = LagrangeInDOF_Line(order=order) +ALLOCATE (ans(tsize)) +CALL EquidistanceInPoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize) +END PROCEDURE EquidistanceInPoint_Line1 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line1_ +INTEGER(I4B) :: ii +REAL(DFP) :: avar + +tsize = 0 +IF (order .LE. 1_I4B) RETURN + +tsize = LagrangeInDOF_Line(order=order) + +avar = (xij(2) - xij(1)) / order + +DO ii = 1, tsize + ans(ii) = xij(1) + REAL(ii, kind=dfp) * avar +END DO +END PROCEDURE EquidistanceInPoint_Line1_ + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line2 +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +isok = order .LE. 1_I4B +IF (isok) THEN + ALLOCATE (ans(0, 0)) + RETURN +END IF + +isok = PRESENT(xij) +IF (isok) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 1_I4B +END IF + +ncol = LagrangeInDOF_Line(order=order) + +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE EquidistanceInPoint_Line2 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Line2_ +INTEGER(I4B) :: ii +REAL(DFP) :: x0(3, 3) + +nrow = 0; ncol = 0 +IF (order .LE. 1_I4B) RETURN + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + x0(1:nrow, 1) = xij(1:nrow, 1) + x0(1:nrow, 2) = xij(1:nrow, 2) +ELSE + nrow = 1_I4B + x0(1, 1) = -1.0 + x0(1, 2) = 1.0 +END IF + +ncol = LagrangeInDOF_Line(order=order) + +x0(1:nrow, 3) = (x0(1:nrow, 2) - x0(1:nrow, 1)) / order + +DO ii = 1, ncol + ans(1:nrow, ii) = x0(1:nrow, 1) + ii * x0(1:nrow, 3) +END DO +END PROCEDURE EquidistanceInPoint_Line2_ + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line1 +INTEGER(I4B) :: tsize + +tsize = order + 1 +ALLOCATE (ans(tsize)) +CALL EquidistancePoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize) +END PROCEDURE EquidistancePoint_Line1 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line1_ +INTEGER(I4B) :: tempint + +tsize = order + 1 + +SELECT CASE (order) +CASE (0) + ans(1) = 0.5_DFP * (xij(1) + xij(2)) + +CASE (1) + ans(1) = xij(1) + ans(2) = xij(2) + +CASE DEFAULT + ans(1) = xij(1) + ans(2) = xij(2) + CALL EquidistanceInPoint_Line_(order=order, xij=xij, ans=ans(3:), & + tsize=tempint) +END SELECT + +END PROCEDURE EquidistancePoint_Line1_ + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line2 +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 1_I4B +END IF + +ncol = order + 1 +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistancePoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE EquidistancePoint_Line2 + +!---------------------------------------------------------------------------- +! EquidistancePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Line2_ +INTEGER(I4B) :: tempint + +ncol = order + 1 + +SELECT CASE (order) + +CASE (0) + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ans(1:nrow, 1) = 0.5_DFP * (xij(1:nrow, 1) + xij(1:nrow, 2)) + RETURN + END IF + + nrow = 1_I4B + ans(1, 1) = 0.0_DFP + +CASE (1) + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ans(1:nrow, 1:2) = xij(1:nrow, 1:2) + RETURN + END IF + + nrow = 1 + ans(1, 1) = -1.0_DFP + ans(1, 2) = 1.0_DFP + +CASE DEFAULT + + IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) + ans(1:nrow, 1:2) = xij(1:nrow, 1:2) + ELSE + nrow = 1 + ans(1, 1) = -1.0_DFP + ans(1, 2) = 1.0_DFP + END IF + + CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans(:, 3:), & + nrow=nrow, ncol=tempint) + +END SELECT + +END PROCEDURE EquidistancePoint_Line2_ + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line1 +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +nrow = 1 +isok = PRESENT(xij) +IF (isok) nrow = SIZE(xij, 1) +ncol = order + 1 + +ALLOCATE (ans(nrow, ncol)) + +CALL InterpolationPoint_Line1_( & + order=order, ipType=ipType, ans=ans, nrow=nrow, ncol=ncol, layout=layout, & + xij=xij, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE InterpolationPoint_Line1 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line2 +INTEGER(I4B) :: tsize +tsize = order + 1 +ALLOCATE (ans(tsize)) +CALL InterpolationPoint_Line2_( & + order=order, ipType=ipType, xij=xij, layout=layout, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, tsize=tsize) +END PROCEDURE InterpolationPoint_Line2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Line1_()" +#endif + +REAL(DFP) :: temp(64) + +IF (order .EQ. 0_I4B) THEN + CALL EquidistancePoint_Line_(xij=xij, order=order, ans=ans, nrow=nrow, & + ncol=ncol) + RETURN +END IF + +CALL handle_error +!! handle_error is defined in this routine, see below + +ncol = order + 1 + +SELECT CASE (ipType) + +CASE (ipopt%Equidistance) + CALL EquidistancePoint_Line_(xij=xij, order=order, nrow=nrow, ncol=ncol, & + ans=ans) + CALL handle_increasing + +CASE (ipopt%GaussLegendre) + CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss) + CALL handle_non_equidistance + +CASE (ipopt%GaussChebyshev) + CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss) + CALL handle_non_equidistance + +CASE (ipopt%GaussLegendreLobatto) + CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), & + quadType=ipopt%GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (ipopt%GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), & + quadType=ipopt%GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (ipopt%GaussJacobi) + CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss, & + alpha=alpha, beta=beta) + CALL handle_non_equidistance + +CASE (ipopt%GaussJacobiLobatto) + CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), & + quadType=ipopt%GaussLobatto, alpha=alpha, beta=beta) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (ipopt%GaussUltraspherical) + CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), & + quadType=ipopt%Gauss, lambda=lambda) + CALL handle_non_equidistance + +CASE (ipopt%GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), & + quadType=ipopt%GaussLobatto, lambda=lambda) + + CALL handle_vefc + CALL handle_non_equidistance + +#ifdef DEBUG_VER +CASE DEFAULT + ! AssertError1(a, myName, modName, lineNo, msg) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "Unknown iptype") +#endif + +END SELECT + +CONTAINS + +SUBROUTINE handle_vefc + REAL(DFP) :: t1 + !! layout VEFC + IF (layout(1:1) .EQ. "V") THEN + t1 = temp(order + 1) + IF (order .GE. 2) THEN + temp(3:order + 1) = temp(2:order) + END IF + temp(2) = t1 + END IF +END SUBROUTINE handle_vefc + +SUBROUTINE handle_increasing + INTEGER(I4B) :: ii + !! layout INCREASING + IF (layout(1:1) .EQ. "I") THEN + DO ii = 1, nrow + CALL HeapSort(ans(ii, 1:ncol)) + END DO + END IF +END SUBROUTINE + +SUBROUTINE handle_non_equidistance + IF (PRESENT(xij)) THEN + CALL FromBiunitLine2Segment_(xin=temp(1:ncol), x1=xij(:, 1), & + x2=xij(:, 2), ans=ans, nrow=nrow, ncol=ncol) + ELSE + nrow = 1 + ans(1, 1:ncol) = temp(1:ncol) + END IF +END SUBROUTINE handle_non_equidistance + +SUBROUTINE handle_error +#ifdef DEBUG_VER + LOGICAL(LGT) :: isok + + SELECT CASE (ipType) + CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto) + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for ipType=GaussJacobi") + + CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for ipType=GaussUltraSpherical") + END SELECT +#endif + +END SUBROUTINE handle_error + +END PROCEDURE InterpolationPoint_Line1_ + +!---------------------------------------------------------------------------- +! InterpolationPoint_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Line2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Line2_()" +#endif + +tsize = order + 1 +IF (order .EQ. 0_I4B) THEN + ans(1) = 0.5_DFP * (xij(1) + xij(2)) + RETURN +END IF + +CALL handle_error + +SELECT CASE (ipType) + +CASE (ipopt%Equidistance) + CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans) + + IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans(1:tsize)) + +CASE (ipopt%GaussLegendre) + CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss) + CALL handle_non_equidistance + +CASE (ipopt%GaussChebyshev) + CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%Gauss) + CALL handle_non_equidistance + +CASE (ipopt%GaussJacobi) + CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, alpha=alpha, & + beta=beta) + CALL handle_non_equidistance + +CASE (ipopt%GaussUltraspherical) + CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, & + lambda=lambda) + CALL handle_non_equidistance + +CASE (ipopt%GaussLegendreLobatto) + CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (ipopt%GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (ipopt%GaussJacobiLobatto) + CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, alpha=alpha, & + beta=beta) + CALL handle_vefc + CALL handle_non_equidistance + +CASE (ipopt%GaussUltrasphericalLobatto) + CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, & + lambda=lambda) + CALL handle_vefc + CALL handle_non_equidistance + +#ifdef DEBUG_VER +CASE DEFAULT + CALL AssertError1(.FALSE., myName, modName, __LINE__, "Unknown ipType") +#endif + +END SELECT + +CONTAINS + +SUBROUTINE handle_vefc + REAL(DFP) :: t1 + + IF (layout(1:2) .EQ. "VE") THEN + t1 = ans(order + 1) + IF (order .GE. 2) THEN + ans(3:) = ans(2:order) + END IF + ans(2) = t1 + END IF + +END SUBROUTINE handle_vefc + +SUBROUTINE handle_non_equidistance + CALL FromBiunitLine2Segment_(xin=ans, x1=xij(1), x2=xij(2), & + ans=ans, tsize=tsize) +END SUBROUTINE handle_non_equidistance + +SUBROUTINE handle_error + +#ifdef DEBUG_VER + LOGICAL(LGT) :: isok + + SELECT CASE (ipType) + CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto) + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for ipType=GaussJacobi") + + CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for ipType=GaussUltraSpherical") + END SELECT + +#endif + +END SUBROUTINE handle_error + +END PROCEDURE InterpolationPoint_Line2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE InterpolationMethods diff --git a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 new file mode 100644 index 000000000..420153623 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 @@ -0,0 +1,457 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) LagrangeMethods +USE BaseType, ONLY: polyopt => TypePolynomialOpt, elmopt => TypeElemNameOpt +USE Display_Method, ONLY: ToString, Display +USE InputUtility, ONLY: Input +USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat +USE F95_BLAS, ONLY: GEMM +USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, & + EvalAllOrthopol_ +USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ + +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "LineInterpolationUtility@LagrangeMethods.F90" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! LagrangeDegree_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Line +INTEGER(I4B) :: ii, n +n = LagrangeDOF_Line(order=order) +ALLOCATE (ans(n, 1)) +DO ii = 1, n + ans(ii, 1) = ii - 1 +END DO +END PROCEDURE LagrangeDegree_Line + +!---------------------------------------------------------------------------- +! LagrangeDOF_Point +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Point +ans = 1_I4B +END PROCEDURE LagrangeDOF_Point + +!---------------------------------------------------------------------------- +! LagrangeDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Line +ans = order + 1 +END PROCEDURE LagrangeDOF_Line + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Line +ans = order - 1_I4B +END PROCEDURE LagrangeInDOF_Line + +!---------------------------------------------------------------------------- +! GetTotalDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalDOF_Line +ans = order + 1 +END PROCEDURE GetTotalDOF_Line + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetTotalInDOF_Line +ans = order - 1_I4B +IF (ans .LT. 0_I4B) ans = 0_I4B +END PROCEDURE GetTotalInDOF_Line + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line1 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Line1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Line1 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line1_ +REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info, nrow, ncol + +tsize = order + 1 +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, & + ans=v, nrow=nrow, ncol=ncol) + +CALL GetLU(A=v, IPIV=ipiv, info=info) + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line1_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Line2_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Line2 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line2_ +REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2)) +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info + +tsize = order + 1 + +vtemp = v +! ipiv = 0 + +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) + +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP + +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) + +END PROCEDURE LagrangeCoeff_Line2_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line3 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Line3_(order=order, i=i, v=v, ipiv=ipiv, ans=ans, & + tsize=tsize) +END PROCEDURE LagrangeCoeff_Line3 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line3_ +INTEGER(I4B) :: info +tsize = 1 + order +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Line3_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line4 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Line4_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE LagrangeCoeff_Line4 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line4_ +CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, & + ans=ans, nrow=nrow, ncol=ncol) +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Line4_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line5 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Line5_( & + order=order, xij=xij, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeCoeff_Line5 + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Line5_ +IF (basisType .EQ. polyopt%Monomial) THEN + CALL LagrangeCoeff_Line_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) + RETURN +END IF + +CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) + +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Line5_ + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line1 +INTEGER(I4B) :: tsize +CALL LagrangeEvalAll_Line1_( & + order=order, x=x, xij=xij, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + tsize=tsize) +END PROCEDURE LagrangeEvalAll_Line1 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line1_()" +LOGICAL(LGT) :: isok +#endif + +LOGICAL(LGT) :: firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), x1(1) +INTEGER(I4B) :: ii, orthopol0, nrow, ncol + +tsize = SIZE(xij, 2) + +#ifdef DEBUG_VER +isok = tsize .EQ. order + 1 +CALL AssertError1(isok, myName, modName, __LINE__, & + 'Size(xij, 1)='//ToString(tsize)//' .NE. order+1 = '//ToString(order + 1)) +#endif + +orthopol0 = Input(default=polyopt%Monomial, option=basisType) +firstCall0 = Input(default=.TRUE., option=firstCall) + +! make coeff0 + +IF (PRESENT(coeff)) THEN + IF (firstCall0) THEN + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff, nrow=nrow, ncol=ncol) + END IF + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + +ELSE + CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=coeff0, nrow=nrow, ncol=ncol) +END IF + +IF (orthopol0 .EQ. polyopt%monomial) THEN + + xx(1, 1) = 1.0_DFP + DO ii = 1, order + xx(1, ii + 1) = xx(1, ii) * x + END DO + +ELSE + + x1(1) = x + CALL EvalAllOrthopol_(n=order, x=x1, orthopol=orthopol0, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=xx, nrow=nrow, ncol=ncol) + +END IF + +DO CONCURRENT(ii=1:tsize) + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO +END PROCEDURE LagrangeEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line2 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Line2_(order=order, x=x, xij=xij, coeff=coeff, & + firstCall=firstCall, basisType=basisType, & + alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeEvalAll_Line2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line2_ +LOGICAL(LGT) :: isok, firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) + +firstCall0 = Input(default=.TRUE., option=firstCall) +isok = PRESENT(coeff) + +IF (isok) THEN + + CALL LagrangeEvalAll_Line_( & + order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff, & + xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) + +ELSE + + CALL LagrangeEvalAll_Line_( & + order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff0, & + xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) + +END IF +END PROCEDURE LagrangeEvalAll_Line2_ + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Line_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Line3_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line3_()" +LOGICAL(LGT) :: isok +#endif + +INTEGER(I4B) :: orthopol0, xx_i, xx_j, coeff_i, coeff_j + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) + +#ifdef DEBUG_VER +isok = ncol .EQ. order + 1 +CALL AssertError1(isok, myName, modName, __LINE__, & + 'Size(xij, 2)='//ToString(ncol)//' .NE. order+1 = '//ToString(order + 1)) +#endif + +orthopol0 = Input(default=polyopt%Monomial, option=basisType) + +IF (firstCall) THEN + CALL LagrangeCoeff_Line_( & + order=order, xij=xij, basisType=orthopol0, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff, nrow=coeff_i, ncol=coeff_j) +END IF + +CALL EvalAllOrthopol_( & + n=order, x=x(1, 1:nrow), orthopol=orthopol0, alpha=alpha, beta=beta, & + lambda=lambda, ans=xx, nrow=xx_i, ncol=xx_j) + +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx(1:nrow, 1:ncol), & + B=coeff(1:ncol, 1:ncol)) + +END PROCEDURE LagrangeEvalAll_Line3_ + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Line1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Line_( & + order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) +END PROCEDURE LagrangeGradientEvalAll_Line1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Line1_ +LOGICAL(LGT) :: firstCall0, iscoeff +REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1) +INTEGER(I4B) :: basisType0 + +firstCall0 = Input(default=.TRUE., option=firstCall) +basisType0 = Input(default=polyopt%Monomial, option=basisType) +iscoeff = PRESENT(coeff) + +IF (iscoeff) THEN + CALL LagrangeGradientEvalAll_Line_( & + order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + coeff=coeff, xx=xx, firstCall=firstCall0, basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda) + +ELSE + + CALL LagrangeGradientEvalAll_Line_( & + order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + coeff=coeff0, xx=xx, firstCall=firstCall0, basisType=basisType0, & + alpha=alpha, beta=beta, lambda=lambda) + +END IF + +END PROCEDURE LagrangeGradientEvalAll_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Line2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "LagrangeGradientEvalAll_Line2_()" +#endif + +! coeff0(order + 1, order + 1) +! xx(SIZE(x, 2), order + 1) + +INTEGER(I4B) :: indx(2) + +dim1 = SIZE(x, 2) !! nips +dim2 = SIZE(xij, 2) !! tdof +dim3 = 1 + +indx(1) = dim2 +indx(2) = dim2 + +IF (firstCall) THEN + CALL LagrangeCoeff_Line_( & + order=order, xij=xij, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff, nrow=indx(1), ncol=indx(2)) +END IF + +CALL GradientEvalAllOrthopol_( & + n=order, x=x(1, 1:dim1), orthopol=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=xx, nrow=dim1, ncol=dim2) + +CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx(1:dim1, 1:dim2), & + B=coeff(1:indx(1), 1:indx(2))) +END PROCEDURE LagrangeGradientEvalAll_Line2_ + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/STForceVector/src/STFV_15.inc b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 similarity index 51% rename from src/submodules/STForceVector/src/STFV_15.inc rename to src/submodules/Line/src/LineInterpolationUtility@Methods.F90 index a38e8e233..b022b17ea 100644 --- a/src/submodules/STForceVector/src/STFV_15.inc +++ b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90 @@ -15,39 +15,16 @@ ! along with this program. If not, see ! +SUBMODULE(LineInterpolationUtility) Methods +IMPLICIT NONE +CONTAINS + !---------------------------------------------------------------------------- -! STForceVector +! RefElemDomain_Line !---------------------------------------------------------------------------- -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 +MODULE PROCEDURE RefElemDomain_Line +ans = "BIUNIT" +END PROCEDURE RefElemDomain_Line + +END SUBMODULE Methods diff --git a/src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90 new file mode 100644 index 000000000..dd49aa037 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90 @@ -0,0 +1,156 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) OrthogonalMethods +USE BaseType, ONLY: polyopt => TypePolynomialOpt +USE StringUtility, ONLY: UpperCase +USE MappingUtility, ONLY: FromUnitLine2BiUnitLine_ +USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, & + EvalAllOrthopol_ +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "LineInterpolationUtility@OrthogonalMethods.F90" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Line1 +INTEGER(I4B) :: nrow, ncol +CALL OrthogonalBasis_Line1_(order=order, xij=xij, refline=refline, & + basisType=basisType, ans=ans, nrow=nrow, & + ncol=ncol, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE OrthogonalBasis_Line1 + +!---------------------------------------------------------------------------- +! OrthogonalBasis_Line1_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasis_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "OrthogonalBasis_Line1_()" +LOGICAL(LGT) :: isok, abool +#endif + +CHARACTER(1) :: astr +REAL(DFP) :: x(SIZE(xij, 2)) + +nrow = SIZE(xij, 2) +ncol = order + 1 +ans(1:nrow, 1:ncol) = 0.0_DFP + +#ifdef DEBUG_VER +abool = basisType .EQ. polyopt%Jacobi +IF (abool) THEN + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for basisType=Jacobi") +END IF + +abool = basisType .EQ. polyopt%Ultraspherical +IF (abool) THEN + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for basisType=Ultraspherical") +END IF +#endif + +astr = UpperCase(refLine(1:1)) + +SELECT CASE (astr) +CASE ("U") + CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=nrow) + CALL EvalAllOrthopol_(n=order, x=x, orthopol=basisType, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, & + ncol=ncol) + +CASE ("B") + CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, & + alpha=alpha, beta=beta, lambda=lambda, ans=ans, & + nrow=nrow, ncol=ncol) + +#ifdef DEBUG_VER +CASE DEFAULT + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "No case found for refLine.") +#endif +END SELECT +END PROCEDURE OrthogonalBasis_Line1_ + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Line1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Line1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL OrthogonalBasisGradient_Line1_( & + order=order, xij=xij, refline=refline, basisType=basisType, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, alpha=alpha, beta=beta, lambda=lambda) +END PROCEDURE OrthogonalBasisGradient_Line1 + +!---------------------------------------------------------------------------- +! OrthogonalBasisGradient_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OrthogonalBasisGradient_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "OrthogonalBasisGradient_Line1_()" +#endif + +CHARACTER(1) :: astr +REAL(DFP) :: x(SIZE(xij, 2)) +INTEGER(I4B) :: ii, jj + +astr = UpperCase(refline(1:1)) +dim1 = SIZE(xij, 2) +dim2 = order + 1 +dim3 = 1 + +SELECT CASE (astr) +CASE ("U") + CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=dim1) + CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType, & + ans=ans(:, :, 1), nrow=dim1, ncol=dim2) + + DO CONCURRENT(ii=1:dim1, jj=1:dim2) + ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP + END DO + +CASE ("B") + CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, & + ans=ans(:, :, 1), nrow=dim1, ncol=dim2) + +#ifdef DEBUG_VER +CASE DEFAULT + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "No case found for refline") +#endif +END SELECT +END PROCEDURE OrthogonalBasisGradient_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE OrthogonalMethods diff --git a/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 new file mode 100644 index 000000000..21c8daaf6 --- /dev/null +++ b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 @@ -0,0 +1,284 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(LineInterpolationUtility) QuadratureMethods +USE BaseType, ONLY: ipopt => TypeInterpolationOpt, & + qpopt => TypeQuadratureOpt +USE MappingUtility, ONLY: FromBiunitLine2Segment_ +USE LegendrePolynomialUtility, ONLY: LegendreQuadrature +USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature +USE JacobiPolynomialUtility, ONLY: JacobiQuadrature +USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature + +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "LineInterpolationUtility@QuadratureMethods.F90" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! QuadratureNumber_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Line +SELECT CASE (quadType) +CASE (qpopt%GaussLegendre, qpopt%GaussChebyshev, & + qpopt%GaussJacobi, qpopt%GaussUltraspherical) + ans = 1_I4B + INT(order / 2, kind=I4B) +CASE (qpopt%GaussLegendreRadauRight, qpopt%GaussLegendreRadauLeft, & + qpopt%GaussChebyshevRadauLeft, qpopt%GaussChebyshevRadauRight, & + qpopt%GaussJacobiRadauLeft, qpopt%GaussJacobiRadauRight, & + qpopt%GaussUltraSphericalRadauLeft, qpopt%GaussUltraSphericalRadauRight) + ans = 2_I4B + INT((order - 1) / 2, kind=I4B) +CASE DEFAULT + ans = 2_I4B + INT(order / 2, kind=I4B) +END SELECT +END PROCEDURE QuadratureNumber_Line + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line1 +INTEGER(I4B) :: nips(1), nrow, ncol +LOGICAL(LGT) :: isok + +nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) + +isok = PRESENT(xij) +nrow = 1 +IF (isok) nrow = SIZE(xij, 1) + +nrow = nrow + 1 +ncol = nips(1) + +ALLOCATE (ans(nrow, ncol)) + +CALL QuadraturePoint_Line1_( & + nips=nips, quadType=quadType, layout=layout, xij=xij, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Line1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line2 +INTEGER(I4B) :: nips(1), nrow, ncol +REAL(DFP) :: x12(1, 2) + +nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) +nrow = 2 +ncol = nips(1) + +ALLOCATE (ans(nrow, ncol)) + +x12(1, 1:2) = xij(1:2) + +CALL QuadraturePoint_Line1_( & + nips=nips, quadType=quadType, layout=layout, xij=x12, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Line2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line3 +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +nrow = 1 +isok = PRESENT(xij) +IF (isok) nrow = SIZE(xij, 1) + +nrow = nrow + 1 +ncol = nips(1) + +ALLOCATE (ans(nrow, ncol)) + +CALL QuadraturePoint_Line1_( & + nips=nips, quadType=quadType, layout=layout, xij=xij, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Line3 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line4 +REAL(DFP) :: x12(1, 2) +INTEGER(I4B) :: nrow, ncol + +nrow = 2 +ncol = nips(1) + +ALLOCATE (ans(nrow, ncol)) + +x12(1, 1:2) = xij(1:2) + +CALL QuadraturePoint_Line1_( & + nips=nips, quadType=quadType, layout=layout, xij=x12, alpha=alpha, & + beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE QuadraturePoint_Line4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Line1_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "QuadraturePoint_Line1_()" +#endif + +INTEGER(I4B) :: np, nsd, ii, jj +REAL(DFP) :: areal +LOGICAL(LGT) :: changeLayout, isok + +nrow = 0 +ncol = 0 + +#ifdef DEBUG_VER +SELECT CASE (quadType) +CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto, & + ipopt%GaussJacobiRadauLeft, ipopt%GaussJacobiRadauRight) + + isok = PRESENT(alpha) .AND. PRESENT(beta) + CALL AssertError1(isok, myName, modName, __LINE__, & + "alpha and beta should be present for quadType=ipopt%GaussJacobi") + +CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto, & + ipopt%GaussUltraSphericalRadauLeft, ipopt%GaussUltraSphericalRadauRight) + + isok = PRESENT(lambda) + CALL AssertError1(isok, myName, modName, __LINE__, & + "lambda should be present for quadType=ipopt%GaussUltraspherical") +END SELECT +#endif + +nsd = 1 +isok = PRESENT(xij) +IF (isok) nsd = SIZE(xij, 1) + +np = nips(1) +nrow = nsd + 1 +ncol = nips(1) + +isok = layout(1:1) .EQ. "V" +changeLayout = .FALSE. +IF (isok) changeLayout = .TRUE. + +SELECT CASE (quadType) + +CASE (ipopt%GaussLegendre) + CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%Gauss) + +CASE (ipopt%GaussLegendreRadauLeft) + CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauLeft) + +CASE (ipopt%GaussLegendreRadauRight) + CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauRight) + +CASE (ipopt%GaussLegendreLobatto) + CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussLobatto) + +CASE (ipopt%GaussChebyshev) + CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%Gauss) + +CASE (ipopt%GaussChebyshevRadauLeft) + CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauLeft) + +CASE (ipopt%GaussChebyshevRadauRight) + CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauRight) + +CASE (ipopt%GaussChebyshevLobatto) + CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussLobatto) + +CASE (ipopt%GaussJacobi) + CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%Gauss, alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiRadauLeft) + CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauLeft, alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiRadauRight) + CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauRight, alpha=alpha, beta=beta) + +CASE (ipopt%GaussJacobiLobatto) + CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussLobatto, alpha=alpha, beta=beta) + +CASE (ipopt%GaussUltraspherical) +CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%Gauss, lambda=lambda) + +CASE (ipopt%GaussUltrasphericalRadauLeft) +CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauLeft, lambda=lambda) + +CASE (ipopt%GaussUltrasphericalRadauRight) +CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussRadauRight, lambda=lambda) + +CASE (ipopt%GaussUltrasphericalLobatto) +CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & + quadType=ipopt%GaussLobatto, lambda=lambda) + +#ifdef DEBUG_VER +CASE DEFAULT + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "Unknown iptype") +#endif +END SELECT + +IF (changeLayout) THEN + CALL ToVEFC_Line(ans(1, 1:ncol)) + CALL ToVEFC_Line(ans(nrow, 1:ncol)) +END IF + +IF (PRESENT(xij)) THEN + CALL FromBiunitLine2Segment_(xin=ans(1, 1:ncol), x1=xij(:, 1), & + x2=xij(:, 2), ans=ans, nrow=ii, ncol=jj) + + areal = NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO +END IF +END PROCEDURE QuadraturePoint_Line1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE QuadratureMethods diff --git a/src/submodules/Line/src/Line_Method@Methods.F90 b/src/submodules/Line/src/Line_Method@Methods.F90 new file mode 100644 index 000000000..3775f5f17 --- /dev/null +++ b/src/submodules/Line/src/Line_Method@Methods.F90 @@ -0,0 +1,556 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(Line_Method) Methods +USE BaseMethod +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_exp_is_degenerate_nd +ans = (ALL(p1(1:dim_num) == p2(1:dim_num))) +END PROCEDURE line_exp_is_degenerate_nd + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_exp2imp_2d +INTEGER(i4b), PARAMETER :: dim_num = 2 +REAL(dfp) norm +! +! Take care of degenerate cases. +! +IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) THEN + RETURN +END IF + +a = p2(2) - p1(2) +b = p1(1) - p2(1) +c = p2(1) * p1(2) - p1(1) * p2(2) + +norm = a * a + b * b + c * c + +IF (0.0D+00 < norm) THEN + a = a / norm + b = b / norm + c = c / norm +END IF + +IF (a < 0.0D+00) THEN + a = -a + b = -b + c = -c +END IF + +END PROCEDURE line_exp2imp_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_imp_is_degenerate_2d +ans = (a * a + b * b == 0.0D+00) +END PROCEDURE line_imp_is_degenerate_2d + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE lines_imp_int_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) a(dim_num, dim_num + 1) +INTEGER(kind=4) info +! +p(1:dim_num) = 0.0D+00 +! +! Refuse to handle degenerate lines. +! +IF (line_imp_is_degenerate_2d(a1, b1, c1)) THEN + ival = -1 + RETURN +END IF +! +IF (line_imp_is_degenerate_2d(a2, b2, c2)) THEN + ival = -2 + RETURN +END IF +! +! Set up and solve a linear system. +! +a(1, 1) = a1 +a(1, 2) = b1 +a(1, 3) = -c1 +a(2, 1) = a2 +a(2, 2) = b2 +a(2, 3) = -c2 +! +CALL r8mat_solve(2, 1, a, info) +! +! If the inverse exists, then the lines intersect at the solution point. +! +IF (info == 0) THEN + + ival = 1 + p(1:dim_num) = a(1:dim_num, 3) +! +! If the inverse does not exist, then the lines are parallel +! or coincident. Check for parallelism by seeing if the +! C entries are in the same ratio as the A or B entries. +! +ELSE + ival = 0 + IF (a1 == 0.0D+00) THEN + IF (b2 * c1 == c2 * b1) THEN + ival = 2 + END IF + ELSE + IF (a2 * c1 == c2 * a1) THEN + ival = 2 + END IF + END IF +END IF +! +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_exp_perp_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) bot +REAL(kind=8) t +! +flag = .FALSE. +IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) THEN + flag = .TRUE. + p4(1:2) = r8_huge() + RETURN +END IF +! +bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2) +! +! (P3-P1) dot (P2-P1) = Norm(P3-P1) * Norm(P2-P1) * Cos(Theta). +! +! (P3-P1) dot (P2-P1) / Norm(P3-P1)^2 = normalized coordinate T +! of the projection of (P3-P1) onto (P2-P1). +! +t = SUM((p1(1:dim_num) - p3(1:dim_num)) & + * (p1(1:dim_num) - p2(1:dim_num))) / bot +! +p4(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +! +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE lines_exp_int_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) a1 +REAL(kind=8) a2 +REAL(kind=8) b1 +REAL(kind=8) b2 +REAL(kind=8) c1 +REAL(kind=8) c2 +LOGICAL(kind=4) point_1 +LOGICAL(kind=4) point_2 +! +ival = 0 +p(1:dim_num) = 0.0D+00 +! +! Check whether either line is a point. +! +IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN + point_1 = .TRUE. +ELSE + point_1 = .FALSE. +END IF + +IF (ALL(q1(1:dim_num) == q2(1:dim_num))) THEN + point_2 = .TRUE. +ELSE + point_2 = .FALSE. +END IF +! +! Convert the lines to ABC format. +! +IF (.NOT. point_1) THEN + CALL line_exp2imp_2d(p1, p2, a1, b1, c1) +END IF + +IF (.NOT. point_2) THEN + CALL line_exp2imp_2d(q1, q2, a2, b2, c2) +END IF +! +! Search for intersection of the lines. +! +IF (point_1 .AND. point_2) THEN + IF (ALL(p1(1:dim_num) == q1(1:dim_num))) THEN + ival = 1 + p(1:dim_num) = p1(1:dim_num) + END IF +ELSE IF (point_1) THEN + IF (a2 * p1(1) + b2 * p1(2) == c2) THEN + ival = 1 + p(1:dim_num) = p1(1:dim_num) + END IF +ELSE IF (point_2) THEN + IF (a1 * q1(1) + b1 * q1(2) == c1) THEN + ival = 1 + p(1:dim_num) = q1(1:dim_num) + END IF +ELSE + CALL lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p) +END IF +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE segment_point_dist_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) bot +REAL(kind=8) pn(dim_num) +REAL(kind=8) t +! +! If the line segment is actually a point, then the answer is easy. +! +IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN + t = 0.0D+00 +ELSE + bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2) + t = SUM((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / bot + t = MAX(t, 0.0D+00) + t = MIN(t, 1.0D+00) +END IF +! +pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +dist = SQRT(SUM((p(1:dim_num) - pn(1:dim_num))**2)) +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE segment_point_dist_3d +INTEGER(i4b), PARAMETER :: dim_num = 3 +REAL(dfp) bot +REAL(dfp) pn(dim_num) +REAL(dfp) t +! +! If the line segment is actually a point, then the answer is easy. +! +IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN + t = 0.0D+00 +ELSE + bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2) + t = SUM((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / bot + t = MAX(t, 0.0D+00) + t = MIN(t, 1.0D+00) +END IF + +pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +dist = SQRT(SUM((p(1:dim_num) - pn(1:dim_num))**2)) +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE line_exp_point_dist_signed_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) a +REAL(kind=8) b +REAL(kind=8) c +! +! If the explicit line degenerates to a point, the computation is easy. +! +IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) THEN + dist_signed = SQRT(SUM((p1(1:dim_num) - p(1:dim_num))**2)) +! +! Convert the explicit line to the implicit form A * P(1) + B * P(2) + C = 0. +! This makes the computation of the signed distance to (X,Y) easy. +! +ELSE + a = p2(2) - p1(2) + b = p1(1) - p2(1) + c = p2(1) * p1(2) - p1(1) * p2(2) + dist_signed = (a * p(1) + b * p(2) + c) / SQRT(a * a + b * b) +END IF +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE segment_point_near_2d +INTEGER(kind=4), PARAMETER :: dim_num = 2 +REAL(kind=8) bot +! +! If the line segment is actually a point, then the answer is easy. +! +IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN + t = 0.0D+00 +ELSE + bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2) + t = SUM((p(1:dim_num) - p1(1:dim_num)) & + * (p2(1:dim_num) - p1(1:dim_num))) / bot + t = MAX(t, 0.0D+00) + t = MIN(t, 1.0D+00) +END IF +! +pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num)) +dist = SQRT(SUM((p(1:dim_num) - pn(1:dim_num))**2)) +END PROCEDURE + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: r8mat solve +! +!# Introduction +! +! Input, integer ( kind = 4 ) N, the order of the matrix. +! +! Input, integer ( kind = 4 ) RHS_NUM, the number of right hand sides. +! RHS_NUM must be at least 0. +! +! Input/output, real ( kind = 8 ) A(N,N+rhs_num), contains in rows and +! columns 1 to N the coefficient matrix, and in columns N+1 through +! N+rhs_num, the right hand sides. On output, the coefficient matrix +! area has been destroyed, while the right hand sides have +! been overwritten with the corresponding solutions. +! +! Output, integer ( kind = 4 ) INFO, singularity flag. +! 0, the matrix was not singular, the solutions were computed; +! J, factorization failed on step J, and the solutions could not +! be computed. + +PURE SUBROUTINE r8mat_solve(n, rhs_num, a, info) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: rhs_num + REAL(DFP), INTENT(INOUT) :: a(n, n + rhs_num) + INTEGER(I4B), INTENT(OUT) :: info + !! + REAL(DFP) :: apivot + REAL(DFP) :: factor + INTEGER(I4B) :: i + INTEGER(I4B) :: ipivot + INTEGER(I4B) :: j + !! + info = 0 + !! + DO j = 1, n + ! + ! Choose a pivot row. + ! + ipivot = j + apivot = a(j, j) + ! + DO i = j + 1, n + IF (ABS(apivot) < ABS(a(i, j))) THEN + apivot = a(i, j) + ipivot = i + END IF + END DO + ! + IF (apivot == 0.0D+00) THEN + info = j + RETURN + END IF + ! + ! Interchange. + ! + DO i = 1, n + rhs_num + CALL swap(a(ipivot, i), a(j, i)) + END DO + ! + ! A(J,J) becomes 1. + ! + a(j, j) = 1.0D+00 + a(j, j + 1:n + rhs_num) = a(j, j + 1:n + rhs_num) / apivot + ! + ! A(I,J) becomes 0. + ! + DO i = 1, n + IF (i /= j) THEN + factor = a(i, j) + a(i, j) = 0.0D+00 + a(i,j+1:n+rhs_num) = a(i,j+1:n+rhs_num) - factor * a(j,j+1:n+rhs_num) + END IF + END DO + END DO +END SUBROUTINE r8mat_solve + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION r8vec_normsq_affine(n, v0, v1) RESULT(ans) + INTEGER(i4b), INTENT(in) :: n + REAL(dfp), INTENT(in) :: v0(n) + REAL(dfp), INTENT(in) :: v1(n) + REAL(dfp) :: ans + ans = SUM((v0(1:n) - v1(1:n))**2) +END FUNCTION r8vec_normsq_affine + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_wrap(ival, ilo, ihi) RESULT(ans) + INTEGER(i4b), INTENT(in) :: ival + INTEGER(i4b), INTENT(in) :: ilo + INTEGER(i4b), INTENT(in) :: ihi + INTEGER(i4b) :: ans + !! + INTEGER(i4b) :: jhi + INTEGER(i4b) :: jlo + INTEGER(i4b) :: wide + !! + jlo = MIN(ilo, ihi) + jhi = MAX(ilo, ihi) + !! + wide = jhi - jlo + 1 + !! + IF (wide == 1) THEN + ans = jlo + ELSE + ans = jlo + i4_modp(ival - jlo, wide) + END IF + !! +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_modp(i, j) RESULT(ans) + INTEGER(i4b), INTENT(IN) :: i + INTEGER(i4b), INTENT(IN) :: j + INTEGER(i4b) :: ans + IF (j == 0) THEN + RETURN + END IF + ans = MOD(i, j) + IF (ans < 0) THEN + ans = ans + ABS(j) + END IF +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4vec_lcm(n, v) + INTEGER(i4b), INTENT(in) :: n + INTEGER(i4b), INTENT(in) :: v(n) + INTEGER(i4b) :: i4vec_lcm + INTEGER(i4b) :: i + INTEGER(i4b) :: lcm + ! + lcm = 1 + DO i = 1, n + IF (v(i) == 0) THEN + lcm = 0 + i4vec_lcm = lcm + RETURN + END IF + lcm = i4_lcm(lcm, v(i)) + END DO + i4vec_lcm = lcm +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_lcm(i, j) + INTEGER(i4b), INTENT(in) :: i, j + INTEGER(I4B) :: i4_lcm + i4_lcm = ABS(i * (j / i4_gcd(i, j))) +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_gcd(i, j) + INTEGER(I4B), INTENT(IN) :: i, j + INTEGER(I4B) :: i4_gcd + !! + INTEGER(kind=4) p + INTEGER(kind=4) q + INTEGER(kind=4) r + ! + i4_gcd = 1 + ! + ! Return immediately if either I or J is zero. + ! + IF (i == 0) THEN + i4_gcd = MAX(1, ABS(j)) + RETURN + ELSE IF (j == 0) THEN + i4_gcd = MAX(1, ABS(i)) + RETURN + END IF + ! + ! Set P to the larger of I and J, Q to the smaller. + ! This way, we can alter P and Q as we go. + ! + p = MAX(ABS(i), ABS(j)) + q = MIN(ABS(i), ABS(j)) + ! + ! Carry out the Euclidean algorithm. + ! + DO + r = MOD(p, q) + IF (r == 0) THEN + EXIT + END IF + p = q + q = r + END DO + i4_gcd = q +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION r8_huge() + REAL(dfp) :: r8_huge + r8_huge = 1.0D+30 +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Line/src/ReferenceLine_Method@Methods.F90 similarity index 96% rename from src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 rename to src/submodules/Line/src/ReferenceLine_Method@Methods.F90 index b6805ae2e..cb10e1d96 100644 --- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 +++ b/src/submodules/Line/src/ReferenceLine_Method@Methods.F90 @@ -372,12 +372,21 @@ ! GetFaceElemType_Line !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Line +MODULE PROCEDURE GetFaceElemType_Line1 INTEGER(I4B) :: elemType0 elemType0 = Input(default=Line, option=elemType) IF (PRESENT(faceElemType)) faceElemType(1:2) = Point1 IF (PRESENT(tFaceNodes)) tFaceNodes(1:2) = 1_I4B -END PROCEDURE GetFaceElemType_Line +END PROCEDURE GetFaceElemType_Line1 + +!---------------------------------------------------------------------------- +! GetFaceElemType_Line +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Line2 +faceElemType = Point1 +tFaceNodes = 1_I4B +END PROCEDURE GetFaceElemType_Line2 !---------------------------------------------------------------------------- ! GetFaceConnectivity_Triangle diff --git a/src/submodules/MassMatrix/src/MM_1.inc b/src/submodules/MassMatrix/src/MM_1.inc deleted file mode 100644 index aee971caa..000000000 --- a/src/submodules/MassMatrix/src/MM_1.inc +++ /dev/null @@ -1,52 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_1(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! scalar variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! ncopy - !! - !! Internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - INTEGER(I4B) :: ips - !! - !! main - !! - CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1)) - CALL getInterpolation(obj=trial, interpol=realval, val=rho) - realval = trial%js * trial%ws * trial%thickness * realval - !! - DO ips = 1, size(realval) - ans = ans + realval(ips) * & - & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - END DO - !! - if( present( opt ) ) CALL MakeDiagonalCopies(ans, opt) - !! - DEALLOCATE (realval) -END SUBROUTINE MM_1 diff --git a/src/submodules/MassMatrix/src/MM_2a.inc b/src/submodules/MassMatrix/src/MM_2a.inc deleted file mode 100644 index 0c31616c7..000000000 --- a/src/submodules/MassMatrix/src/MM_2a.inc +++ /dev/null @@ -1,58 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2a(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 1 - !! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, ips - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, 1) = m4(:, :, ii, 1) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - !! - CALL Convert(From=m4, To=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2a diff --git a/src/submodules/MassMatrix/src/MM_2b.inc b/src/submodules/MassMatrix/src/MM_2b.inc deleted file mode 100644 index 3cbcb268e..000000000 --- a/src/submodules/MassMatrix/src/MM_2b.inc +++ /dev/null @@ -1,61 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2b(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 2 - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, ips - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, 1, ii) = m4(:, :, 1, ii) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - !! - CALL Convert(From=m4, To=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2b diff --git a/src/submodules/MassMatrix/src/MM_2c.inc b/src/submodules/MassMatrix/src/MM_2c.inc deleted file mode 100644 index edc9450fa..000000000 --- a/src/submodules/MassMatrix/src/MM_2c.inc +++ /dev/null @@ -1,59 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2c(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - INTEGER( I4B ), INTENT( IN ) :: opt - !! 3 - !! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ips, ii - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(vbar, 1), SIZE(vbar, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(vbar, 2) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, ii) = m4(:, :, ii, ii) & - & + realval(ips) * vbar(ii, ips) * m2 - END DO - END DO - !! - CALL Convert(from=m4, to=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2c diff --git a/src/submodules/MassMatrix/src/MM_2d.inc b/src/submodules/MassMatrix/src/MM_2d.inc deleted file mode 100644 index 00474ec01..000000000 --- a/src/submodules/MassMatrix/src/MM_2d.inc +++ /dev/null @@ -1,61 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_2d(ans, test, trial, rho) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! vector variable - !! Define internal variable - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: vbar(:, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ips, ii, jj - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) - !! - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(vbar, 1), SIZE(vbar, 1)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(vbar, 2) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(vbar, 1) - DO ii = 1, SIZE(vbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * vbar(ii, ips) & - & * vbar(jj, ips) * m2 - END DO - END DO - END DO - !! - CALL Convert(from=m4, to=ans) - !! - DEALLOCATE (realval, m2, vbar, m4) - !! -END SUBROUTINE MM_2d diff --git a/src/submodules/MassMatrix/src/MM_3.inc b/src/submodules/MassMatrix/src/MM_3.inc deleted file mode 100644 index b72f07d7f..000000000 --- a/src/submodules/MassMatrix/src/MM_3.inc +++ /dev/null @@ -1,62 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! MassMatrix -!---------------------------------------------------------------------------- - -PURE SUBROUTINE MM_3(ans, test, trial, rho, opt) - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(ElemshapeData_), INTENT(IN) :: test - !! Shapedata for test function - CLASS(ElemshapeData_), INTENT(IN) :: trial - !! Shapedata for trial function - CLASS(FEVariable_), INTENT(IN) :: rho - !! matrix variable - INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt - !! 4 - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: m2(:, :) - REAL(DFP), ALLOCATABLE :: kbar(:, :, :) - REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) - INTEGER(I4B) :: ii, jj, ips - !! - !! main - !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) - CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & - & SIZE(kbar, 1), SIZE(kbar, 2)) - !! - realval = trial%js * trial%ws * trial%thickness - !! - DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(kbar, 2) - DO ii = 1, SIZE(kbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * kbar(ii, jj, ips) * m2 - END DO - END DO - END DO - !! - CALL Convert(From=m4, To=ans) - !! - DEALLOCATE (realval, m2, kbar, m4) -END SUBROUTINE MM_3 diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 index 009ca1ada..cd9e3fe51 100644 --- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 +++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 @@ -16,7 +16,23 @@ ! SUBMODULE(MassMatrix_Method) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate +USE ElemshapeData_Method, ONLY: GetInterpolation +USE ElemshapeData_Method, ONLY: GetInterpolation_ +USE ProductUtility, ONLY: OuterProd_ +USE ProductUtility, ONLY: OuterProd +USE ProductUtility, ONLY: OTimesTilda_ +USE ConvertUtility, ONLY: Convert +USE ConvertUtility, ONLY: Convert_ +USE RealMatrix_Method, ONLY: MakeDiagonalCopies +USE RealMatrix_Method, ONLY: MakeDiagonalCopies_ +USE EyeUtility, ONLY: Eye +USE BaseType, ONLY: math => TypeMathOpt +USE BaseType, ONLY: varopt => TypeFEVariableOpt +USE InputUtility, ONLY: Input +USE FEVariable_Method, ONLY: FEVariableSize => Size +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ + IMPLICIT NONE CONTAINS @@ -24,228 +40,60 @@ ! 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) +INTEGER(I4B) :: nrow, ncol, opt0 + +opt0 = Input(option=opt, default=math%one_i) +nrow = test%nns * opt0 +ncol = trial%nns * opt0 +CALL Reallocate(ans, nrow, ncol) +CALL MassMatrix_(test=test, trial=trial, ans=ans, nrow=nrow, ncol=ncol, & + opt=opt0) END PROCEDURE MassMatrix_1 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE Massmatrix1_ -REAL(DFP), PARAMETER :: one = 1.0_DFP +MODULE PROCEDURE MassMatrix1_ REAL(DFP) :: realval -INTEGER(I4B) :: ii, jj, ips +INTEGER(I4B) :: ii, jj, ips, opt0 +LOGICAL(LGT) :: isok nrow = test%nns ncol = trial%nns -ans(1:nrow, 1:ncol) = 0.0 +opt0 = Input(default=math%one_i, option=opt) +ans(1:nrow * opt0, 1:ncol * opt0) = 0.0 DO ips = 1, trial%nips realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) - CALL OuterProd_(a=test%N(1:nrow, ips), & - b=trial%N(1:ncol, ips), & - nrow=ii, ncol=jj, ans=ans, scale=realval, anscoeff=one) - + CALL OuterProd_( & + a=test%N(1:nrow, ips), b=trial%N(1:ncol, ips), nrow=ii, ncol=jj, & + ans=ans, scale=realval, anscoeff=math%one) END DO -IF (PRESENT(opt)) THEN - CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) - nrow = opt * nrow - ncol = opt * ncol +isok = opt0 .GT. 1 +IF (isok) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt0, nrow=nrow, ncol=ncol) + nrow = opt0 * nrow + ncol = opt0 * ncol END IF - -END PROCEDURE Massmatrix1_ +END PROCEDURE MassMatrix1_ !---------------------------------------------------------------------------- ! 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) +INTEGER(I4B) :: nrow, ncol, opt0 + +opt0 = Input(option=opt, default=math%one_i) +nrow = test%nns * opt0 +ncol = trial%nns * opt0 +CALL Reallocate(ans, nrow, ncol) +CALL MassMatrix_(test=test, trial=trial, ans=ans, nrow=nrow, ncol=ncol, & + opt=opt0, rho=rho, rhorank=rhorank) END PROCEDURE MassMatrix_2 !---------------------------------------------------------------------------- @@ -253,30 +101,35 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix2_ -REAL(DFP) :: realval(trial%nips) -REAL(DFP), PARAMETER :: one = 1.0_DFP -INTEGER(I4B) :: ips, ii, jj +INTEGER(I4B) :: ips, i1, i2, opt0 +REAL(DFP) :: realval, rhobar, T(0) +LOGICAL(LGT) :: isok +opt0 = Input(default=math%one_i, option=opt) nrow = test%nns ncol = trial%nns -realval = 0.0_DFP -CALL GetInterpolation_(obj=trial, interpol=realval, & - val=rho, tsize=ii) -realval = trial%js * trial%ws * trial%thickness * realval +ans(1:nrow * opt0, 1:ncol * opt0) = math%zero -DO ips = 1, 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) +DO ips = 1, test%nips + + CALL FEVariableGetInterpolation_( & + obj=rho, rank=rhorank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=rhobar) + + realval = rhobar * trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + + CALL OuterProd_( & + a=test%N(1:nrow, ips), b=trial%N(1:ncol, ips), nrow=i1, ncol=i2, & + ans=ans, scale=realval, anscoeff=math%one) END DO -IF (PRESENT(opt)) THEN - CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol) - nrow = opt * nrow - ncol = opt * ncol +isok = opt0 .GT. 1 +IF (isok) THEN + CALL MakeDiagonalCopies_(mat=ans, ncopy=opt0, nrow=nrow, ncol=ncol) + nrow = opt0 * nrow + ncol = opt0 * ncol END IF - END PROCEDURE MassMatrix2_ !---------------------------------------------------------------------------- @@ -284,56 +137,213 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix_3 -SELECT CASE (opt) -CASE (1) - CALL MM_2a(ans=ans, test=test, trial=trial, rho=rho) -CASE (2) - CALL MM_2b(ans=ans, test=test, trial=trial, rho=rho) -CASE (3) - CALL MM_2c(ans=ans, test=test, trial=trial, rho=rho) -CASE (4) - CALL MM_2d(ans=ans, test=test, trial=trial, rho=rho) -END SELECT +! SELECT CASE (opt) +! CASE (1) +! CALL MM_3a(ans=ans, test=test, trial=trial, rho=rho) +! CASE (2) +! CALL MM_3b(ans=ans, test=test, trial=trial, rho=rho) +! CASE (3) +! CALL MM_3c(ans=ans, test=test, trial=trial, rho=rho) +! CASE (4) +! CALL MM_3d(ans=ans, test=test, trial=trial, rho=rho) +! END SELECT END PROCEDURE MassMatrix_3 !---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix3_ +! SELECT CASE (opt) +! CASE (1) +! CALL MM_3a(ans=ans, test=test, trial=trial, rho=rho) +! CASE (2) +! CALL MM_3b(ans=ans, test=test, trial=trial, rho=rho) +! CASE (3) +! CALL MM_3c(ans=ans, test=test, trial=trial, rho=rho) +! CASE (4) +! CALL MM_3d(ans=ans, test=test, trial=trial, rho=rho) +! END SELECT +END PROCEDURE MassMatrix3_ + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +! PURE SUBROUTINE MM_3a(test, trial, rho, rhorank, ans, nrow, ncol) +! CLASS(ElemshapeData_), INTENT(IN) :: test +! ! Shapedata for test function +! CLASS(ElemshapeData_), INTENT(IN) :: trial +! ! Shapedata for trial function +! CLASS(FEVariable_), INTENT(IN) :: rho +! ! vector variable +! TYPE(FEVariableVector_), INTENT(IN) :: rhorank +! REAL(DFP), INTENT(INOUT) :: ans(:, :) +! INTEGER(I4B), INTENT(OUT) :: nrow, ncol +! +! ! Define internal variable +! REAL(DFP), ALLOCATABLE :: realval(:) +! REAL(DFP), ALLOCATABLE :: m2(:, :) +! REAL(DFP), ALLOCATABLE :: vbar(:, :) +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! INTEGER(I4B) :: ii, ips +! +! ! main +! CALL GetInterpolation(obj=trial, ans=vbar, val=rho) +! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1) +! realval = trial%js * trial%ws * trial%thickness +! +! DO ips = 1, SIZE(realval) +! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) +! DO ii = 1, SIZE(vbar, 1) +! m4(:, :, ii, 1) = m4(:, :, ii, 1) & +! & + realval(ips) * vbar(ii, ips) * m2 +! END DO +! END DO +! +! CALL Convert(From=m4, To=ans) +! DEALLOCATE (realval, m2, vbar, m4) +! END SUBROUTINE MM_3a + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +! PURE SUBROUTINE MM_3b(ans, test, trial, rho) +! REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) +! CLASS(ElemshapeData_), INTENT(IN) :: test +! ! Shapedata for test function +! CLASS(ElemshapeData_), INTENT(IN) :: trial +! ! Shapedata for trial function +! CLASS(FEVariable_), INTENT(IN) :: rho +! ! vector variable +! +! ! Define internal variable +! REAL(DFP), ALLOCATABLE :: realval(:) +! REAL(DFP), ALLOCATABLE :: m2(:, :) +! REAL(DFP), ALLOCATABLE :: vbar(:, :) +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! INTEGER(I4B) :: ii, ips +! +! ! main +! CALL GetInterpolation(obj=trial, ans=vbar, val=rho) +! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1)) +! realval = trial%js * trial%ws * trial%thickness +! +! DO ips = 1, SIZE(realval) +! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) +! DO ii = 1, SIZE(vbar, 1) +! m4(:, :, 1, ii) = m4(:, :, 1, ii) & +! & + realval(ips) * vbar(ii, ips) * m2 +! END DO +! END DO +! +! CALL Convert(From=m4, To=ans) +! DEALLOCATE (realval, m2, vbar, m4) +! END SUBROUTINE MM_3b + +!---------------------------------------------------------------------------- +! MassMatrix +!---------------------------------------------------------------------------- + +! PURE SUBROUTINE MM_3c(ans, test, trial, rho) +! REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) +! CLASS(ElemshapeData_), INTENT(IN) :: test +! ! Shapedata for test function +! CLASS(ElemshapeData_), INTENT(IN) :: trial +! ! Shapedata for trial function +! CLASS(FEVariable_), INTENT(IN) :: rho +! ! vector variable +! ! Define internal variable +! REAL(DFP), ALLOCATABLE :: realval(:) +! REAL(DFP), ALLOCATABLE :: m2(:, :) +! REAL(DFP), ALLOCATABLE :: vbar(:, :) +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! INTEGER(I4B) :: ips, ii ! +! ! main +! CALL GetInterpolation(obj=trial, ans=vbar, val=rho) +! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & +! & SIZE(vbar, 1), SIZE(vbar, 1)) +! +! realval = trial%js * trial%ws * trial%thickness +! +! DO ips = 1, SIZE(vbar, 2) +! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) +! DO ii = 1, SIZE(vbar, 1) +! m4(:, :, ii, ii) = m4(:, :, ii, ii) & +! & + realval(ips) * vbar(ii, ips) * m2 +! END DO +! END DO +! +! CALL Convert(from=m4, to=ans) +! +! DEALLOCATE (realval, m2, vbar, m4) +! END SUBROUTINE MM_3c + +!---------------------------------------------------------------------------- +! MassMatrix !---------------------------------------------------------------------------- -MODULE PROCEDURE massmatrix3_ -! TODO: implement -END PROCEDURE massmatrix3_ +! PURE SUBROUTINE MM_3d(ans, test, trial, rho) +! REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) +! CLASS(ElemshapeData_), INTENT(IN) :: test +! ! Shapedata for test function +! CLASS(ElemshapeData_), INTENT(IN) :: trial +! ! Shapedata for trial function +! CLASS(FEVariable_), INTENT(IN) :: rho +! ! vector variable +! ! Define internal variable +! REAL(DFP), ALLOCATABLE :: realval(:) +! REAL(DFP), ALLOCATABLE :: m2(:, :) +! REAL(DFP), ALLOCATABLE :: vbar(:, :) +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! INTEGER(I4B) :: ips, ii, jj +! +! ! main +! CALL GetInterpolation(obj=trial, ans=vbar, val=rho) +! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), & +! & SIZE(vbar, 1), SIZE(vbar, 1)) +! +! realval = trial%js * trial%ws * trial%thickness +! +! DO ips = 1, SIZE(vbar, 2) +! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) +! DO jj = 1, SIZE(vbar, 1) +! DO ii = 1, SIZE(vbar, 1) +! m4(:, :, ii, jj) = m4(:, :, ii, jj) & +! & + realval(ips) * vbar(ii, ips) & +! & * vbar(jj, ips) * m2 +! END DO +! END DO +! END DO +! +! CALL Convert(from=m4, to=ans) +! +! DEALLOCATE (realval, m2, vbar, m4) +! END SUBROUTINE MM_3d !---------------------------------------------------------------------------- ! MassMatrix !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix_4 -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: m2(:, :) -REAL(DFP), ALLOCATABLE :: kbar(:, :, :) +INTEGER(I4B) :: rhobar_i, rhobar_j, nns1, nns2 REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) -INTEGER(I4B) :: ii, jj, ips -! 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)) +rhobar_i = FEVariableSize(obj=rho, dim=1) +rhobar_j = FEVariableSize(obj=rho, dim=2) +nns1 = test%nns +nns2 = trial%nns -realval = trial%js * trial%ws * trial%thickness +CALL Reallocate(m4, nns1, nns2, rhobar_i, rhobar_j) +CALL Reallocate(ans, nns1 * rhobar_i, nns2 * rhobar_j) -DO ips = 1, SIZE(realval) - m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) - DO jj = 1, SIZE(kbar, 2) - DO ii = 1, SIZE(kbar, 1) - m4(:, :, ii, jj) = m4(:, :, ii, jj) & - & + realval(ips) * kbar(ii, jj, ips) * m2 - END DO - END DO -END DO +CALL MassMatrix_(test=test, trial=trial, rho=rho, rhorank=rhorank, & + ans=ans, nrow=nns1, ncol=nns2, m4=m4) +! nns1 and nns2 are dummary values here as we dont use them -CALL Convert(From=m4, To=ans) -DEALLOCATE (realval, m2, kbar, m4) +DEALLOCATE (m4) END PROCEDURE MassMatrix_4 !---------------------------------------------------------------------------- @@ -341,7 +351,40 @@ END SUBROUTINE MM_2d !---------------------------------------------------------------------------- MODULE PROCEDURE MassMatrix4_ -! TODO: implement +INTEGER(I4B) :: ips, rhobar_i, rhobar_j, nns1, nns2 +INTEGER(I4B) :: i1, i2, i3, i4 +REAL(DFP) :: realval, T(0), & + rhobar(varopt%defaultMatrixSize, varopt%defaultMatrixSize) + +! main + +rhobar_i = FEVariableSize(obj=rho, dim=1) +rhobar_j = FEVariableSize(obj=rho, dim=2) +nns1 = test%nns +nns2 = trial%nns + +! nrow = nns1 * rhobar_i +! ncol = nns2 * rhobar_j + +m4(1:nns1, 1:nns2, 1:rhobar_i, 1:rhobar_j) = math%zero + +DO ips = 1, test%nips + + CALL FEVariableGetInterpolation_( & + obj=rho, rank=rhorank, N=test%N, nns=test%nns, spaceIndx=ips, & + timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, & + addContribution=math%no, ans=rhobar, nrow=i1, ncol=i2) + + realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips) + + CALL OuterProd_(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips), & + c=rhobar(1:rhobar_i, 1:rhobar_j), & + scale=realval, anscoeff=math%one, & + ans=m4, dim1=i1, dim2=i2, dim3=i3, dim4=i4) +END DO + +CALL Convert_(from=m4(1:nns1, 1:nns2, 1:rhobar_i, 1:rhobar_j), & + to=ans, nrow=nrow, ncol=ncol) END PROCEDURE MassMatrix4_ !---------------------------------------------------------------------------- @@ -360,9 +403,9 @@ END SUBROUTINE MM_2d INTEGER(I4B) :: ii, jj, ips, nsd, nns ! main -CALL GetInterpolation(obj=trial, interpol=lambdaBar, val=lambda) -CALL GetInterpolation(obj=trial, interpol=muBar, val=mu) -CALL GetInterpolation(obj=trial, interpol=rhoBar, val=rho) +CALL GetInterpolation(obj=trial, ans=lambdaBar, val=lambda) +CALL GetInterpolation(obj=trial, ans=muBar, val=mu) +CALL GetInterpolation(obj=trial, ans=rhoBar, val=rho) ALLOCATE (acoeff(SIZE(lambdaBar, 1)), bcoeff(SIZE(lambdaBar, 1))) @@ -396,6 +439,187 @@ END SUBROUTINE MM_2d & eyemat, nij) END PROCEDURE MassMatrix_5 +!---------------------------------------------------------------------------- +! MassMatrix_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix5_ +! REAL(DFP), ALLOCATABLE :: realval(:) +! REAL(DFP), ALLOCATABLE :: m2(:, :), eyemat(:, :), nij(:, :) +! REAL(DFP), ALLOCATABLE :: lambdaBar(:) +! REAL(DFP), ALLOCATABLE :: muBar(:) +! REAL(DFP), ALLOCATABLE :: rhoBar(:) +! REAL(DFP), ALLOCATABLE :: acoeff(:) +! REAL(DFP), ALLOCATABLE :: bcoeff(:) +! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :) +! INTEGER(I4B) :: ii, jj, ips, nsd, nns +! REAL(DFP) :: lambdaBar, muBar, rhoBar, acoeff, bcoeff +! +! ! main +! ALLOCATE (acoeff(SIZE(lambdaBar, 1)), bcoeff(SIZE(lambdaBar, 1))) +! +! bcoeff = SQRT(rhoBar * muBar) +! acoeff = SQRT(rhoBar * (lambdaBar + 2.0_DFP * muBar)) - bcoeff +! +! nsd = trial%nsd +! eyemat = Eye(nsd, 1.0_DFP) +! nns = SIZE(test%N, 1) +! ALLOCATE (m4(nns, nns, nsd, nsd)) +! +! realval = trial%js * trial%ws * trial%thickness +! +! DO ips = 1, SIZE(realval) +! m2 = OUTERPROD(a=test%normal(:, ips), b=trial%normal(:, ips)) +! nij = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips)) +! +! DO jj = 1, nsd +! DO ii = 1, nsd +! +! m4(:, :, ii, jj) = m4(:, :, ii, jj) + realval(ips) * & +! & (acoeff(ips) * m2(ii, jj) + bcoeff(ips) * eyemat(ii, jj)) * nij +! +! END DO +! END DO +! END DO +! +! CALL Convert(From=m4, To=ans) +! +! DEALLOCATE (realval, m2, lambdaBar, muBar, rhoBar, acoeff, bcoeff, m4, & +! & eyemat, nij) +END PROCEDURE MassMatrix5_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix6_ +REAL(DFP) :: realval +INTEGER(I4B) :: ii, jj, ips + +nrow = nns1 +ncol = nns2 +ans(1:nrow, 1:ncol) = 0.0 + +DO ips = 1, nips + realval = js(ips) * ws(ips) * thickness(ips) + + CALL OuterProd_( & + a=N(1:nrow, ips), b=M(1:ncol, ips), nrow=ii, ncol=jj, & + ans=ans, scale=realval, anscoeff=math%one) +END DO +END PROCEDURE MassMatrix6_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix7_ +LOGICAL(LGT) :: isok +INTEGER(I4B) :: a, b, c, d, mynns1, mynns2 + +IF (.NOT. skipVertices) THEN + CALL MassMatrix_( & + N=N, M=M, js=js, ws=ws, thickness=thickness, & + nips=nips, nns1=nns1, nns2=nns2, ans=ans, nrow=nrow, ncol=ncol) + RETURN +END IF + +isok = (nns1 .GT. tVertices) .AND. (nns2 .GT. tVertices) +IF (.NOT. isok) THEN + nrow = 0 + ncol = 0 + RETURN +END IF + +a = tVertices + 1 +b = nns1 +c = tVertices + 1 +d = nns2 +mynns1 = nns1 - tVertices +mynns2 = nns2 - tVertices + +CALL MassMatrix_( & + N=N(a:b, :), M=M(c:d, :), js=js, ws=ws, thickness=thickness, & + nips=nips, nns1=mynns1, nns2=mynns2, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE MassMatrix7_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix8_ +INTEGER(I4B) :: ips, ipt +REAL(DFP) :: realval + +nrow = nnt1 * nns1 +ncol = nnt2 * nns2 +ans(1:nrow, 1:ncol) = 0.0 + +DO ipt = 1, nipt + DO ips = 1, nips + + realval = ws(ips) * js(ips) * spaceThickness(ips) * & + wt(ipt) * jt(ipt) * timeThickness(ipt) + + CALL OTimesTilda_(a=timeN(1:nnt1, ipt), b=timeM(1:nnt2, ipt), & + c=spaceN(1:nns1, ips), d=spaceM(1:nns2, ips), ans=ans, & + nrow=nrow, ncol=ncol, anscoeff=math%one, scale=realval) + + END DO +END DO +END PROCEDURE MassMatrix8_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MassMatrix9_ +LOGICAL(LGT) :: donothing +INTEGER(I4B) :: a, b, c, d, e, f, g, h, mynns1, mynns2, mynnt1, mynnt2 + +IF (.NOT. skipVertices) THEN + CALL MassMatrix_( & + spaceN=spaceN, spaceM=spaceM, timeN=timeN, timeM=timeM, js=js, ws=ws, & + jt=jt, wt=wt, spaceThickness=spaceThickness, & + timeThickness=timeThickness, nips=nips, nns1=nns1, nns2=nns2, & + nipt=nipt, nnt1=nnt1, nnt2=nnt2, ans=ans, nrow=nrow, ncol=ncol) + RETURN +END IF + +donothing = (nns1 .LE. tSpaceVertices) & + .OR. (nns2 .LE. tSpaceVertices) & + .OR. (nnt1 .LE. tTimeVertices) & + .OR. (nnt2 .LE. tTimeVertices) + +IF (donothing) THEN + nrow = 0 + ncol = 0 + RETURN +END IF + +a = tSpaceVertices + 1 +b = nns1 +c = tSpaceVertices + 1 +d = nns2 +e = tTimeVertices + 1 +f = nnt1 +g = tTimeVertices + 1 +h = nnt2 + +mynns1 = nns1 - tSpaceVertices +mynns2 = nns2 - tSpaceVertices +mynnt1 = nnt1 - tTimeVertices +mynnt2 = nnt2 - tTimeVertices + +CALL MassMatrix_( & + spaceN=spaceN(a:b, :), spaceM=spaceM(c:d, :), timeN=timeN(e:f, :), & + timeM=timeM(g:h, :), js=js, ws=ws, jt=jt, wt=wt, & + spaceThickness=spaceThickness, timeThickness=timeThickness, nips=nips, & + nns1=mynns1, nns2=mynns2, nipt=nipt, nnt1=mynnt1, nnt2=mynnt2, ans=ans, & + nrow=nrow, ncol=ncol) + +END PROCEDURE MassMatrix9_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Point/CMakeLists.txt b/src/submodules/Point/CMakeLists.txt new file mode 100644 index 000000000..8f444e95d --- /dev/null +++ b/src/submodules/Point/CMakeLists.txt @@ -0,0 +1,20 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} + PRIVATE ${src_path}/ReferencePoint_Method@Methods.F90) diff --git a/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 b/src/submodules/Point/src/ReferencePoint_Method@Methods.F90 similarity index 100% rename from src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 rename to src/submodules/Point/src/ReferencePoint_Method@Methods.F90 diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt index 8cdab8754..c1588532b 100644 --- a/src/submodules/Polynomial/CMakeLists.txt +++ b/src/submodules/Polynomial/CMakeLists.txt @@ -18,20 +18,7 @@ set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") target_sources( ${PROJECT_NAME} - PRIVATE ${src_path}/LineInterpolationUtility@Methods.F90 - ${src_path}/QuadraturePoint_Triangle_Solin.F90 - ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90 - ${src_path}/TriangleInterpolationUtility@Methods.F90 - ${src_path}/TriangleInterpolationUtility@QuadratureMethods.F90 - ${src_path}/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 - ${src_path}/TriangleInterpolationUtility@LagrangeBasisMethods.F90 - ${src_path}/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 - ${src_path}/QuadrangleInterpolationUtility@Methods.F90 - ${src_path}/TetrahedronInterpolationUtility@Methods.F90 - ${src_path}/HexahedronInterpolationUtility@Methods.F90 - ${src_path}/PrismInterpolationUtility@Methods.F90 - ${src_path}/PyramidInterpolationUtility@Methods.F90 - ${src_path}/InterpolationUtility@Methods.F90 + PRIVATE ${src_path}/InterpolationUtility@Methods.F90 ${src_path}/LagrangePolynomialUtility@Methods.F90 ${src_path}/HierarchicalPolynomialUtility@Methods.F90 ${src_path}/JacobiPolynomialUtility@Methods.F90 diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 index 462fefdbf..4a9722da2 100644 --- a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 @@ -62,23 +62,27 @@ MODULE PROCEDURE HierarchicalDOF INTEGER(I4B) :: ii +LOGICAL(LGT) :: isok ans = 0 ii = HierarchicalVertexDOF(elemType=elemType) ans = ans + ii -IF (PRESENT(cellOrder)) THEN +isok = PRESENT(cellOrder) +IF (isok) THEN ii = HierarchicalCellDOF(elemType=elemType, order=cellOrder) ans = ans + ii END IF -IF (PRESENT(faceOrder)) THEN +isok = PRESENT(faceOrder) +IF (isok) THEN ii = HierarchicalFaceDOF(elemType=elemType, order=faceOrder) ans = ans + ii END IF -IF (PRESENT(edgeOrder)) THEN +isok = PRESENT(edgeOrder) +IF (isok) THEN ii = HierarchicalEdgeDOF(elemType=elemType, order=edgeOrder) ans = ans + ii END IF diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 index 313f99916..c49b17cb7 100644 --- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 @@ -249,11 +249,21 @@ ! LagrangeVandermonde_ !---------------------------------------------------------------------------- -MODULE PROCEDURE LagrangeVandermonde_ +MODULE PROCEDURE LagrangeVandermonde1_ INTEGER(I4B), ALLOCATABLE :: degree(:, :) +degree = LagrangeDegree(order=order, elemType=elemType) +CALL LagrangeVandermonde2_(xij=xij, degree=degree, ans=ans, nrow=nrow, & + ncol=ncol) +IF (ALLOCATED(degree)) DEALLOCATE (degree) +END PROCEDURE LagrangeVandermonde1_ + +!---------------------------------------------------------------------------- +! LagrangeVandermonde_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeVandermonde2_ INTEGER(I4B) :: jj, nsd, ii -degree = LagrangeDegree(order=order, elemType=elemType) nrow = SIZE(xij, 2) nsd = SIZE(degree, 2) ncol = SIZE(degree, 1) @@ -280,8 +290,7 @@ END SELECT -IF (ALLOCATED(degree)) DEALLOCATE (degree) -END PROCEDURE LagrangeVandermonde_ +END PROCEDURE LagrangeVandermonde2_ !---------------------------------------------------------------------------- ! EquidistancePoint diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 deleted file mode 100644 index 4c309f30c..000000000 --- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,1973 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public 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 BaseType, ONLY: ipopt => TypeInterpolationOpt, & - qpopt => TypeQuadratureOpt, & - polyopt => TypePolynomialOpt, & - elmopt => TypeElemNameOpt - -USE GlobalData, ONLY: stderr - -USE StringUtility, ONLY: UpperCase - -USE MappingUtility, ONLY: FromBiunitLine2Segment_, & - FromBiunitLine2Segment, & - FromUnitLine2BiUnitLine, & - FromUnitLine2BiUnitLine_ - -USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, & - GradientEvalAllOrthopol_, & - EvalAllOrthopol, & - EvalAllOrthopol_ - -USE InputUtility, ONLY: Input - -USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde, & - LagrangeCoeff, & - LagrangeVandermonde_ - -USE ErrorHandling, ONLY: ErrorMsg - -USE LegendrePolynomialUtility, ONLY: LegendreQuadrature - -USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature - -USE JacobiPolynomialUtility, ONLY: JacobiQuadrature - -USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature - -USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat - -USE SortUtility, ONLY: HeapSort - -USE F95_BLAS, ONLY: GEMM - -#ifndef USE_BLAS95 - -USE SwapUtility, ONLY: Swap - -#else - -USE F95_BLAS, ONLY: Swap - -#endif - -IMPLICIT NONE -CONTAINS - -!---------------------------------------------------------------------------- -! RefElemDomain_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE RefElemDomain_Line -ans = "BIUNIT" -END PROCEDURE RefElemDomain_Line - -!---------------------------------------------------------------------------- -! QuadratureNumber_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadratureNumber_Line -SELECT CASE (quadType) -CASE (qpopt%GaussLegendre, qpopt%GaussChebyshev, & - qpopt%GaussJacobi, qpopt%GaussUltraspherical) - ans = 1_I4B + INT(order / 2, kind=I4B) -CASE DEFAULT - ans = 2_I4B + INT(order / 2, kind=I4B) -END SELECT -END PROCEDURE QuadratureNumber_Line - -!---------------------------------------------------------------------------- -! ToVEFC_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE ToVEFC_Line -REAL(DFP) :: t1 -INTEGER(I4B) :: np -np = SIZE(pt) -t1 = pt(np) -IF (np .GT. 2) THEN - pt(3:np) = pt(2:np - 1) - pt(2) = t1 -END IF -END PROCEDURE ToVEFC_Line - -!---------------------------------------------------------------------------- -! LagrangeDegree_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Line -INTEGER(I4B) :: ii, n -n = LagrangeDOF_Line(order=order) -ALLOCATE (ans(n, 1)) -DO ii = 1, n - ans(ii, 1) = ii - 1 -END DO -END PROCEDURE LagrangeDegree_Line - -!---------------------------------------------------------------------------- -! LagrangeDOF_Point -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Point -ans = 1_I4B -END PROCEDURE LagrangeDOF_Point - -!---------------------------------------------------------------------------- -! LagrangeDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Line -ans = order + 1 -END PROCEDURE LagrangeDOF_Line - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Line -ans = order - 1_I4B -END PROCEDURE LagrangeInDOF_Line - -!---------------------------------------------------------------------------- -! GetTotalDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Line -ans = order + 1 -END PROCEDURE GetTotalDOF_Line - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Line -ans = order - 1_I4B -END PROCEDURE GetTotalInDOF_Line - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line1 -INTEGER(I4B) :: tsize - -IF (order .LE. 1_I4B) THEN - ALLOCATE (ans(0)) - RETURN -END IF - -tsize = LagrangeInDOF_Line(order=order) -ALLOCATE (ans(tsize)) -CALL EquidistanceInPoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize) - -END PROCEDURE EquidistanceInPoint_Line1 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line1_ -INTEGER(I4B) :: ii -REAL(DFP) :: avar - -tsize = 0 -IF (order .LE. 1_I4B) RETURN - -tsize = LagrangeInDOF_Line(order=order) - -avar = (xij(2) - xij(1)) / order - -DO ii = 1, tsize - ans(ii) = xij(1) + REAL(ii, kind=dfp) * avar -END DO - -END PROCEDURE EquidistanceInPoint_Line1_ - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line2 -INTEGER(I4B) :: nrow, ncol - -IF (order .LE. 1_I4B) THEN - ALLOCATE (ans(0, 0)) - RETURN -END IF - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1_I4B -END IF - -ncol = LagrangeInDOF_Line(order=order) - -ALLOCATE (ans(nrow, ncol)) - -CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) - -END PROCEDURE EquidistanceInPoint_Line2 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Line2_ -INTEGER(I4B) :: ii -REAL(DFP) :: x0(3, 3) - -nrow = 0; ncol = 0 -IF (order .LE. 1_I4B) RETURN - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) - x0(1:nrow, 1) = xij(1:nrow, 1) - x0(1:nrow, 2) = xij(1:nrow, 2) -ELSE - nrow = 1_I4B - x0(1, 1) = -1.0 - x0(1, 2) = 1.0 -END IF - -ncol = LagrangeInDOF_Line(order=order) - -x0(1:nrow, 3) = (x0(1:nrow, 2) - x0(1:nrow, 1)) / order - -DO ii = 1, ncol - ans(1:nrow, ii) = x0(1:nrow, 1) + ii * x0(1:nrow, 3) -END DO -END PROCEDURE EquidistanceInPoint_Line2_ - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Line1 -INTEGER(I4B) :: tsize - -tsize = order + 1 -ALLOCATE (ans(tsize)) -CALL EquidistancePoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize) -END PROCEDURE EquidistancePoint_Line1 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Line1_ -INTEGER(I4B) :: tempint - -tsize = order + 1 - -SELECT CASE (order) -CASE (0) - ans(1) = 0.5_DFP * (xij(1) + xij(2)) - -CASE (1) - ans(1) = xij(1) - ans(2) = xij(2) - -CASE DEFAULT - ans(1) = xij(1) - ans(2) = xij(2) - CALL EquidistanceInPoint_Line_(order=order, xij=xij, ans=ans(3:), & - tsize=tempint) -END SELECT - -END PROCEDURE EquidistancePoint_Line1_ - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Line2 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1_I4B -END IF - -ncol = order + 1 -ALLOCATE (ans(nrow, ncol)) - -CALL EquidistancePoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE EquidistancePoint_Line2 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Line2_ -INTEGER(I4B) :: tempint - -ncol = order + 1 - -SELECT CASE (order) - -CASE (0) - - IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) - ans(1:nrow, 1) = 0.5_DFP * (xij(1:nrow, 1) + xij(1:nrow, 2)) - RETURN - END IF - - nrow = 1_I4B - ans(1, 1) = 0.0_DFP - -CASE (1) - - IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) - ans(1:nrow, 1:2) = xij(1:nrow, 1:2) - RETURN - END IF - - nrow = 1 - ans(1, 1) = -1.0_DFP - ans(1, 2) = 1.0_DFP - -CASE DEFAULT - - IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) - ans(1:nrow, 1:2) = xij(1:nrow, 1:2) - ELSE - nrow = 1 - ans(1, 1) = -1.0_DFP - ans(1, 2) = 1.0_DFP - END IF - - CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans(:, 3:), & - nrow=nrow, ncol=tempint) - -END SELECT - -END PROCEDURE EquidistancePoint_Line2_ - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Line1 -INTEGER(I4B) :: nrow, ncol - -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 - CALL EquidistancePoint_Line_(xij=xij, order=order, ans=ans, nrow=nrow, & - ncol=ncol) - RETURN -END IF - -CALL handle_error -!! handle_error is defined in this routine, see below - -ncol = order + 1 - -SELECT CASE (ipType) - -CASE (ipopt%Equidistance) - CALL EquidistancePoint_Line_(xij=xij, order=order, nrow=nrow, ncol=ncol, & - ans=ans) - CALL handle_increasing - -CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss) - CALL handle_non_equidistance - -CASE (ipopt%GaussChebyshev) - CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss) - CALL handle_non_equidistance - -CASE (ipopt%GaussLegendreLobatto) - CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto) - CALL handle_vefc - CALL handle_non_equidistance - -CASE (ipopt%GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto) - CALL handle_vefc - CALL handle_non_equidistance - -CASE (ipopt%GaussJacobi) - CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss, & - alpha=alpha, beta=beta) - CALL handle_non_equidistance - -CASE (ipopt%GaussJacobiLobatto) - CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto, & - alpha=alpha, beta=beta) - CALL handle_vefc - CALL handle_non_equidistance - -CASE (ipopt%GaussUltraspherical) -CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss, & - lambda=lambda) - CALL handle_non_equidistance - -CASE (ipopt%GaussUltrasphericalLobatto) - CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto, & - lambda=lambda) - - CALL handle_vefc - CALL handle_non_equidistance - -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line1_()", & - file=__FILE__, line=__LINE__, unitno=stderr) -END SELECT - -CONTAINS - -SUBROUTINE handle_vefc - REAL(DFP) :: t1 - - !! layout VEFC - IF (layout(1:1) .EQ. "V") THEN - t1 = temp(order + 1) - IF (order .GE. 2) THEN - temp(3:order + 1) = temp(2:order) - END IF - temp(2) = t1 - END IF - -END SUBROUTINE handle_vefc - -SUBROUTINE handle_increasing - INTEGER(I4B) :: ii - - !! layout INCREASING - IF (layout(1:1) .EQ. "I") THEN - DO ii = 1, nrow - CALL HeapSort(ans(ii, :)) - END DO - END IF -END SUBROUTINE - -SUBROUTINE handle_non_equidistance - IF (PRESENT(xij)) THEN - CALL FromBiunitLine2Segment_(xin=temp(1:ncol), x1=xij(:, 1), x2=xij(:, 2), & - ans=ans, nrow=nrow, ncol=ncol) - ELSE - nrow = 1 - ans(1, 1:ncol) = temp(1:ncol) - END IF - -END SUBROUTINE handle_non_equidistance - -SUBROUTINE handle_error - -#ifdef DEBUG_VER - LOGICAL(LGT) :: isok - CHARACTER(:), ALLOCATABLE :: msg - - SELECT CASE (ipType) - CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto) - isok = PRESENT(alpha) .AND. PRESENT(beta) - IF (.NOT. isok) THEN - msg = "alpha and beta should be present for ipType=GaussJacobi" - - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - - CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) - isok = PRESENT(lambda) - IF (.NOT. isok) THEN - msg = "lambda should be present for ipType=GaussUltraSpherical" - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - END SELECT - -#endif - -END SUBROUTINE handle_error - -END PROCEDURE InterpolationPoint_Line1_ - -!---------------------------------------------------------------------------- -! InterpolationPoint_Line2_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Line2_ -tsize = order + 1 -IF (order .EQ. 0_I4B) THEN - ans(1) = 0.5_DFP * (xij(1) + xij(2)) - RETURN -END IF - -CALL handle_error - -SELECT CASE (ipType) - -CASE (ipopt%Equidistance) - CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans) - - IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans(1:tsize)) - -CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss) - CALL handle_non_equidistance - -CASE (ipopt%GaussChebyshev) - CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%Gauss) - CALL handle_non_equidistance - -CASE (ipopt%GaussJacobi) - CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, alpha=alpha, & - beta=beta) - CALL handle_non_equidistance - -CASE (ipopt%GaussUltraspherical) - CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, & - lambda=lambda) - CALL handle_non_equidistance - -CASE (ipopt%GaussLegendreLobatto) - CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto) - CALL handle_vefc - CALL handle_non_equidistance - -CASE (ipopt%GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto) - CALL handle_vefc - CALL handle_non_equidistance - -CASE (ipopt%GaussJacobiLobatto) - CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, alpha=alpha, & - beta=beta) - CALL handle_vefc - CALL handle_non_equidistance - -CASE (ipopt%GaussUltrasphericalLobatto) - CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, & - lambda=lambda) - CALL handle_vefc - CALL handle_non_equidistance - -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) -END SELECT - -CONTAINS - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE handle_vefc - REAL(DFP) :: t1 - - IF (layout(1:2) .EQ. "VE") THEN - t1 = ans(order + 1) - IF (order .GE. 2) THEN - ans(3:) = ans(2:order) - END IF - ans(2) = t1 - END IF - -END SUBROUTINE handle_vefc - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE handle_non_equidistance - CALL FromBiunitLine2Segment_(xin=ans, x1=xij(1), x2=xij(2), & - ans=ans, tsize=tsize) - -END SUBROUTINE handle_non_equidistance - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -SUBROUTINE handle_error - -#ifdef DEBUG_VER - LOGICAL(LGT) :: isok - CHARACTER(:), ALLOCATABLE :: msg - - SELECT CASE (ipType) - CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto) - isok = PRESENT(alpha) .AND. PRESENT(beta) - IF (.NOT. isok) THEN - msg = "alpha and beta should be present for ipType=GaussJacobi" - - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - - CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto) - isok = PRESENT(lambda) - IF (.NOT. isok) THEN - msg = "lambda should be present for ipType=GaussUltraSpherical" - CALL ErrorMsg(msg=msg, file=__FILE__, & - routine="InterpolationPoint_Line1_()", & - line=__LINE__, unitno=stderr) - END IF - END SELECT - -#endif - -END SUBROUTINE handle_error - -END PROCEDURE InterpolationPoint_Line2_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line1 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Line1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Line1 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line1_ -REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2)) -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info, nrow, ncol - -tsize = order + 1 -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, & - ans=v, nrow=nrow, ncol=ncol) - -CALL GetLU(A=v, IPIV=ipiv, info=info) - -ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP - -CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) - -END PROCEDURE LagrangeCoeff_Line1_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line2 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Line2_(order=order, i=i, v=v, isVandermonde=.TRUE., & - ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Line2 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line2_ -REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2)) -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info - -tsize = order + 1 - -vtemp = v -! ipiv = 0 - -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) - -ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP - -CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) - -END PROCEDURE LagrangeCoeff_Line2_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line3 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Line3_(order=order, i=i, v=v, ipiv=ipiv, ans=ans, & - tsize=tsize) -END PROCEDURE LagrangeCoeff_Line3 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line3_ -INTEGER(I4B) :: info -tsize = 1 + order -ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Line3_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line4 -INTEGER(I4B) :: nrow, ncol -CALL LagrangeCoeff_Line4_(order=order, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE LagrangeCoeff_Line4 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line4_ -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, & - ans=ans, nrow=nrow, ncol=ncol) -CALL GetInvMat(ans(1:nrow, 1:ncol)) -END PROCEDURE LagrangeCoeff_Line4_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line5 -INTEGER(I4B) :: nrow, ncol -CALL LagrangeCoeff_Line5_(order=order, xij=xij, basisType=basisType, & - alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE LagrangeCoeff_Line5 - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Line5_ -IF (basisType .EQ. polyopt%Monomial) THEN - CALL LagrangeCoeff_Line_(order=order, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) - RETURN -END IF - -CALL EvalAllOrthopol_(n=order, x=xij(1, :), & - orthopol=basisType, & - alpha=alpha, beta=beta, lambda=lambda, & - ans=ans, nrow=nrow, ncol=ncol) - -CALL GetInvMat(ans(1:nrow, 1:ncol)) -END PROCEDURE LagrangeCoeff_Line5_ - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Line1 -INTEGER(I4B) :: tsize -CALL LagrangeEvalAll_Line1_(order=order, x=x, xij=xij, coeff=coeff, & - firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda, ans=ans, tsize=tsize) -END PROCEDURE LagrangeEvalAll_Line1 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Line1_ -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), x1(1) -INTEGER(I4B) :: ii, orthopol0, nrow, ncol - -tsize = SIZE(xij, 2) - -#ifdef DEBUG_VER - -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 - CALL LagrangeCoeff_Line_(order=order, xij=xij, & - basisType=orthopol0, alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff, nrow=nrow, ncol=ncol) - END IF - - ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff(1:nrow, 1:ncol)) - coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) - -ELSE - - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff0, nrow=nrow, ncol=ncol) - - ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff0(1:nrow, 1:ncol)) -END IF - -IF (orthopol0 .EQ. polyopt%monomial) THEN - - xx(1, 1) = 1.0_DFP - DO ii = 1, order - xx(1, ii + 1) = xx(1, ii) * x - END DO - -ELSE - - x1(1) = x - CALL EvalAllOrthopol_(n=order, x=x1, orthopol=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, & - ans=xx, nrow=nrow, ncol=ncol) - -END IF - -DO CONCURRENT(ii=1:tsize) - ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) -END DO - -END PROCEDURE LagrangeEvalAll_Line1_ - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Line2 -INTEGER(I4B) :: nrow, ncol -CALL LagrangeEvalAll_Line2_(order=order, x=x, xij=xij, coeff=coeff, & - firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE LagrangeEvalAll_Line2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Line2_ -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) -INTEGER(I4B) :: ii, orthopol0, aint, bint - -nrow = SIZE(x, 2) -ncol = SIZE(xij, 2) - -#ifdef DEBUG_VER - -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(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff, nrow=aint, ncol=bint) - END IF - - coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) - -ELSE - - ! coeff0 = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=aint, ncol=bint) - -END IF - -IF (orthopol0 .EQ. polyopt%monomial) THEN - - xx(:, 1) = 1.0_DFP - DO ii = 1, order - xx(:, ii + 1) = xx(:, ii) * x(1, :) - END DO - -ELSE - - ! xx = EvalAllOrthopol( - CALL EvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, alpha=alpha, & - beta=beta, lambda=lambda, ans=xx, nrow=aint, ncol=bint) - -END IF - -! ans = MATMUL(xx, coeff0) -CALL GEMM(C=ans, alpha=1.0_DFP, A=xx, B=coeff0) - -END PROCEDURE LagrangeEvalAll_Line2_ - -!---------------------------------------------------------------------------- -! EvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line1 -INTEGER(I4B) :: tsize -CALL BasisEvalAll_Line1_(order=order, x=x, ans=ans, tsize=tsize, & - refline=refline, basistype=basistype, alpha=alpha, beta=beta, & - lambda=lambda) -END PROCEDURE BasisEvalAll_Line1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line1_ -#ifdef DEBUG_VER -CHARACTER(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 - -#endif - -basisType0 = Input(default=polyopt%Monomial, option=basisType) - -SELECT CASE (basisType0) - -CASE (polyopt%Monomial) - ans(1) = 1.0_DFP - DO ii = 1, order - ans(ii + 1) = ans(ii) * x - END DO - -CASE DEFAULT - -#ifdef DEBUG_VER - - IF (basisType0 .EQ. polyopt%Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (order + 1 .GT. SIZE(temp, 2)) THEN - CALL Errormsg( & - msg="order+1 is greater than number of col in temp", & - routine="BasisEvalAll_Line1_", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -#endif - - x1(1) = x - CALL EvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, alpha=alpha, & - beta=beta, lambda=lambda, ans=temp, nrow=nrow, ncol=ncol) - - ans(1:tsize) = temp(1, 1:tsize) - -END SELECT - -END PROCEDURE BasisEvalAll_Line1_ - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line1 -INTEGER(I4B) :: tsize -CALL BasisGradientEvalAll_Line1_(order=order, x=x, refLine=refLine, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, & - tsize=tsize) -END PROCEDURE BasisGradientEvalAll_Line1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line1_ -INTEGER(I4B) :: ii, basisType0 -CHARACTER(:), ALLOCATABLE :: astr -REAL(DFP) :: areal, breal, x1(1), temp(1, order + 1) - -astr = UpperCase(refline) - -tsize = order + 1 - -#ifdef DEBUG_VER - -IF (astr .EQ. "UNIT") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - -#endif - -basisType0 = Input(default=polyopt%Monomial, option=basisType) -SELECT CASE (basisType0) - -CASE (polyopt%Monomial) - - ans(1) = 0.0_DFP - DO ii = 1, order - areal = REAL(ii, kind=DFP) - breal = x**(ii - 1) - ans(ii + 1) = areal * breal - END DO - -CASE DEFAULT - -#ifdef DEBUG_VER - - IF (basisType0 .EQ. polyopt%Jacobi) THEN - - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - - END IF - -#endif - - x1(1) = x - CALL GradientEvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, ans=temp, nrow=ii, ncol=tsize) - - ans(1:tsize) = temp(1, 1:tsize) - -END SELECT - -END PROCEDURE BasisGradientEvalAll_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line2 -INTEGER(I4B) :: nrow, ncol -CALL BasisGradientEvalAll_Line2_(order=order, x=x, ans=ans, nrow=nrow, & - ncol=ncol, refLine=refLine, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) -END PROCEDURE BasisGradientEvalAll_Line2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisGradientEvalAll_Line2_ -INTEGER(I4B) :: ii, basisType0, jj -REAL(DFP) :: areal, breal -CHARACTER(:), ALLOCATABLE :: astr - -nrow = SIZE(x) -ncol = 1 + order - -astr = UpperCase(refLine) - -#ifdef DEBUG_VER - -IF (astr .EQ. "UNIT") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisGradientEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - -#endif - -basisType0 = Input(default=polyopt%Monomial, option=basisType) -SELECT CASE (basisType0) - -CASE (polyopt%Monomial) - - ans(1:nrow, 1) = 0.0_DFP - - DO ii = 1, order - areal = REAL(ii, kind=dfp) - - DO jj = 1, nrow - - breal = x(jj)**(ii - 1) - ans(jj, ii + 1) = areal * breal - - END DO - - END DO - -CASE DEFAULT - -#ifdef DEBUG_VER - - IF (basisType0 .EQ. polyopt%Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisGradientEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisGradientEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - -#endif - - ! ans = GradientEvalAllOrthopol(& - CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) - -END SELECT - -END PROCEDURE BasisGradientEvalAll_Line2_ - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line2 -INTEGER(I4B) :: nrow, ncol -CALL BasisEvalAll_Line2_(order=order, x=x, ans=ans, nrow=nrow, ncol=ncol, & - refline=refline, basistype=basistype, & - alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE BasisEvalAll_Line2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE BasisEvalAll_Line2_ -#ifdef DEBUG_VER -CHARACTER(1) :: astr - -#endif - -INTEGER(I4B) :: ii, basisType0 - -nrow = SIZE(x) -ncol = order + 1 - -#ifdef DEBUG_VER - -astr = UpperCase(refline(1:1)) - -IF (astr .EQ. "U") THEN - CALL Errormsg(msg="refLine should be BIUNIT", & - routine="BasisEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END IF - -#endif - -basisType0 = Input(default=polyopt%Monomial, option=basisType) - -SELECT CASE (basisType0) - -CASE (polyopt%Monomial) - ans(1:nrow, 1) = 1.0_DFP - DO ii = 1, order - ans(1:nrow, ii + 1) = ans(1:nrow, ii) * x - END DO - -CASE DEFAULT - -#ifdef DEBUG_VER - - IF (basisType0 .EQ. polyopt%Jacobi) THEN - IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN - CALL Errormsg( & - msg="alpha and beta should be present for basisType=Jacobi", & - routine="BasisEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - - IF (basisType0 .EQ. polyopt%Ultraspherical) THEN - IF (.NOT. PRESENT(lambda)) THEN - CALL Errormsg( & - msg="lambda should be present for basisType=Ultraspherical", & - routine="BasisEvalAll_Line2", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - END IF - -#endif - - CALL EvalAllOrthopol_(n=order, x=x, orthopol=basisType0, alpha=alpha, & - beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) -END SELECT - -END PROCEDURE BasisEvalAll_Line2_ - -!---------------------------------------------------------------------------- -! BasisGradientEvalAll_Line -!---------------------------------------------------------------------------- - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line1 -INTEGER(I4B) :: nips(1), nrow, ncol - -nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1 -END IF - -nrow = nrow + 1 -ncol = nips(1) - -ALLOCATE (ans(nrow, ncol)) - -CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & - xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) - -END PROCEDURE QuadraturePoint_Line1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line2 -INTEGER(I4B) :: nips(1), nrow, ncol -REAL(DFP) :: x12(1, 2) - -nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) -nrow = 2 -ncol = nips(1) - -ALLOCATE (ans(nrow, ncol)) - -x12(1, 1:2) = xij(1:2) - -CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & - xij=x12, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE QuadraturePoint_Line2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line3 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 1 -END IF - -nrow = nrow + 1 -ncol = nips(1) - -ALLOCATE (ans(nrow, ncol)) - -CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & - xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) - -END PROCEDURE QuadraturePoint_Line3 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line4 -REAL(DFP) :: x12(1, 2) -INTEGER(I4B) :: nrow, ncol - -nrow = 2 -ncol = nips(1) - -ALLOCATE (ans(nrow, ncol)) - -x12(1, 1:2) = xij(1:2) - -CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, & - xij=x12, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, & - ncol=ncol) - -END PROCEDURE QuadraturePoint_Line4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Line1_ -#ifdef DEBUG_VER -LOGICAL(LGT) :: isok -#endif - -INTEGER(I4B) :: np, nsd, ii, jj -REAL(DFP) :: areal -LOGICAL(LGT) :: changeLayout - -nrow = 0 -ncol = 0 - -#ifdef DEBUG_VER - -SELECT CASE (quadType) -CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto, & - ipopt%GaussJacobiRadauLeft, ipopt%GaussJacobiRadauRight) - - isok = PRESENT(alpha) .AND. PRESENT(beta) - - IF (.NOT. isok) THEN - CALL ErrorMsg(routine="QuadraturePoint_Line3", & - msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto, & - ipopt%GaussUltraSphericalRadauLeft, ipopt%GaussUltraSphericalRadauRight) - - isok = PRESENT(lambda) - - IF (.NOT. isok) THEN - CALL ErrorMsg(routine="QuadraturePoint_Line3", & - msg="lambda should be present for quadType=ipopt%GaussUltraspherical", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -END SELECT - -#endif - -IF (PRESENT(xij)) THEN - nsd = SIZE(xij, 1) -ELSE - nsd = 1 -END IF - -np = nips(1) -nrow = nsd + 1 -ncol = nips(1) - -changeLayout = .FALSE. -IF (layout(1:1) .EQ. "V") changeLayout = .TRUE. - -SELECT CASE (quadType) - -CASE (ipopt%GaussLegendre) - CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%Gauss) - -CASE (ipopt%GaussLegendreRadauLeft) - CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauLeft) - -CASE (ipopt%GaussLegendreRadauRight) - CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauRight) - -CASE (ipopt%GaussLegendreLobatto) - CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussLobatto) - -CASE (ipopt%GaussChebyshev) - CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%Gauss) - -CASE (ipopt%GaussChebyshevRadauLeft) - CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauLeft) - -CASE (ipopt%GaussChebyshevRadauRight) - CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauRight) - -CASE (ipopt%GaussChebyshevLobatto) - CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussLobatto) - -CASE (ipopt%GaussJacobi) - CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%Gauss, alpha=alpha, beta=beta) - -CASE (ipopt%GaussJacobiRadauLeft) - CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauLeft, alpha=alpha, beta=beta) - -CASE (ipopt%GaussJacobiRadauRight) - CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauRight, alpha=alpha, beta=beta) - -CASE (ipopt%GaussJacobiLobatto) - CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussLobatto, alpha=alpha, beta=beta) - -CASE (ipopt%GaussUltraspherical) -CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%Gauss, lambda=lambda) - -CASE (ipopt%GaussUltrasphericalRadauLeft) -CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauLeft, lambda=lambda) - -CASE (ipopt%GaussUltrasphericalRadauRight) -CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussRadauRight, lambda=lambda) - -CASE (ipopt%GaussUltrasphericalLobatto) -CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), & - quadType=ipopt%GaussLobatto, lambda=lambda) - -CASE DEFAULT - CALL ErrorMsg(msg="Unknown iptype", routine="QuadraturePoint_Line3", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN -END SELECT - -IF (changeLayout) THEN - CALL ToVEFC_Line(ans(1, 1:ncol)) - CALL ToVEFC_Line(ans(nrow, 1:ncol)) -END IF - -IF (PRESENT(xij)) THEN - CALL FromBiunitLine2Segment_(xin=ans(1, 1:ncol), x1=xij(:, 1), & - x2=xij(:, 2), ans=ans, nrow=ii, ncol=jj) - - areal = NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP - - DO CONCURRENT(ii=1:ncol) - ans(nrow, ii) = ans(nrow, ii) * areal - END DO - - RETURN -END IF - -END PROCEDURE QuadraturePoint_Line1_ - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Line1 -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1) -INTEGER(I4B) :: ii, orthopol0 - -orthopol0 = input(default=polyopt%Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - coeff = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) - END IF - coeff0 = coeff -ELSE - coeff0 = LagrangeCoeff_Line(& - & order=order, & - & xij=xij, & - & basisType=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda & - & ) -END IF - -SELECT CASE (orthopol0) -CASE (polyopt%Monomial) - - IF (SIZE(xij, 2) .NE. order + 1) THEN - CALL Errormsg(& - & msg="size(xij, 2) is not same as order+1", & - & file=__FILE__, & - & routine="LagrangeGradientEvalAll_Line1", & - & line=__LINE__, & - & unitno=stderr) - RETURN - END IF - - DO ii = 0, order - xx(:, ii + 1) = REAL(ii, kind=DFP) * x(1, :)**(MAX(ii - 1_I4B, 0_I4B)) - END DO - -CASE DEFAULT - xx = GradientEvalAllOrthopol(& - & n=order, & - & x=x(1, :), & - & orthopol=orthopol0, & - & alpha=alpha, & - & beta=beta, & - & lambda=lambda) -END SELECT - -ans(:, :, 1) = MATMUL(xx, coeff0) - -END PROCEDURE LagrangeGradientEvalAll_Line1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Line1_ -LOGICAL(LGT) :: firstCall0 -REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1), areal -INTEGER(I4B) :: ii, orthopol0, indx(2), jj - -dim1 = SIZE(x, 2) -dim2 = SIZE(xij, 2) -dim3 = 1 -!! ans(SIZE(x, 2), SIZE(xij, 2), 1) - -orthopol0 = input(default=polyopt%Monomial, option=basisType) -firstCall0 = input(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - IF (firstCall0) THEN - - ! coeff = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff, & - nrow=indx(1), ncol=indx(2)) - - END IF - - coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) - -ELSE - - ! coeff0 = LagrangeCoeff_Line(& - CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & - nrow=indx(1), ncol=indx(2)) -END IF - -SELECT CASE (orthopol0) -CASE (polyopt%Monomial) - -#ifdef DEBUG_VER - - IF (dim2 .NE. order + 1) THEN - CALL Errormsg(msg="size(xij, 2) is not same as order+1", & - routine="LagrangeGradientEvalAll_Line1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -#endif - - DO ii = 0, order - indx(1) = MAX(ii - 1_I4B, 0_I4B) - areal = REAL(ii, kind=DFP) - DO jj = 1, dim1 - xx(jj, ii + 1) = areal * (x(1, jj)**(indx(1))) - END DO - END DO - -CASE DEFAULT - - ! xx(1:dim1, 1:dim2) = GradientEvalAllOrthopol(n=order, x=x(1, :), & - CALL GradientEvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, & - alpha=alpha, beta=beta, lambda=lambda, ans=xx, nrow=dim1, ncol=dim2) - -END SELECT - -! ans(:, :, 1) = MATMUL(xx, coeff0) -CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx, B=coeff0) - -END PROCEDURE LagrangeGradientEvalAll_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line1 -INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Line1_(order=order, xij=xij, refLine=refLine, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Line1 - -!---------------------------------------------------------------------------- -! BasisEvalAll_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line1_ -INTEGER(I4B), PARAMETER :: orient = 1 -CALL HeirarchicalBasis_Line2_(order=order, xij=xij, refLine=refLine, & - orient=orient, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Line2_ -CHARACTER(1) :: astr -REAL(DFP) :: temp(SIZE(xij, 2)), o1 -INTEGER(I4B) :: ii, k - -o1 = REAL(orient, kind=DFP) -astr = UpperCase(refLine(1:1)) - -! nrow = SIZE(xij, 2) -! ncol = order + 1 - -SELECT CASE (astr) -CASE ("U") - CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=nrow) - CALL EvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, ans=ans, & - nrow=nrow, ncol=ncol) - -CASE ("B") - CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=polyopt%Lobatto, & - ans=ans, nrow=nrow, ncol=ncol) - -CASE DEFAULT - nrow = 0 - ncol = 0 -END SELECT - -DO CONCURRENT(k=2:order, ii=1:nrow) - ans(ii, k + 1) = (o1**k) * ans(ii, k + 1) -END DO - -END PROCEDURE HeirarchicalBasis_Line2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalGradientBasis_Line1 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL HeirarchicalGradientBasis_Line1_(order=order, xij=xij, refLine=refLine, & - ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) -END PROCEDURE HeirarchicalGradientBasis_Line1 - -!---------------------------------------------------------------------------- -! HeirarchicalGradientBasis_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalGradientBasis_Line1_ -INTEGER(I4B), PARAMETER :: orient = 1 -CALL HeirarchicalGradientBasis_Line2_(order=order, xij=xij, refLine=refLine, & - orient=orient, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) -END PROCEDURE HeirarchicalGradientBasis_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalGradientBasis_Line2 -INTEGER(I4B) :: dim1, dim2, dim3 - -dim1 = SIZE(xij, 2) -dim2 = order + 1 -dim3 = 1 - -ALLOCATE (ans(dim1, dim2, dim3)) - -CALL HeirarchicalGradientBasis_Line2_(order=order, xij=xij, refLine=refLine, & - orient=orient, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) - -END PROCEDURE HeirarchicalGradientBasis_Line2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalGradientBasis_Line2_ -CHARACTER(1) :: astr -REAL(DFP) :: temp(SIZE(xij, 2)), o1 -INTEGER(I4B) :: ii, jj, k - -o1 = REAL(orient, kind=DFP) -astr = UpperCase(refLine(1:1)) - -dim3 = 1 - -SELECT CASE (astr) - -CASE ("U") - CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=dim1) - CALL GradientEvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, & - ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - - DO CONCURRENT(ii=1:dim1, jj=1:dim2) - ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP - END DO - -CASE ("B") - CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), & - orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - -CASE DEFAULT - dim1 = 0; dim2 = 0; dim3 = 0 - RETURN - -END SELECT - -DO CONCURRENT(k=2:order, ii=1:dim1) - ans(ii, k + 1, 1) = (o1**(k - 1)) * ans(ii, k + 1, 1) -END DO - -END PROCEDURE HeirarchicalGradientBasis_Line2_ - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasis_Line1 -INTEGER(I4B) :: nrow, ncol -CALL OrthogonalBasis_Line1_(order=order, xij=xij, refline=refline, & - basisType=basisType, ans=ans, nrow=nrow, ncol=ncol, & - alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE OrthogonalBasis_Line1 - -!---------------------------------------------------------------------------- -! OrthogonalBasis_Line1_ -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasis_Line1_ -LOGICAL(LGT) :: isok, abool -#ifdef DEBUG_VER -#endif - -CHARACTER(1) :: astr -REAL(DFP) :: x(SIZE(xij, 2)) - -nrow = SIZE(xij, 2) -ncol = order + 1 - -#ifdef DEBUG_VER - -ans(1:nrow, 1:ncol) = 0.0_DFP - -isok = basisType .EQ. polyopt%Jacobi - -IF (isok) THEN - abool = (.NOT. PRESENT(alpha)) .OR. (.NOT. PRESENT(beta)) - - IF (abool) THEN - CALL Errormsg(routine="OrthogonalBasis_Line1()", & - msg="alpha and beta should be present for basisType=Jacobi", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -END IF - -isok = basisType .EQ. polyopt%Ultraspherical -IF (isok) THEN - - abool = .NOT. PRESENT(lambda) - - IF (abool) THEN - CALL Errormsg(routine="OrthogonalBasis_Line1()", file=__FILE__, & - msg="lambda should be present for basisType=Ultraspherical", & - line=__LINE__, unitno=stderr) - RETURN - END IF - -END IF - -#endif - -astr = UpperCase(refLine(1:1)) - -SELECT CASE (astr) -CASE ("U") - CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=nrow) - CALL EvalAllOrthopol_(n=order, x=x, orthopol=basisType, alpha=alpha, & - beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) - -CASE ("B") - CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, & - alpha=alpha, beta=beta, lambda=lambda, ans=ans, & - nrow=nrow, ncol=ncol) - -CASE DEFAULT - - ans(1:nrow, 1:ncol) = 0.0_DFP - CALL Errormsg(msg="No case found for refLine.", & - routine="OrthogonalBasis_Line1()", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - -END SELECT - -END PROCEDURE OrthogonalBasis_Line1_ - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Line1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasisGradient_Line1 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL OrthogonalBasisGradient_Line1_(order=order, xij=xij, refline=refline, & - basisType=basisType, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & - alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE OrthogonalBasisGradient_Line1 - -!---------------------------------------------------------------------------- -! OrthogonalBasisGradient_Line -!---------------------------------------------------------------------------- - -MODULE PROCEDURE OrthogonalBasisGradient_Line1_ -CHARACTER(1) :: astr -REAL(DFP) :: x(SIZE(xij, 2)) -INTEGER(I4B) :: ii, jj - -astr = UpperCase(refline(1:1)) -dim1 = SIZE(xij, 2) -dim2 = order + 1 -dim3 = 1 - -SELECT CASE (astr) -CASE ("U") - - CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=dim1) - CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType, & - ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - - DO CONCURRENT(ii=1:dim1, jj=1:dim2) - ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP - END DO - -CASE ("B") - CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, & - ans=ans(:, :, 1), nrow=dim1, ncol=dim2) - -CASE DEFAULT - - ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP - CALL Errormsg(msg="No case found for refline.", & - routine=" OrthogonalBasisGradient_Line1_", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - -END SELECT -END PROCEDURE OrthogonalBasisGradient_Line1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 index 45bbc689c..0e4429343 100644 --- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 +++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 @@ -201,6 +201,8 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE EvalAllOrthopol_ +INTEGER(I4B) :: ii + SELECT CASE (orthopol) CASE (poly%Jacobi) CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, nrow=nrow, & @@ -219,6 +221,17 @@ CASE (poly%UnscaledLobatto) CALL UnscaledLobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol) + +CASE (poly%Monomial) + + nrow = SIZE(x) !! Number of points of evaluation + ncol = n + 1 !! Number of basis functions + + ans(1:nrow, 1) = 1.0_DFP + DO ii = 1, n + ans(1:nrow, ii + 1) = ans(1:nrow, ii) * x(1:nrow) + END DO + END SELECT END PROCEDURE EvalAllOrthopol_ @@ -237,6 +250,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE GradientEvalAllOrthopol_ +INTEGER(I4B) :: indx, ii, jj +REAL(DFP) :: areal + SELECT CASE (orthopol) CASE (poly%Jacobi) ! ans(1:nrow, 1:ncol) = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x) @@ -265,6 +281,18 @@ CALL UnscaledLobattoGradientEvalAll_(n=n, x=x, ans=ans, & nrow=nrow, ncol=ncol) +CASE (poly%Monomial) + nrow = SIZE(x) !! Number of points of evaluation + ncol = n + 1 !! Number of basis functions + + DO jj = 0, n + indx = MAX(jj - 1_I4B, 0_I4B) + areal = REAL(jj, kind=DFP) + DO ii = 1, nrow + ans(ii, jj + 1) = areal * (x(ii)**(indx)) + END DO + END DO + END SELECT END PROCEDURE GradientEvalAllOrthopol_ diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 deleted file mode 100644 index 32243f79b..000000000 --- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,2420 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public 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 -ans(1:2, 1) = [1, 2] -ans(1:2, 2) = [2, 3] -ans(1:2, 3) = [3, 4] -ans(1:2, 4) = [4, 1] -END PROCEDURE FacetConnectivity_Quadrangle - -!---------------------------------------------------------------------------- -! QuadratureNumber_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadratureNumber_Quadrangle -ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1) -ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2) -END PROCEDURE QuadratureNumber_Quadrangle - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -nrow = LagrangeDOF_Quadrangle(order=order) -ALLOCATE (ans(nrow, 2)) -CALL LagrangeDegree_Quadrangle1_(ans=ans, nrow=nrow, ncol=ncol, order=order) -END PROCEDURE LagrangeDegree_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle1_ -CALL LagrangeDegree_Quadrangle2_(ans=ans, p=order, q=order, nrow=nrow, & - ncol=ncol) -END PROCEDURE LagrangeDegree_Quadrangle1_ - -!---------------------------------------------------------------------------- -! LagrangeDegree_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle2 -INTEGER(I4B) :: nrow, ncol - -nrow = LagrangeDOF_Quadrangle(p=p, q=q) -ALLOCATE (ans(nrow, 2)) -CALL LagrangeDegree_Quadrangle2_(ans=ans, nrow=nrow, ncol=ncol, & - p=p, q=q) -END PROCEDURE LagrangeDegree_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDegree_Quadrangle2_ -INTEGER(I4B) :: ii, jj, p1 - -nrow = LagrangeDOF_Quadrangle(p=p, q=q) -ncol = 2 -p1 = p + 1 - -DO CONCURRENT(jj=0:q, ii=0:p) - ans(p1 * jj + ii + 1, 1) = ii - ans(p1 * jj + ii + 1, 2) = jj -END DO - -END PROCEDURE LagrangeDegree_Quadrangle2_ - -!---------------------------------------------------------------------------- -! GetTotalDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalDOF_Quadrangle -ans = (order + 1)**2 -END PROCEDURE GetTotalDOF_Quadrangle - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Quadrangle1 -ans = (order - 1)**2 -END PROCEDURE GetTotalInDOF_Quadrangle1 - -!---------------------------------------------------------------------------- -! GetTotalInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE GetTotalInDOF_Quadrangle2 -ans = (p - 1) * (q - 1) -END PROCEDURE GetTotalInDOF_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Quadrangle1 -ans = (order + 1)**2 -END PROCEDURE LagrangeDOF_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeDOF_Quadrangle2 -ans = (p + 1) * (q + 1) -END PROCEDURE LagrangeDOF_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Quadrangle1 -ans = (order - 1)**2 -END PROCEDURE LagrangeInDOF_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeInDOF_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeInDOF_Quadrangle2 -ans = (p - 1) * (q - 1) -END PROCEDURE LagrangeInDOF_Quadrangle2 - -!---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Quadrangle1 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2_I4B -END IF - -ncol = LagrangeDOF_Quadrangle(order=order) - -ALLOCATE (ans(nrow, ncol)) - -CALL EquidistancePoint_Quadrangle1_(order=order, ans=ans, nrow=nrow, & - ncol=ncol, xij=xij) - -END PROCEDURE EquidistancePoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Quadrangle1_ -CALL EquidistancePoint_Quadrangle2_(p=order, q=order, ans=ans, nrow=nrow, & - ncol=ncol, xij=xij) -END PROCEDURE EquidistancePoint_Quadrangle1_ - -!---------------------------------------------------------------------------- -! EquidistancePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) -ncol = (p + 1) * (q + 1) -ALLOCATE (ans(nrow, ncol)) -CALL EquidistancePoint_Quadrangle2_(p=p, q=q, ans=ans, nrow=nrow, ncol=ncol, & - xij=xij) -END PROCEDURE EquidistancePoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistancePoint_Quadrangle2_ -CALL InterpolationPoint_Quadrangle2_(p=p, q=q, ipType1=Equidistance, & - ipType2=Equidistance, ans=ans, nrow=nrow, ncol=ncol, layout="VEFC", xij=xij) -END PROCEDURE EquidistancePoint_Quadrangle2_ - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Quadrangle1 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2 -END IF - -ncol = LagrangeInDOF_Quadrangle(order=order) - -IF (ncol .EQ. 0) THEN - ALLOCATE (ans(0, 0)) - RETURN -ELSE - ALLOCATE (ans(nrow, ncol)) - ans(1:nrow, 1:ncol) = EquidistanceInPoint_Quadrangle2(p=order, q=order, & - xij=xij) -END IF -END PROCEDURE EquidistanceInPoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! EquidistanceInPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE EquidistanceInPoint_Quadrangle2 -REAL(DFP), ALLOCATABLE :: temp(:, :) -INTEGER(I4B) :: a, b, nrow, ncol - -a = LagrangeDOF_Quadrangle(p=p, q=q) -b = LagrangeInDOF_Quadrangle(p=p, q=q) - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2 -END IF - -ALLOCATE (temp(nrow, a)) - -CALL EquidistancePoint_Quadrangle2_(p=p, q=q, xij=xij, ans=temp, & - nrow=nrow, ncol=ncol) - -IF (b .EQ. 0) THEN - ALLOCATE (ans(0, 0)) -ELSE - ALLOCATE (ans(nrow, b)) - - ans(1:nrow, 1:b) = temp(1:nrow, a - b + 1:) -END IF - -DEALLOCATE (temp) - -END PROCEDURE EquidistanceInPoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle -CALL IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, temp, p, q, 1_I4B) -END PROCEDURE IJ2VEFC_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, & - startNode) - INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) - INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) - INTEGER(I4B), INTENT(IN) :: startNode - - SELECT CASE (startNode) - CASE (1) - edgeConnectivity(1:2, 1) = [1, 2] - edgeConnectivity(1:2, 2) = [2, 3] - edgeConnectivity(1:2, 3) = [3, 4] - edgeConnectivity(1:2, 4) = [4, 1] - pointsOrder = [1, 2, 3, 4] - CASE (2) - edgeConnectivity(1:2, 1) = [2, 3] - edgeConnectivity(1:2, 2) = [3, 4] - edgeConnectivity(1:2, 3) = [4, 1] - edgeConnectivity(1:2, 4) = [1, 2] - pointsOrder = [2, 3, 4, 1] - CASE (3) - edgeConnectivity(1:2, 1) = [3, 4] - edgeConnectivity(1:2, 2) = [4, 1] - edgeConnectivity(1:2, 3) = [1, 2] - edgeConnectivity(1:2, 4) = [2, 3] - pointsOrder = [3, 4, 1, 2] - CASE (4) - edgeConnectivity(1:2, 1) = [4, 1] - edgeConnectivity(1:2, 2) = [1, 2] - edgeConnectivity(1:2, 3) = [2, 3] - edgeConnectivity(1:2, 4) = [3, 4] - pointsOrder = [4, 1, 2, 3] - END SELECT - -END SUBROUTINE GetEdgeConnectivityHelpAntiClock - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, & - startNode) - INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) - INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) - INTEGER(I4B), INTENT(IN) :: startNode - - SELECT CASE (startNode) - CASE (1) - edgeConnectivity(1:2, 1) = [1, 4] - edgeConnectivity(1:2, 2) = [4, 3] - edgeConnectivity(1:2, 3) = [3, 2] - edgeConnectivity(1:2, 4) = [2, 1] - pointsOrder = [1, 4, 3, 2] - CASE (2) - edgeConnectivity(1:2, 1) = [2, 1] - edgeConnectivity(1:2, 2) = [1, 4] - edgeConnectivity(1:2, 3) = [4, 3] - edgeConnectivity(1:2, 4) = [3, 2] - pointsOrder = [2, 1, 4, 3] - CASE (3) - edgeConnectivity(1:2, 1) = [3, 2] - edgeConnectivity(1:2, 2) = [2, 1] - edgeConnectivity(1:2, 3) = [1, 4] - edgeConnectivity(1:2, 4) = [4, 3] - pointsOrder = [3, 2, 1, 4] - CASE (4) - edgeConnectivity(1:2, 1) = [4, 3] - edgeConnectivity(1:2, 2) = [3, 2] - edgeConnectivity(1:2, 3) = [2, 1] - edgeConnectivity(1:2, 4) = [1, 4] - pointsOrder = [4, 3, 2, 1] - END SELECT - -END SUBROUTINE GetEdgeConnectivityHelpClock - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise -! internal variables -INTEGER(I4B) :: cnt, 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(:, :) - -LOGICAL(LGT) :: isok, abool - -! vertices -N = (p + 1) * (q + 1) -cnt = 0 -ll = -1 - -CALL GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, startNode) - -isok = (p .EQ. 0) .AND. (q .EQ. 0) -IF (isok) THEN - temp(1, 1) = xi(1, 1) - temp(2, 1) = eta(1, 1) - RETURN -END IF - -! INFO: This case is p = 0 and q .GE. 1 -abool = (p .EQ. 0) .AND. (q .GE. 1) -IF (abool) THEN - DO jj = 1, q + 1 - cnt = cnt + 1 - temp(1, jj) = xi(1, jj) - temp(2, jj) = eta(1, jj) - END DO - RETURN -END IF - -! INFO: This case is q = 0 and p .GE. 1 -abool = (q .EQ. 0) .AND. (p .GE. 1) -IF (abool) THEN - DO ii = 1, p + 1 - cnt = cnt + 1 - temp(1, ii) = xi(ii, 1) - temp(2, ii) = eta(ii, 1) - END DO - RETURN -END IF - -ij(1, 1) = 1 -ij(2, 1) = 1 - -ij(1, 2) = p + 1 -ij(2, 2) = 1 - -ij(1, 3) = p + 1 -ij(2, 3) = q + 1 - -ij(1, 4) = 1 -ij(2, 4) = q + 1 - -isok = (p .GE. 1) .AND. (q .GE. 1) - -IF (isok) THEN - - DO ii = 1, 4 - cnt = cnt + 1 - jj = pointsOrder(ii) - temp(1, ii) = xi(ij(1, jj), ij(2, jj)) - - temp(2, ii) = eta(ij(1, jj), ij(2, jj)) - - END DO - -END IF - -abool = (p .EQ. 1) .AND. (q .EQ. 1) -IF (abool) RETURN - -isok = (p .GE. 1) .AND. (q .GE. 1) -IF (.NOT. isok) RETURN - -DO iedge = 1, tEdges - p1 = edgeConnectivity(1, iedge) - p2 = edgeConnectivity(2, iedge) - - IF (ij(1, p1) .EQ. ij(1, p2)) THEN - ii1 = ij(1, p1) - ii2 = ii1 - dii = 1 - ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN - ii1 = ij(1, p1) + 1 - ii2 = ij(1, p2) - 1 - dii = 1 - ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN - ii1 = ij(1, p1) - 1 - ii2 = ij(1, p2) + 1 - dii = -1 - END IF - - IF (ij(2, p1) .EQ. ij(2, p2)) THEN - jj1 = ij(2, p1) - jj2 = jj1 - djj = 1 - ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN - jj1 = ij(2, p1) + 1 - jj2 = ij(2, p2) - 1 - djj = 1 - ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN - jj1 = ij(2, p1) - 1 - jj2 = ij(2, p2) + 1 - djj = -1 - END IF - - DO ii = ii1, ii2, dii - DO jj = jj1, jj2, djj - cnt = cnt + 1 - temp(1, cnt) = xi(ii, jj) - temp(2, cnt) = eta(ii, jj) - END DO - END DO -END DO - -! internal nodes -isok = (p .GE. 2) .AND. (q .GE. 2) -IF (.NOT. isok) RETURN - -CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) -CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) -CALL Reallocate(temp_in, 2, SIZE(xi_in)) - -IF (p .LE. 1_I4B) THEN - ii1 = 1 - ii2 = 1 -ELSE - ii1 = 2 - ii2 = p -END IF - -IF (q .LE. 1_I4B) THEN - jj1 = 1 - jj2 = 1 -ELSE - jj1 = 2 - jj2 = q -END IF - -xi_in = xi(ii1:ii2, jj1:jj2) -eta_in = eta(ii1:ii2, jj1:jj2) - -CALL IJ2VEFC_Quadrangle_Clockwise(xi=xi_in, & - eta=eta_in, & - temp=temp_in, & - p=MAX(p - 2, 0_I4B), & - q=MAX(q - 2, 0_I4B), & - startNode=startNode) - -ii1 = cnt + 1 -ii2 = ii1 + SIZE(temp_in, 2) - 1 -temp(1:2, ii1:ii2) = temp_in - -IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) -IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) -IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) - -END PROCEDURE IJ2VEFC_Quadrangle_Clockwise - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise -! internal variables -INTEGER(I4B) :: cnt, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 -INTEGER(I4B), PARAMETER :: tEdges = 4 -INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & - pointsOrder(4) -REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & - temp_in(:, :) -LOGICAL(LGT) :: isok, abool - -! vertices -N = (p + 1) * (q + 1) -cnt = 0 -ll = -1 - -CALL GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, startNode) - -isok = (p .EQ. 0) .AND. (q .EQ. 0) -IF (isok) THEN - temp(1, 1) = xi(1, 1) - temp(2, 1) = eta(1, 1) - RETURN -END IF - -ij(1:2, 1) = [1, 1] -ij(1:2, 2) = [p + 1, 1] -ij(1:2, 3) = [p + 1, q + 1] -ij(1:2, 4) = [1, q + 1] - -isok = (p .GE. 1) .AND. (q .GE. 1) -IF (isok) THEN - DO ii = 1, 4 - cnt = cnt + 1 - jj = pointsOrder(ii) - temp(1:2, ii) = [& - & xi(ij(1, jj), ij(2, jj)), & - & eta(ij(1, jj), ij(2, jj)) & - & ] - END DO - - abool = (p .EQ. 1) .AND. (q .EQ. 1) - IF (abool) RETURN - -ELSE - - DO ii = 1, MIN(p, 1) + 1 - DO jj = 1, MIN(q, 1) + 1 - cnt = cnt + 1 - temp(1:2, cnt) = [& - & xi(ij(1, cnt), ij(2, cnt)), & - & eta(ij(1, cnt), ij(2, cnt))] - END DO - END DO -END IF - -IF (ALL([p, q] .GE. 1_I4B)) THEN - DO iedge = 1, tEdges - p1 = edgeConnectivity(1, iedge) - p2 = edgeConnectivity(2, iedge) - - IF (ij(1, p1) .EQ. ij(1, p2)) THEN - ii1 = ij(1, p1) - ii2 = ii1 - dii = 1 - ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN - ii1 = ij(1, p1) + 1 - ii2 = ij(1, p2) - 1 - dii = 1 - ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN - ii1 = ij(1, p1) - 1 - ii2 = ij(1, p2) + 1 - dii = -1 - END IF - - IF (ij(2, p1) .EQ. ij(2, p2)) THEN - jj1 = ij(2, p1) - jj2 = jj1 - djj = 1 - ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN - jj1 = ij(2, p1) + 1 - jj2 = ij(2, p2) - 1 - djj = 1 - ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN - jj1 = ij(2, p1) - 1 - jj2 = ij(2, p2) + 1 - djj = -1 - END IF - - DO ii = ii1, ii2, dii - DO jj = jj1, jj2, djj - cnt = cnt + 1 - temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] - END DO - END DO - END DO - - ! internal nodes - IF (ALL([p, q] .GE. 2_I4B)) THEN - - CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) - CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) - CALL Reallocate(temp_in, 2, SIZE(xi_in)) - - IF (p .LE. 1_I4B) THEN - ii1 = 1 - ii2 = 1 - ELSE - ii1 = 2 - ii2 = p - END IF - - IF (q .LE. 1_I4B) THEN - jj1 = 1 - jj2 = 1 - ELSE - jj1 = 2 - jj2 = q - END IF - - xi_in = xi(ii1:ii2, jj1:jj2) - eta_in = eta(ii1:ii2, jj1:jj2) - - CALL IJ2VEFC_Quadrangle_AntiClockwise( & - & xi=xi_in, & - & eta=eta_in, & - & temp=temp_in, & - & p=MAX(p - 2, 0_I4B), & - & q=MAX(q - 2, 0_I4B), & - & startNode=startNode) - - ii1 = cnt + 1 - ii2 = ii1 + SIZE(temp_in, 2) - 1 - temp(1:2, ii1:ii2) = temp_in - END IF - -END IF - -IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) -IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) -IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) - -END PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Quadrangle1 -ans = InterpolationPoint_Quadrangle2(p=order, q=order, ipType1=ipType, & - ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda) -END PROCEDURE InterpolationPoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Quadrangle1_ -CALL InterpolationPoint_Quadrangle2_(p=order, q=order, ipType1=ipType, & - ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, & - ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE InterpolationPoint_Quadrangle1_ - -!---------------------------------------------------------------------------- -! InterpolationPoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Quadrangle2 -INTEGER(I4B) :: nrow, ncol - -nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) -ncol = (p + 1) * (q + 1) -ALLOCATE (ans(nrow, ncol)) - -CALL InterpolationPoint_Quadrangle2_(p=p, q=q, ipType1=ipType1, & - ipType2=ipType2, ans=ans, nrow=nrow, ncol=ncol, layout=layout, xij=xij, & - alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & - beta2=beta2, lambda2=lambda2) - -END PROCEDURE InterpolationPoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE InterpolationPoint_Quadrangle2_ -REAL(DFP), PARAMETER :: biunit_xij(2) = [-1.0_DFP, 1.0_DFP] - -REAL(DFP) :: x(p + 1), y(q + 1), xi(p + 1, q + 1), eta(p + 1, q + 1) -INTEGER(I4B) :: ii, jj, kk, tsize - -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2 -END IF - -ncol = (p + 1) * (q + 1) - -CALL InterpolationPoint_Line_(order=p, ipType=ipType1, xij=biunit_xij, & - layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, & - ans=x, tsize=tsize) - -CALL InterpolationPoint_Line_(order=q, ipType=ipType2, xij=biunit_xij, & - layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, & - ans=y, tsize=tsize) - -kk = 0 -DO ii = 1, p + 1 - DO jj = 1, q + 1 - kk = kk + 1 - xi(ii, jj) = x(ii) - ans(1, kk) = x(ii) - - eta(ii, jj) = y(jj) - ans(2, kk) = y(jj) - END DO -END DO - -IF (layout(1:4) .EQ. "VEFC") THEN - CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=ans(1:2, 1:ncol), p=p, q=q) -END IF - -IF (PRESENT(xij)) THEN - CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, 1:ncol), & - x1=xij(:, 1), x2=xij(:, 2), & - x3=xij(:, 3), x4=xij(:, 4), & - ans=ans, nrow=ii, ncol=jj) -END IF - -END PROCEDURE InterpolationPoint_Quadrangle2_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle1 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Quadrangle1_(order=order, i=i, xij=xij, ans=ans, & - tsize=tsize) -END PROCEDURE LagrangeCoeff_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle1_ -REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V -INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv -INTEGER(I4B) :: info, nrow, ncol - -tsize = SIZE(xij, 2) - -ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP -! V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle) -CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Quadrangle, & - ans=V, nrow=nrow, ncol=ncol) -CALL GetLU(A=V, IPIV=ipiv, info=info) -CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle1_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle2 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Quadrangle2_(order=order, i=i, v=v, isVandermonde=.TRUE., & - ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle2_ -REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp -INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv -INTEGER(I4B) :: info - -tsize = SIZE(v, 1) - -vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B -CALL GetLU(A=vtemp, IPIV=ipiv, info=info) -CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle2_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle3 -INTEGER(I4B) :: tsize -CALL LagrangeCoeff_Quadrangle3_(order=order, i=i, v=v, ipiv=ipiv, & - ans=ans, tsize=tsize) -END PROCEDURE LagrangeCoeff_Quadrangle3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle3_ -INTEGER(I4B) :: info -tsize = SIZE(v, 1) -ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP -CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) -END PROCEDURE LagrangeCoeff_Quadrangle3_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle4 -INTEGER(I4B) :: nrow, ncol -CALL LagrangeCoeff_Quadrangle4_(order=order, xij=xij, basisType=basisType, & - alpha=alpha, beta=beta, lambda=lambda, ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE LagrangeCoeff_Quadrangle4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle4_ -INTEGER(I4B) :: basisType0 - -basisType0 = Input(default=Monomial, option=basisType) - -IF (basisType0 .EQ. Heirarchical) THEN - CALL HeirarchicalBasis_Quadrangle2_(p=order, q=order, xij=xij, & - ans=ans, nrow=nrow, ncol=ncol) - CALL GetInvMat(ans(1:nrow, 1:ncol)) - RETURN -END IF - -! ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=order, q=order, & -CALL TensorProdBasis_Quadrangle1_(p=order, q=order, & - xij=xij, basisType1=basisType0, basisType2=basisType0, & - alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & - beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) - -CALL GetInvMat(ans(1:nrow, 1:ncol)) - -END PROCEDURE LagrangeCoeff_Quadrangle4_ - -!---------------------------------------------------------------------------- -! LagrangeCoeff_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle5 -INTEGER(I4B) :: nrow, ncol -CALL LagrangeCoeff_Quadrangle5_(p=p, q=q, xij=xij, basisType1=basisType1, & - basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, & - alpha2=alpha2, beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE LagrangeCoeff_Quadrangle5 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeCoeff_Quadrangle5_ -INTEGER(I4B) :: jj, kk, basisType(2) - -basisType(1) = Input(default=Monomial, option=basisType1) -basisType(2) = Input(default=Monomial, option=basisType2) - -IF (ALL(basisType .EQ. Heirarchical)) THEN - ! ans(1:nrow, 1:ncol) = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij) - CALL HeirarchicalBasis_Quadrangle2_(p=p, q=q, xij=xij, & - ans=ans, nrow=nrow, ncol=ncol) - - CALL GetInvMat(ans(1:nrow, 1:ncol)) - RETURN -END IF - -! ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=p, q=q, xij=xij, & -CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, & - basisType1=basisType(1), alpha1=alpha1, beta1=beta1, lambda1=lambda1, & - basisType2=basisType(2), alpha2=alpha2, beta2=beta2, lambda2=lambda2, & - ans=ans, nrow=nrow, ncol=ncol) - -CALL GetInvMat(ans(1:nrow, 1:ncol)) - -END PROCEDURE LagrangeCoeff_Quadrangle5_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -CALL Dubiner_Quadrangle1_(xij=xij, order=order, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE Dubiner_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle1_ -#define TP size(xij, 2) - -REAL(DFP) :: P1(TP, order + 1), P2(TP, order + 1), temp(TP, 3) - -REAL(DFP) :: alpha, beta - -INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii - -#undef TP - -nrow = SIZE(xij, 2) -ncol = (order + 1) * (order + 2) / 2 - -CALL LegendreEvalAll_(n=order, x=xij(1, :), ans=P1, nrow=indx(1), & - ncol=indx(2)) - -! we do not need x now, so let store (1-y)/2 in x -DO CONCURRENT(ii=1:nrow) - temp(ii, 3) = xij(2, ii) - temp(ii, 1) = 0.5_DFP * (1.0_DFP - temp(ii, 3)) -END DO - -alpha = 0.0_DFP -beta = 0.0_DFP -cnt = 0 - -! temp1 = 0.5 * (1.0 - y) -! temp3 = y - -DO k1 = 0, order - - !! note here temp1 is - !! note here x = 0.5_DFP*(1-y) - DO CONCURRENT(ii=1:nrow) - temp(ii, 2) = temp(ii, 1)**k1 - END DO - - alpha = 2.0_DFP * k1 + 1.0_DFP - - max_k2 = order - k1 - - ! P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) - CALL JacobiEvalAll_(n=max_k2, x=temp(:, 3), alpha=alpha, beta=beta, ans=P2, & - nrow=indx(1), ncol=indx(2)) - - DO k2 = 0, max_k2 - cnt = cnt + 1 - - DO CONCURRENT(ii=1:nrow) - ans(ii, cnt) = P1(ii, k1 + 1) * temp(ii, 2) * P2(ii, k2 + 1) - END DO - END DO - -END DO - -END PROCEDURE Dubiner_Quadrangle1_ - -!---------------------------------------------------------------------------- -! DubinerGradient_Quadrangle1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DubinerGradient_Quadrangle1 -INTEGER(I4B) :: s(3) -CALL DubinerGradient_Quadrangle1_(xij=xij, order=order, ans=ans, & - tsize1=s(1), tsize2=s(2), tsize3=s(3)) -END PROCEDURE DubinerGradient_Quadrangle1 - -!---------------------------------------------------------------------------- -! DubinerGradient_Quadrangle1 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE DubinerGradient_Quadrangle1_ -REAL(DFP), DIMENSION(SIZE(xij, 2), order + 1) :: P1, P2, dP1, dP2 -REAL(DFP), DIMENSION(SIZE(xij, 2)) :: avec, bvec, x, y -REAL(DFP) :: alpha, beta, areal -INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii - -tsize1 = SIZE(xij, 2) -tsize2 = (order + 1) * (order + 2) / 2 -tsize3 = 2 - -x = xij(1, :) -y = xij(2, :) - -! P1 = LegendreEvalAll(n=order, x=x) -CALL LegendreEvalAll_(n=order, x=x, ans=P1, nrow=indx(1), ncol=indx(2)) - -! dP1 = LegendreGradientEvalAll(n=order, x=x) -CALL LegendreGradientEvalAll_(n=order, x=x, ans=dP1, nrow=indx(1), & - ncol=indx(2)) - -! we do not need x now, so let store (1-y)/2 in x -x = 0.5_DFP * (1.0_DFP - y) -alpha = 1.0_DFP -beta = 0.0_DFP -cnt = 0 - -DO k1 = 0, order - bvec = x**(MAX(k1 - 1_I4B, 0_I4B)) - avec = x * bvec - alpha = 2.0_DFP * k1 + 1.0_DFP - - max_k2 = order - k1 - - CALL JacobiEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, & - ans=P2, nrow=indx(1), ncol=indx(2)) - - CALL JacobiGradientEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, & - ans=dP2, nrow=indx(1), ncol=indx(2)) - - areal = REAL(k1, DFP) - - DO k2 = 0, max_k2 - cnt = cnt + 1 - - DO CONCURRENT(ii=1:tsize1) - ans(ii, cnt, 1) = dP1(ii, k1 + 1) * avec(ii) * P2(ii, k2 + 1) - ans(ii, cnt, 2) = P1(ii, k1 + 1) * bvec(ii) * & - (x(ii) * dP2(ii, k2 + 1) - 0.5_DFP * areal * P2(ii, k2 + 1)) - END DO - - END DO - -END DO -END PROCEDURE DubinerGradient_Quadrangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL Dubiner_Quadrangle2_(x=x, y=y, order=order, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE Dubiner_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE Dubiner_Quadrangle2_ -REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) -INTEGER(I4B) :: ii, jj, cnt - -xij = 0.0_DFP -cnt = 0 -DO ii = 1, SIZE(x) - DO jj = 1, SIZE(y) - cnt = cnt + 1 - xij(1, cnt) = x(ii) - xij(2, cnt) = y(jj) - END DO -END DO -CALL Dubiner_Quadrangle1_(order=order, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE Dubiner_Quadrangle2_ - -!---------------------------------------------------------------------------- -! TensorProdOrthoPol_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol, basisType1=basisType1, basisType2=basisType2, & - alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & - beta2=beta2, lambda2=lambda2) -END PROCEDURE TensorProdBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! TensorProdBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle1_ -REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: k1, k2, ii - -nrow = SIZE(xij, 2) -ncol = (p + 1) * (q + 1) - -CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & - basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, & - nrow=k1, ncol=k2) - -CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & - basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, & - nrow=k1, ncol=k2) - -DO CONCURRENT(k1=1:p + 1, k2=1:q + 1, ii=1:nrow) - ans(ii, (k2 - 1) * (p + 1) + k1) = P1(ii, k1) * Q1(ii, k2) -END DO - -END PROCEDURE TensorProdBasis_Quadrangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL TensorProdBasis_Quadrangle2_(p=p, q=q, x=x, y=y, ans=ans, nrow=nrow, & - ncol=ncol, basisType1=basisType1, basisType2=basisType2, & - alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & - beta2=beta2, lambda2=lambda2) -END PROCEDURE TensorProdBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasis_Quadrangle2_ -REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) -INTEGER(I4B) :: ii, jj - -nrow = SIZE(x) -ncol = SIZE(y) - -DO CONCURRENT(ii=1:nrow, jj=1:ncol) - xij(1, ncol * (ii - 1) + jj) = x(ii) - xij(2, ncol * (ii - 1) + jj) = y(jj) -END DO - -CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, basisType1=basisType1, & - basisType2=basisType2, alpha1=alpha1, alpha2=alpha2, beta1=beta1, & - beta2=beta2, lambda1=lambda1, lambda2=lambda2, & - ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE TensorProdBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -CALL VertexBasis_Quadrangle1_(x=x, y=y, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE VertexBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle1_ -nrow = SIZE(x) -ncol = 4 -ans(1:nrow, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y) -ans(1:nrow, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y) -ans(1:nrow, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y) -ans(1:nrow, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) -END PROCEDURE VertexBasis_Quadrangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE VertexBasis_Quadrangle3_(L1, L2, ans, nrow, ncol) - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), 4) - !! ans(:,v1) basis function of vertex v1 at all points - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - - !! internal variable - INTEGER(I4B) :: ii - - nrow = SIZE(L1, 1) - ncol = 4 - - DO CONCURRENT(ii=1:nrow) - ans(ii, 1) = L1(ii, 0) * L2(ii, 0) - ans(ii, 2) = L1(ii, 1) * L2(ii, 0) - ans(ii, 3) = L1(ii, 1) * L2(ii, 1) - ans(ii, 4) = L1(ii, 0) * L2(ii, 1) - END DO - -END SUBROUTINE VertexBasis_Quadrangle3_ - -!---------------------------------------------------------------------------- -! VertexBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL VertexBasis_Quadrangle2_(xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE VertexBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VertexBasis_Quadrangle2_ -CALL VertexBasis_Quadrangle1_(x=xij(1, :), y=xij(2, :), ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE VertexBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! VertexBasisGradient_Quadrangle2_ -!---------------------------------------------------------------------------- - -PURE SUBROUTINE VertexBasisGradient_Quadrangle2_(L1, L2, dL1, dL2, & - ans, dim1, dim2, dim3) - REAL(DFP), INTENT(IN) :: L1(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - REAL(DFP), INTENT(IN) :: L2(1:, 0:) - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP), INTENT(IN) :: dL1(1:, 0:) - !! L1 Lobatto polynomial evaluated at x coordinates - REAL(DFP), INTENT(IN) :: dL2(1:, 0:) - !! L2 is Lobatto polynomial evaluated at y coordinates - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - !! dim1= SIZE(L1, 1) - !! dim2= 4 - !! dim3 = 2 - !! Gradient of vertex basis - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - - dim1 = SIZE(L1, 1) - dim2 = 4 - dim3 = 2 - ans(1:dim1, 1, 1) = dL1(1:dim1, 0) * L2(1:dim1, 0) - ans(1:dim1, 2, 1) = dL1(1:dim1, 1) * L2(1:dim1, 0) - ans(1:dim1, 3, 1) = dL1(1:dim1, 1) * L2(1:dim1, 1) - ans(1:dim1, 4, 1) = dL1(1:dim1, 0) * L2(1:dim1, 1) - ans(1:dim1, 1, 2) = L1(1:dim1, 0) * dL2(1:dim1, 0) - ans(1:dim1, 2, 2) = L1(1:dim1, 1) * dL2(1:dim1, 0) - ans(1:dim1, 3, 2) = L1(1:dim1, 1) * dL2(1:dim1, 1) - ans(1:dim1, 4, 2) = L1(1:dim1, 0) * dL2(1:dim1, 1) - -END SUBROUTINE VertexBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! VerticalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle -INTEGER(I4B) :: nrow, ncol -CALL VerticalEdgeBasis_Quadrangle_(qe1=qe1, qe2=qe2, x=x, y=y, ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE VerticalEdgeBasis_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE VerticalEdgeBasis_Quadrangle_ -! REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) -INTEGER(I4B) :: maxQ, aint, bint -INTEGER(I4B), PARAMETER :: maxP = 1, orient = 1 -REAL(DFP), ALLOCATABLE :: L2(:, :), L1(:, :) - -maxQ = MAX(qe1, qe2) - -aint = SIZE(y) -nrow = SIZE(x) -ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) - -CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) -CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) - -CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans, & - nrow=nrow, ncol=ncol, qe1Orient=orient, qe2Orient=orient) - -DEALLOCATE (L2, L1) - -END PROCEDURE VerticalEdgeBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, & - ans, nrow, ncol, qe1Orient, qe2Orient) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), qe1 + qe2 - 2) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written to ans - INTEGER(I4B), INTENT(IN), OPTIONAL :: qe1Orient, qe2Orient - !! orientation fo left and write vertical edge - !! it can be 1 or -1 - - INTEGER(I4B) :: k2, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(-qe1Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & - ! in master element - o2 = REAL(qe2Orient, kind=DFP) - - nrow = SIZE(L1, 1) - ncol = qe1 + qe2 - 2 - cnt = qe1 - 1 - - !! left vertical - DO CONCURRENT(k2=2:qe1, ii=1:nrow) - ans(ii, k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2) - END DO - - !! right vertical - DO CONCURRENT(k2=2:qe2, ii=1:nrow) - ans(ii, cnt + k2 - 1) = (o2**k2) * L1(ii, 1) * L2(ii, k2) - END DO - -END SUBROUTINE VerticalEdgeBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! VerticalEdgeBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Returns the vertex basis functions on biunit quadrangle - -PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3, qe1Orient, qe2Orient) - INTEGER(I4B), INTENT(IN) :: qe1 - !! order on left vertical edge (e1), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qe2 - !! order on right vertical edge(e2), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - !! Lobatto polynomials in x and y direction. - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - !! dim1=SIZE(L1, 1) - !! dim2=qe1 + qe2 - 2 - !! dim3= 2 - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! range of data written to ans - INTEGER(I4B), INTENT(IN) :: qe1Orient, qe2Orient - !! orientation fo left and write vertical edge - !! it can be 1 or -1 - - INTEGER(I4B) :: k2, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(-qe1Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the left edge is oriented downwards & - ! in master element - o2 = REAL(qe2Orient, kind=DFP) - - dim1 = SIZE(L1, 1) - dim2 = qe1 + qe2 - 2 - dim3 = 2 - - cnt = qe1 - 1 - - DO CONCURRENT(k2=2:qe1, ii=1:dim1) - ans(ii, k2 - 1, 1) = (o1**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2) - ans(ii, k2 - 1, 2) = (o1**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2) - END DO - - DO CONCURRENT(k2=2:qe2, ii=1:dim1) - ans(ii, cnt + k2 - 1, 1) = (o2**(k2 - 1)) * dL1(ii, 1) * L2(ii, k2) - ans(ii, cnt + k2 - 1, 2) = (o2**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2) - END DO - -END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle -INTEGER(I4B) :: nrow, ncol -CALL HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, ans, nrow, ncol) -END PROCEDURE HorizontalEdgeBasis_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle_ -INTEGER(I4B) :: maxP, aint, bint -INTEGER(I4B), PARAMETER :: maxQ = 1, orient = 1 - -REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) - -maxP = MAX(pe3, pe4) - -nrow = SIZE(x) -aint = SIZE(y) - -ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) - -CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) -CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) - -CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans, nrow=nrow, ncol=ncol, pe3Orient=orient, pe4Orient=orient) - -DEALLOCATE (L1, L2) - -END PROCEDURE HorizontalEdgeBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle2_(pe3, pe4, L1, L2, & - ans, nrow, ncol, pe3Orient, pe4Orient) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), pe3 + pe4 - 2) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and columns written to ans - INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient - !! orientaion of bottom and top edge - - INTEGER(I4B) :: k1, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(pe3Orient, kind=DFP) - - o2 = REAL(-pe4Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & - ! in master element - - nrow = SIZE(L1, 1) - ncol = pe3 + pe4 - 2 - cnt = pe3 - 1 - - !! bottom edge - DO CONCURRENT(k1=2:pe3, ii=1:nrow) - ans(ii, k1 - 1) = (o1**k1) * L1(ii, k1) * L2(ii, 0) - END DO - - !! top edge - DO CONCURRENT(k1=2:pe4, ii=1:nrow) - ans(ii, cnt + k1 - 1) = (o2**k1) * L1(ii, k1) * L2(ii, 1) - END DO - -END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! HorizontalEdgeBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, & - L1, L2, dL1, dL2, ans, dim1, dim2, dim3, pe3Orient, pe4Orient) - INTEGER(I4B), INTENT(IN) :: pe3 - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: pe4 - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! dim1 = SIZE(L1, 1) - !! dim2 = pe3 + pe4 - 2 - !! dim3 = 2 - INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient - !! orientation of bottom and top horizontal edge - - !! internal variable - INTEGER(I4B) :: k1, cnt, ii - REAL(DFP) :: o1, o2 - - o1 = REAL(pe3Orient, kind=DFP) - - o2 = REAL(-pe4Orient, kind=DFP) - ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards & - ! in master element - - dim1 = SIZE(L1, 1) - dim2 = pe3 + pe4 - 2 - dim3 = 2 - cnt = pe3 - 1 - - !! bottom edge - DO CONCURRENT(k1=2:pe3, ii=1:dim1) - ans(ii, k1 - 1, 1) = (o1**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0) - ans(ii, k1 - 1, 2) = (o1**(k1 - 1)) * L1(ii, k1) * dL2(ii, 0) - END DO - - !! top edge - DO CONCURRENT(k1=2:pe4, ii=1:dim1) - ans(ii, cnt + k1 - 1, 1) = (o2**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1) - ans(ii, cnt + k1 - 1, 2) = (o2**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1) - END DO - -END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! CellBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle -INTEGER(I4B) :: nrow, ncol -CALL CellBasis_Quadrangle_(pb=pb, qb=qb, x=x, y=y, ans=ans, nrow=nrow, & - ncol=ncol) -END PROCEDURE CellBasis_Quadrangle - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE CellBasis_Quadrangle_ -REAL(DFP) :: L1(1:SIZE(x), 0:pb) -REAL(DFP) :: L2(1:SIZE(y), 0:qb) -INTEGER(I4B), PARAMETER :: faceOrient(3) = [1, 1, 1] - -CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=nrow, ncol=ncol) -CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=nrow, ncol=ncol) - -CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, ans=ans, nrow=nrow, & - ncol=ncol, faceOrient=faceOrient) - -END PROCEDURE CellBasis_Quadrangle_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & - faceOrient) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - !! point of evaluation - REAL(DFP), INTENT(INOUT) :: ans(:, :) - !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) - INTEGER(I4B), INTENT(OUT) :: nrow, ncol - !! number of rows and cols written to ans - INTEGER(I4B), INTENT(IN) :: faceOrient(3) - !! face orientation - - !! Internal variables - INTEGER(I4B) :: k1, k2, ii, p, q - REAL(DFP) :: o1, o2 - - nrow = SIZE(L1, 1) - ncol = (pb - 1) * (qb - 1) - - o1 = REAL(faceOrient(1), kind=DFP) - o2 = REAL(faceOrient(2), kind=DFP) - - IF (faceOrient(3) .LT. 0_I4B) THEN - p = qb - q = pb - ELSE - p = pb - q = qb - END IF - - DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) - ans(ii, (q - 1) * (k1 - 2) + k2 - 1) = & - (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2) - END DO - -END SUBROUTINE CellBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! CellBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, & - dL1, dL2, ans, dim1, dim2, dim3, faceOrient) - INTEGER(I4B), INTENT(IN) :: pb - !! order on bottom vertical edge (e3), it should be greater than 1 - INTEGER(I4B), INTENT(IN) :: qb - !! order on top vertical edge(e4), it should be greater than 1 - REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) - REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) - REAL(DFP), INTENT(INOUT) :: ans(:, :, :) - INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 - !! dim1=SIZE(L1, 1) - !! dim2=(pb - 1) * (qb - 1) - !! dim3=2 - INTEGER(I4B), INTENT(IN) :: faceOrient(3) - - !! internal variables - INTEGER(I4B) :: k1, k2, ii, p, q - REAL(DFP) :: o1, o2 - - dim1 = SIZE(L1, 1) - dim2 = (pb - 1) * (qb - 1) - dim3 = 2 - - o1 = REAL(faceOrient(1), kind=DFP) - o2 = REAL(faceOrient(2), kind=DFP) - - IF (faceOrient(3) .LT. 0_I4B) THEN - p = qb - q = pb - ELSE - p = pb - q = qb - END IF - - DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1) - - ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 1) = & - (o1**(k1 - 1)) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) - - ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 2) = & - (o1**k1) * (o2**(k2 - 1)) * L1(ii, k1) * dL2(ii, k2) - - END DO - -END SUBROUTINE CellBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 -INTEGER(I4B) :: nrow, ncol -CALL HeirarchicalBasis_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ -INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] -CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, & - qe2=qe2, xij=xij, pe3Orient=orient, pe4Orient=orient, & - qe1Orient=orient, qe2Orient=orient, faceOrient=faceOrient, ans=ans, & - nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle1_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 -INTEGER(I4B) :: nrow, ncol - -CALL HeirarchicalBasis_Quadrangle1_(pb=p, pe3=p, pe4=p, & - qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle2 - -!---------------------------------------------------------------------------- -! HeirarchicalBasis_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle2_ -CALL HeirarchicalBasis_Quadrangle1_(pb=p, pe3=p, pe4=p, & - qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol) -END PROCEDURE HeirarchicalBasis_Quadrangle2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle3 -INTEGER(I4B) :: nrow, ncol - -nrow = SIZE(xij, 2) -ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 - -ALLOCATE (ans(1:nrow, 1:ncol)) - -CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, pe3Orient=pe3Orient, pe4Orient=pe4Orient, & - qe1Orient=qe1Orient, qe2Orient=qe2Orient, faceOrient=faceOrient, & - ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE HeirarchicalBasis_Quadrangle3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_ -INTEGER(I4B) :: a, b, indx(4), maxP, maxQ -REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) -LOGICAL(LGT) :: isok, abool - -nrow = SIZE(xij, 2) -! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 -ncol = 0 - -maxP = MAX(pe3, pe4, pb) -maxQ = MAX(qe1, qe2, qb) - -ALLOCATE (L1(1:nrow, 0:maxP), L2(1:nrow, 0:maxQ)) - -CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) -CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) - -! Vertex basis function -CALL VertexBasis_Quadrangle3_(L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2)) - -ncol = indx(2) - -! Edge basis function -isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) -IF (isok) THEN - CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), qe1Orient=qe1Orient, & - qe2Orient=qe2Orient) - - ncol = ncol + indx(2) -END IF - -! Edge basis function -isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) -IF (isok) THEN - CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), pe3Orient=pe3Orient, & - pe4Orient=pe4Orient) - ncol = ncol + indx(2) -END IF - -! Cell basis function -isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) -IF (isok) THEN - CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, & - ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient) - ncol = ncol + indx(2) -END IF - -DEALLOCATE (L1, L2) - -END PROCEDURE HeirarchicalBasis_Quadrangle3_ - -!---------------------------------------------------------------------------- -! LagrangeEvallAll_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle1 -INTEGER(I4B) :: tsize -CALL LagrangeEvalAll_Quadrangle1_(order=order, x=x, xij=xij, & - ans=ans, tsize=tsize, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE LagrangeEvalAll_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle1_ -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, degree(SIZE(xij, 2), 2), indx(2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & - x21(2, 1) - -tsize = SIZE(xij, 2) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, & - beta=beta, lambda=lambda, & - ans=coeff, nrow=indx(1), ncol=indx(2)) - END IF - - ! coeff0 = TRANSPOSE(coeff) - coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) - -ELSE - - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff0, nrow=indx(1), ncol=indx(2)) - - ! coeff0 = TRANSPOSE(coeff0) - -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & - ncol=indx(2)) -#ifdef DEBUG_VER - - IF (tsize .NE. SIZE(degree, 1)) THEN - CALL Errormsg(msg="tdof is not same as size(degree,1)", & - routine="LagrangeEvalAll_Quadrangle1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -#endif - - DO ii = 1, tsize - indx(1:2) = degree(ii, 1:2) - xx(1, ii) = x(1)**indx(1) * x(2)**indx(2) - END DO - -CASE (Heirarchical) - - ! xx = HeirarchicalBasis_Quadrangle( & - x21(1:2, 1) = x(1:2) - CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, & - xij=x21, ans=xx, nrow=indx(1), ncol=indx(2)) - -CASE DEFAULT - - x21(1:2, 1) = x(1:2) - CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x21, & - basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & - nrow=indx(1), ncol=indx(2)) - -END SELECT - -DO CONCURRENT(ii=1:tsize) - ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) -END DO - -END PROCEDURE LagrangeEvalAll_Quadrangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle2 -INTEGER(I4B) :: nrow, ncol -CALL LagrangeEvalAll_Quadrangle2_(order=order, x=x, xij=xij, ans=ans, & - nrow=nrow, ncol=ncol, coeff=coeff, firstCall=firstCall, & - basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) -END PROCEDURE LagrangeEvalAll_Quadrangle2 - -!---------------------------------------------------------------------------- -! LagrangeEvalAll_Quadrangle2 -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeEvalAll_Quadrangle2_ -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, jj, basisType0, indx(2), degree(SIZE(xij, 2), 2) -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) ,xx(SIZE(x, 2), SIZE(xij, 2)), & - aval - -nrow = SIZE(x, 2) -ncol = SIZE(xij, 2) - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - - ! coeff = LagrangeCoeff_Quadrangle(& - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, & - ans=coeff, nrow=indx(1), ncol=indx(2)) - END IF - - coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol) - -ELSE - - ! coeff0 = LagrangeCoeff_Quadrangle(& - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, & - nrow=indx(1), ncol=indx(2)) - -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - ! degree = LagrangeDegree_Quadrangle(order=order) - CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & - ncol=indx(2)) - -#ifdef DEBUG_VER - IF (ncol .NE. SIZE(degree, 1)) THEN - CALL Errormsg(msg="tdof is not same as size(degree,1)", & - routine="LagrangeEvalAll_Quadrangle1", file=__FILE__, line=__LINE__, & - unitno=stderr) - RETURN - END IF -#endif - - DO ii = 1, ncol - indx(1:2) = degree(ii, 1:2) - DO jj = 1, nrow - aval = x(1, jj)**indx(1) * x(2, jj)**indx(2) - xx(jj, ii) = aval - END DO - END DO - -CASE (Heirarchical) - - ! xx = HeirarchicalBasis_Quadrangle( & - CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & - nrow=indx(1), ncol=indx(2)) - -CASE DEFAULT - - ! xx = TensorProdBasis_Quadrangle( & - CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x, & - basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & - nrow=indx(1), ncol=indx(2)) - -END SELECT - -! ans = MATMUL(xx, coeff0) -CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0) - -END PROCEDURE LagrangeEvalAll_Quadrangle2_ - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle1 -INTEGER(I4B) :: nips(1), nrow, ncol - -nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) - -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2) -ELSE - nrow = 2 -END IF - -nrow = nrow + 1 -ncol = nips(1) * nips(1) - -ALLOCATE (ans(1:nrow, 1:ncol)) - -CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, & - quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, & - xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & - beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE QuadraturePoint_Quadrangle1 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle2 -INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol - -nipsx(1) = QuadratureNumber_Line(order=p, quadType=quadType1) -nipsy(1) = QuadratureNumber_Line(order=q, quadType=quadType2) - -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2) -ELSE - nrow = 2 -END IF - -nrow = nrow + 1 -ncol = nipsx(1) * nipsy(1) - -ALLOCATE (ans(1:nrow, 1:ncol)) - -CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, & - quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, & - xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & - beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE QuadraturePoint_Quadrangle2 - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle3 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2) -ELSE - nrow = 2 -END IF - -nrow = nrow + 1 -ncol = nips(1) * nips(1) - -ALLOCATE (ans(1:nrow, 1:ncol)) - -CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, & - quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, & - xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & - beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE QuadraturePoint_Quadrangle3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle4 -INTEGER(I4B) :: nrow, ncol - -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2) -ELSE - nrow = 2 -END IF - -nrow = nrow + 1 -ncol = nipsx(1) * nipsy(1) - -ALLOCATE (ans(1:nrow, 1:ncol)) - -CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, & - quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, & - xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & - beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) - -END PROCEDURE QuadraturePoint_Quadrangle4 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE QuadraturePoint_Quadrangle1_ -! internal variables -REAL(DFP) :: x(4, nipsx(1)), y(2, nipsy(1)), areal -INTEGER(I4B) :: ii, jj, kk, nsd, np, nq -CHARACTER(len=1) :: astr - -REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2]) - -IF (PRESENT(xij)) THEN - nsd = MAX(SIZE(xij, 1), 2) -ELSE - nsd = 2 -END IF - -! CALL Reallocate(ans, nsd + 1_I4B, np * nq) -nrow = nsd + 1 -ncol = nipsx(1) * nipsy(1) - -CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadType1, xij=x12, & - layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, ans=x, & - nrow=ii, ncol=np) - -CALL QuadraturePoint_Line_(nips=nipsy, quadType=quadType2, xij=x12, & - layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, ans=y, & - nrow=ii, ncol=nq) - -DO CONCURRENT(ii=1:np, jj=1:nq) - ans(1, nq * (ii - 1) + jj) = x(1, ii) - ans(2, nq * (ii - 1) + jj) = y(1, jj) - ans(nrow, nq * (ii - 1) + jj) = x(2, ii) * y(2, jj) -END DO - -IF (PRESENT(xij)) THEN - CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, :), x1=xij(:, 1), & - x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, nrow=ii, ncol=jj) - - areal = JacobianQuadrangle(from="BIUNIT", to="QUADRANGLE", xij=xij) - - DO CONCURRENT(ii=1:ncol) - ans(nrow, ii) = ans(nrow, ii) * areal - END DO - - RETURN -END IF - -astr = UpperCase(refQuadrangle(1:1)) -IF (astr .EQ. "U") THEN - CALL FromBiUnitQuadrangle2UnitQuadrangle_(xin=ans(1:2, :), ans=ans, & - nrow=ii, ncol=jj) - - areal = JacobianQuadrangle(from="BIUNIT", to="UNIT", xij=xij) - - DO CONCURRENT(ii=1:ncol) - ans(nrow, ii) = ans(nrow, ii) * areal - END DO - - RETURN -END IF - -END PROCEDURE QuadraturePoint_Quadrangle1_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL LagrangeGradientEvalAll_Quadrangle1_(order=order, x=x, xij=xij, & - ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, coeff=coeff, & - firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) -END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 - -!---------------------------------------------------------------------------- -! LagrangeGradientEvalAll_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ -LOGICAL(LGT) :: firstCall0 -INTEGER(I4B) :: ii, basisType0, ai, bi, indx(3), degree(SIZE(xij, 2), 2), & - jj -REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & - xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br, areal, breal - -dim1 = SIZE(x, 2) -dim2 = SIZE(xij, 2) -dim3 = 2 - -basisType0 = INPUT(default=Monomial, option=basisType) -firstCall0 = INPUT(default=.TRUE., option=firstCall) - -IF (PRESENT(coeff)) THEN - - IF (firstCall0) THEN - - ! coeff = LagrangeCoeff_Quadrangle(& - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, & - basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff, & - nrow=indx(1), ncol=indx(2)) - END IF - - coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) - -ELSE - - ! coeff0 = LagrangeCoeff_Quadrangle(& - CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, basisType=basisType0, & - alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=indx(1), & - ncol=indx(2)) -END IF - -SELECT CASE (basisType0) - -CASE (Monomial) - - ! degree = LagrangeDegree_Quadrangle(order=order) - CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & - ncol=indx(2)) - -#ifdef DEBUG_VER - - IF (dim2 .NE. SIZE(degree, 1)) THEN - CALL Errormsg(msg="tdof is not same as size(degree,1)", & - routine="LagrangeEvalAll_Quadrangle1", & - file=__FILE__, line=__LINE__, unitno=stderr) - RETURN - END IF - -#endif - - DO ii = 1, dim2 - ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) - bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) - ar = REAL(degree(ii, 1_I4B), DFP) - br = REAL(degree(ii, 2_I4B), DFP) - - indx(1:2) = degree(ii, 1:2) - - DO jj = 1, dim1 - areal = (ar * x(1, jj)**ai) * x(2, jj)**indx(2) - breal = x(1, jj)**indx(1) * (br * x(2, jj)**bi) - xx(jj, ii, 1) = areal - xx(jj, ii, 2) = breal - - END DO - - END DO - -CASE (Heirarchical) - - ! xx = HeirarchicalBasisGradient_Quadrangle( & - CALL HeirarchicalBasisGradient_Quadrangle_(p=order, q=order, xij=x, & - ans=xx, dim1=indx(1), dim2=indx(2), dim3=indx(3)) - -CASE DEFAULT - - ! xx = OrthogonalBasisGradient_Quadrangle( & - CALL OrthogonalBasisGradient_Quadrangle_(p=order, q=order, xij=x, & - basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & - lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & - dim1=indx(1), dim2=indx(2), dim3=indx(3)) - -END SELECT - -DO ii = 1, 2 - ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) - ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0) -END DO - -END PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL HeirarchicalBasisGradient_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) -END PROCEDURE HeirarchicalBasisGradient_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ -INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(3) = [1, 1, 1] - -CALL HeirarchicalBasisGradient_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, qe1Orient=orient, qe2Orient=orient, & - pe3Orient=orient, pe4Orient=orient, faceOrient=faceOrient, ans=ans, & - dim1=dim1, dim2=dim2, dim3=dim3) - -END PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ - -!---------------------------------------------------------------------------- -! HeirarchicalBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL HeirarchicalBasisGradient_Quadrangle2_(p=p, q=q, xij=xij, ans=ans, & - dim1=dim1, dim2=dim2, dim3=dim3) -END PROCEDURE HeirarchicalBasisGradient_Quadrangle2 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2_ -CALL HeirarchicalBasisGradient_Quadrangle1_(pb=p, pe3=p, pe4=p, qb=q, qe1=q, & - qe2=q, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) -END PROCEDURE HeirarchicalBasisGradient_Quadrangle2_ - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle3 -INTEGER(I4B) :: dim1, dim2, dim3 -dim1 = SIZE(xij, 2) -dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 -dim3 = 2 - -ALLOCATE (ans(1:dim1, 1:dim2, 1:dim3)) - -CALL HeirarchicalBasisGradient_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, & - qe1=qe1, qe2=qe2, xij=xij, qe1Orient=qe1Orient, qe2Orient=qe2Orient, & - pe3Orient=pe3Orient, pe4Orient=pe4Orient, faceOrient=faceOrient, ans=ans, & - dim1=dim1, dim2=dim2, dim3=dim3) - -END PROCEDURE HeirarchicalBasisGradient_Quadrangle3 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ -INTEGER(I4B) :: maxP, maxQ, indx(3) -REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :), dL1(:, :), dL2(:, :) -LOGICAL(LGT) :: isok - -dim1 = SIZE(xij, 2) -dim2 = 0 -dim3 = 2 - -maxP = MAX(pe3, pe4, pb) -maxQ = MAX(qe1, qe2, qb) - -ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), & - dL1(1:dim1, 0:maxP), dL2(1:dim1, 0:maxQ)) - -CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) -CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) -CALL LobattoGradientEvalAll_(n=maxP, x=xij(1, :), ans=dL1, nrow=indx(1), & - ncol=indx(2)) -CALL LobattoGradientEvalAll_(n=maxQ, x=xij(2, :), ans=dL2, nrow=indx(1), & - ncol=indx(2)) - -CALL VertexBasisGradient_Quadrangle2_(L1=L1, L2=L2, dL1=dL1, dL2=dL2, & - ans=ans, dim1=indx(1), dim2=indx(2), dim3=indx(3)) - -dim2 = indx(2) - -isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B) - -IF (isok) THEN - CALL VerticalEdgeBasisGradient_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, & - L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), qe1Orient=qe1Orient, qe2Orient=qe2Orient) - - dim2 = dim2 + indx(2) - -END IF - -! Edge basis function -isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B) -IF (isok) THEN - CALL HorizontalEdgeBasisGradient_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, & - L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), pe3Orient=pe3Orient, pe4Orient=pe4Orient) - dim2 = dim2 + indx(2) -END IF - -! Cell basis function -isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) -IF (isok) THEN - CALL CellBasisGradient_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, dL1=dL1, & - dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), & - dim2=indx(2), dim3=indx(3), faceOrient=faceOrient) - - dim2 = dim2 + indx(2) -END IF - -DEALLOCATE (L1, L2, dL1, dL2) - -END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ - -!---------------------------------------------------------------------------- -! TensorProdBasisGradient_Quadrangle -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 -INTEGER(I4B) :: dim1, dim2, dim3 -CALL TensorProdBasisGradient_Quadrangle1_(p=p, q=q, xij=xij, ans=ans, & - dim1=dim1, dim2=dim2, dim3=dim3, basisType1=basisType1, & - basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, & - alpha2=alpha2, beta2=beta2, lambda2=lambda2) -END PROCEDURE TensorProdBasisGradient_Quadrangle1 - -!---------------------------------------------------------------------------- -! -!---------------------------------------------------------------------------- - -MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ -REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) -REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1) -INTEGER(I4B) :: k1, k2, cnt, indx(3) - -dim1 = SIZE(xij, 2) -dim2 = (p + 1) * (q + 1) -dim3 = 2 - -! P1 -CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & - basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, & - ans=P1, nrow=indx(1), ncol=indx(2)) - -! Q1 = BasisEvalAll_Line( & -CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & - basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, & - nrow=indx(1), ncol=indx(2)) - -! dP1 = BasisGradientEvalAll_Line( & -CALL BasisGradientEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", & - basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, ans=dP1, & - nrow=indx(1), ncol=indx(2)) - -! dQ1 = BasisGradientEvalAll_Line( & -CALL BasisGradientEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", & - basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=dQ1, & - nrow=indx(1), ncol=indx(2)) - -cnt = 0 - -DO k2 = 1, q + 1 - - DO k1 = 1, p + 1 - cnt = cnt + 1 - ans(1:dim1, cnt, 1) = dP1(1:dim1, k1) * Q1(1:dim1, k2) - ans(1:dim1, cnt, 2) = P1(1:dim1, k1) * dQ1(1:dim1, k2) - END DO - -END DO - -END PROCEDURE TensorProdBasisGradient_Quadrangle1_ - -!---------------------------------------------------------------------------- -! QuadraturePoint_Quadrangle3 -!---------------------------------------------------------------------------- - -END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 deleted file mode 100644 index 353cf8485..000000000 --- a/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90 +++ /dev/null @@ -1,376 +0,0 @@ - -! PURE SUBROUTINE VertexBasis_Triangle2(Lo1, Lo2, ans) -! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) -! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) -! !! coordinates on biunit square -! REAL(DFP), INTENT(INOUT) :: ans(:, :) -! ! ans(SIZE(Lo1, 1), 3) -! !! ans(:,v1) basis function of vertex v1 at all points -! -! INTEGER(I4B) :: ii, tpoints -! -! tpoints = SIZE(ans, 1) -! -! DO CONCURRENT(ii=1:tpoints) -! ans(ii, 1) = Lo1(ii, 0) * Lo2(ii, 0) -! ans(ii, 2) = Lo1(ii, 1) * Lo2(ii, 0) -! ans(ii, 3) = Lo1(ii, 1) * Lo2(ii, 1) + Lo1(ii, 0) * Lo2(ii, 1) -! END DO -! -! END SUBROUTINE VertexBasis_Triangle2 - -!---------------------------------------------------------------------------- -! EdgeBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis on left, right edge of biunit Triangle (internal only) -! -!# Introduction -! -! Evaluate basis functions on left and right edge of biunit Triangle -! -! qe1 and qe2 should be greater than or equal to 2 - -! PURE SUBROUTINE EdgeBasis_Triangle2(pe1, pe2, pe3, L1, L2, Lo1, & -! & Lo2, ans) -! INTEGER(I4B), INTENT(IN) :: pe1 -! !! order on left vertical edge (e1), should be greater than 1 -! INTEGER(I4B), INTENT(IN) :: pe2 -! !! order on right vertical edge(e2), should be greater than 1 -! INTEGER(I4B), INTENT(IN) :: pe3 -! !! order on right vertical edge(e3), should be greater than 1 -! REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) -! !! L1 and L2 are jacobian polynomials -! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(INOUT) :: ans(:, :) -! ! REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 - 3) -! -! INTEGER(I4B) :: maxP, k1, k2, a -! REAL(DFP) :: asign -! -! maxP = MAX(pe1, pe2, pe3) -! ! edge(1) = 1 -> 2 -! a = 0 -! -! DO k1 = 2, pe1 -! ans(:, k1 - 1) = Lo1(:, 0) * Lo1(:, 1) * L1(:, k1 - 2) * (Lo2(:, 0)**k1) -! END DO -! -! ! edge(2) = 2 -> 3 -! a = pe1 - 1 -! DO k2 = 2, pe2 -! ans(:, a + k2 - 1) = Lo1(:, 1) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) -! END DO -! -! ! edge(3) = 3 -> 1 -! a = pe1 - 1 + pe2 - 1 -! DO k2 = 2, pe3 -! asign = (-1.0_DFP)**(k2 - 2) -! ans(:, a + k2 - 1) = asign * Lo1(:, 0) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) -! END DO -! -! END SUBROUTINE EdgeBasis_Triangle2 - -!---------------------------------------------------------------------------- -! CellBasis_Triangle -!---------------------------------------------------------------------------- - -!> author: Vikas Sharma, Ph. D. -! date: 28 Oct 2022 -! summary: Eval basis in the cell of biunit Triangle (internal only) -! -!# Introduction -! -! Evaluate basis functions in the cell of biunit Triangle - -! PURE SUBROUTINE CellBasis_Triangle2(order, L1, eta_ij, & -! & Lo1, Lo2, ans) -! INTEGER(I4B), INTENT(IN) :: order -! !! order of approximation inside the cell, order>2 -! REAL(DFP), INTENT(IN) :: L1(1:, 0:) -! !! lobatto polynomials -! REAL(DFP), INTENT(IN) :: eta_ij(:, :) -! !! coordinates on biunit square -! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(INOUT) :: ans(:, :) -! ! REAL(DFP) :: ans(SIZE(L1, 1), INT((order - 1) * (order - 2) / 2)) -! -! ! FIXME: Remove these arrays, no allocation is our goal -! REAL(DFP) :: P2(SIZE(eta_ij, 2), 0:order) -! REAL(DFP) :: avec(SIZE(eta_ij, 2)), alpha, beta -! INTEGER(I4B) :: k1, k2, max_k2, cnt -! -! alpha = 0.0_DFP -! beta = 1.0_DFP -! cnt = 0 -! -! ! FIXME: Make this loop parallel -! -! DO k1 = 2, order - 1 -! avec = (Lo2(:, 0)**k1) * Lo2(:, 1) * Lo1(:, 0) * Lo1(:, 1) -! alpha = 2.0_DFP * k1 - 1.0_DFP -! max_k2 = MAX(order - k1 - 1, 0) -! P2(:, 0:max_k2) = JacobiEvalAll(n=max_k2, x=eta_ij(2, :), & -! & alpha=alpha, beta=beta) -! DO k2 = 2, order - k1 + 1 -! cnt = cnt + 1 -! ans(:, cnt) = L1(:, k1 - 2) * avec * P2(:, k2 - 2) -! END DO -! END DO -! -! END SUBROUTINE CellBasis_Triangle2 - -! PURE SUBROUTINE VertexBasisGradient_Triangle2(Lo1, Lo2, dLo1, dLo2, ans) -! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) -! !! Lobatto polynomials evaluated at x1 -! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) -! !! Lobatto polynomials evaluated at x2 -! REAL(DFP), INTENT(IN) :: dLo1(1:, 0:) -! !! Gradient of Lobatto polynomials at x1 -! REAL(DFP), INTENT(IN) :: dLo2(1:, 0:) -! !! Gradient of Lobatto polynomials at x2 -! REAL(DFP), INTENT(INOUT) :: ans(:, :, :) -! ! REAL(DFP) :: ans(SIZE(Lo1, 1), 3, 2) -! !! ans(:,v1) basis function of vertex v1 at all points -! -! ans(:, 1, 1) = dLo1(:, 0) * Lo2(:, 0) -! ans(:, 1, 2) = Lo1(:, 0) * dLo2(:, 0) -! ans(:, 2, 1) = dLo1(:, 1) * Lo2(:, 0) -! ans(:, 2, 2) = Lo1(:, 1) * dLo2(:, 0) -! ans(:, 3, 1) = dLo1(:, 1) * Lo2(:, 1) + dLo1(:, 0) * Lo2(:, 1) -! ans(:, 3, 2) = Lo1(:, 1) * dLo2(:, 1) + Lo1(:, 0) * dLo2(:, 1) -! END SUBROUTINE VertexBasisGradient_Triangle2 - -! PURE SUBROUTINE EdgeBasisGradient_Triangle2(pe1, pe2, pe3, L1, L2, & -! Lo1, Lo2, dL1, dL2, dLo1, dLo2, ans) -! INTEGER(I4B), INTENT(IN) :: pe1 -! !! order on left vertical edge (e1), should be greater than 1 -! INTEGER(I4B), INTENT(IN) :: pe2 -! !! order on right vertical edge(e2), should be greater than 1 -! INTEGER(I4B), INTENT(IN) :: pe3 -! !! order on right vertical edge(e3), should be greater than 1 -! REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) -! !! L1 and L2 are jacobian polynomials -! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) -! !! L1 and L2 are jacobian polynomials -! REAL(DFP), INTENT(IN) :: dLo1(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(IN) :: dLo2(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(INOUT) :: ans(:, :, :) -! ! REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 - 3, 2) -! -! INTEGER(I4B) :: maxP, k1, k2, a -! REAL(DFP), DIMENSION(SIZE(Lo1, 1)) :: avec -! -! maxP = MAX(pe1, pe2, pe3) -! ! edge(1) -! a = 0 -! -! DO k1 = 2, pe1 -! avec = dLo1(:, 0) * Lo1(:, 1) * L1(:, k1 - 2) & -! & + Lo1(:, 0) * dLo1(:, 1) * L1(:, k1 - 2) & -! & + Lo1(:, 0) * Lo1(:, 1) * dL1(:, k1 - 2) -! -! ans(:, k1 - 1, 1) = avec * (Lo2(:, 0)**k1) -! -! ans(:, k1 - 1, 2) = Lo1(:, 0) * Lo1(:, 1) & -! & * L1(:, k1 - 2) & -! & * REAL(k1, DFP) & -! & * (Lo2(:, 0)**(k1 - 1)) & -! & * dLo2(:, 0) -! END DO -! -! ! edge(2) -! a = pe1 - 1 -! DO k2 = 2, pe2 -! avec = dLo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) & -! &+ Lo2(:, 0) * dLo2(:, 1) * L2(:, k2 - 2) & -! &+ Lo2(:, 0) * Lo2(:, 1) * dL2(:, k2 - 2) -! ans(:, a + k2 - 1, 1) = dLo1(:, 0) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) -! ans(:, a + k2 - 1, 2) = Lo1(:, 0) * avec -! END DO -! -! ! edge(3) -! a = pe1 - 1 + pe2 - 1 -! DO k2 = 2, pe3 -! avec = dLo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) & -! & + Lo2(:, 0) * dLo2(:, 1) * L2(:, k2 - 2) & -! & + Lo2(:, 0) * Lo2(:, 1) * dL2(:, k2 - 2) -! ans(:, a + k2 - 1, 1) = dLo1(:, 1) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) -! ans(:, a + k2 - 1, 2) = Lo1(:, 1) * avec -! END DO -! END SUBROUTINE EdgeBasisGradient_Triangle2 - -! PURE SUBROUTINE CellBasisGradient_Triangle2(order, eta_ij, L1, Lo1, & -! Lo2, dL1, dLo1, dLo2, ans) -! INTEGER(I4B), INTENT(IN) :: order -! !! order of approximation inside the cell, order>2 -! REAL(DFP), INTENT(IN) :: eta_ij(:, :) -! !! coordinates on biunit square -! REAL(DFP), INTENT(IN) :: L1(1:, 0:) -! !! lobatto polynomials -! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:) -! !! coordinates on biunit square domain -! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:) -! !! -! REAL(DFP), INTENT(IN) :: dL1(1:, 0:) -! !! lobatto polynomials -! REAL(DFP), INTENT(IN) :: dLo1(1:, 0:) -! !! -! REAL(DFP), INTENT(IN) :: dLo2(1:, 0:) -! !! -! REAL(DFP), INTENT(INOUT) :: ans(:, :, :) -! ! REAL(DFP) :: ans(SIZE(L1, 1), INT((order - 1) * (order - 2) / 2), 2) -! -! REAL(DFP) :: P2(SIZE(eta_ij, 2), 0:order) -! REAL(DFP) :: dP2(SIZE(eta_ij, 2), 0:order) -! -! REAL(DFP) :: temp(SIZE(eta_ij, 2), 13) -! -! REAL(DFP) :: alpha, beta -! INTEGER(I4B) :: k1, k2, max_k2, cnt -! -! alpha = 0.0_DFP -! beta = 1.0_DFP -! cnt = 0 -! temp(:, 5) = dLo1(:, 0) * Lo1(:, 1) -! temp(:, 6) = Lo1(:, 0) * dLo1(:, 1) -! temp(:, 7) = Lo1(:, 0) * Lo1(:, 1) -! temp(:, 9) = dLo2(:, 0) * Lo2(:, 1) -! temp(:, 12) = Lo2(:, 0) * Lo2(:, 1) -! temp(:, 13) = Lo2(:, 0) * dLo2(:, 1) -! -! DO k1 = 2, order - 1 -! alpha = 2.0_DFP * k1 - 1.0_DFP -! max_k2 = MAX(order - k1 - 1, 0) -! P2(:, 0:max_k2) = JacobiEvalAll(n=max_k2, x=eta_ij(2, :), & -! & alpha=alpha, beta=beta) -! dP2(:, 0:max_k2) = JacobiGradientEvalAll(n=max_k2, x=eta_ij(2, :), & -! & alpha=alpha, beta=beta) -! -! temp(:, 1) = (temp(:, 5) + temp(:, 6)) * L1(:, k1 - 2) & -! & + temp(:, 7) * dL1(:, k1 - 2) -! temp(:, 11) = Lo2(:, 0)**(k1 - 1) -! temp(:, 2) = temp(:, 11) * temp(:, 12) -! temp(:, 3) = temp(:, 7) * L1(:, k1 - 2) -! -! temp(:, 10) = REAL(k1, dfp) * temp(:, 9) + temp(:, 13) -! temp(:, 8) = temp(:, 11) * temp(:, 10) -! -! DO k2 = 2, order - k1 + 1 -! cnt = cnt + 1 -! temp(:, 4) = temp(:, 8) * P2(:, k2 - 2) + temp(:, 2) * dP2(:, k2 - 2) -! -! ans(:, cnt, 1) = temp(:, 1) * temp(:, 2) * P2(:, k2 - 2) -! ans(:, cnt, 2) = temp(:, 3) * temp(:, 4) -! END DO -! -! END DO -! -! END SUBROUTINE CellBasisGradient_Triangle2 - -! FUNCTION HeirarchicalBasisGradient_Triangle1(order, pe1, pe2, pe3,& -! & xij, refTriangle) RESULT(ans) -! INTEGER(I4B), INTENT(IN) :: order -! !! Order of approximation inside the triangle (i.e., cell) -! !! it should be greater than 2 for cell bubble to exist -! INTEGER(I4B), INTENT(IN) :: pe1 -! !! Order of interpolation on edge e1 -! !! It should be greater than 1 for edge bubble to exists -! INTEGER(I4B), INTENT(IN) :: pe2 -! !! Order of interpolation on edge e2 -! !! It should be greater than 1 for edge bubble to exists -! INTEGER(I4B), INTENT(IN) :: pe3 -! !! Order of interpolation on edge e3 -! !! It should be greater than 1 for edge bubble to exists -! REAL(DFP), INTENT(IN) :: xij(:, :) -! !! Points of evaluation in xij format -! CHARACTER(*), INTENT(IN) :: refTriangle -! !! This parameter denotes the type of reference triangle. -! !! It can take following values: -! !! UNIT: in this case xij is in unit Triangle. -! !! BIUNIT: in this case xij is in biunit triangle. -! REAL(DFP) :: ans( & -! & SIZE(xij, 2), & -! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 2) -! !! -! -! CHARACTER(20) :: layout -! REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2)) -! REAL(DFP) :: L1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) -! REAL(DFP) :: L2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) -! REAL(DFP) :: dL1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) -! REAL(DFP) :: dL2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order)) -! REAL(DFP) :: Lo1(SIZE(xij, 2), 0:1) -! REAL(DFP) :: Lo2(SIZE(xij, 2), 0:1) -! REAL(DFP) :: dLo1(SIZE(xij, 2), 0:1) -! REAL(DFP) :: dLo2(SIZE(xij, 2), 0:1) -! -! INTEGER(I4B) :: maxP, a, b -! -! layout = TRIM(UpperCase(refTriangle)) -! -! IF (layout .EQ. "BIUNIT") THEN -! x = FromBiUnitTriangle2BiUnitSqr(xin=xij) -! ELSE -! x = FromUnitTriangle2BiUnitSqr(xin=xij) -! END IF -! -! Lo1(:, 0) = 0.5_DFP * (1.0 - x(1, :)) -! Lo1(:, 1) = 0.5_DFP * (1.0 + x(1, :)) -! Lo2(:, 0) = 0.5_DFP * (1.0 - x(2, :)) -! Lo2(:, 1) = 0.5_DFP * (1.0 + x(2, :)) -! dLo1(:, 0) = -0.5_DFP -! dLo1(:, 1) = 0.5_DFP -! dLo2(:, 0) = -0.5_DFP -! dLo2(:, 1) = 0.5_DFP -! -! !! Vertex basis function -! ! ans = 0.0_DFP -! CALL VertexBasisGradient_Triangle2(Lo1=Lo1, Lo2=Lo2, dLo1=dLo1, dLo2=dLo2, & -! ans=ans(:, 1:3, 1:2)) -! -! maxP = MAX(pe1, pe2, pe3, order) -! L1 = JacobiEvalAll(n=maxP, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP) -! L2 = JacobiEvalAll(n=maxP, x=x(2, :), alpha=1.0_DFP, beta=1.0_DFP) -! dL1 = JacobiGradientEvalAll(n=maxP, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP) -! dL2 = JacobiGradientEvalAll(n=maxP, x=x(2, :), alpha=1.0_DFP, beta=1.0_DFP) -! -! !! Edge basis function -! b = 3 -! IF (pe1 .GE. 2_I4B .OR. pe2 .GE. 2_I4B .OR. pe3 .GE. 2_I4B) THEN -! a = b + 1 -! b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2 -! CALL EdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2, & -! Lo1=Lo1, Lo2=Lo2, dL1=dL1, dL2=dL2, dLo1=dLo1, dLo2=dLo2, & -! ans=ans(:, a:b, 1:2)) -! END IF -! -! !! Cell basis function -! IF (order .GT. 2_I4B) THEN -! a = b + 1 -! b = a - 1 + INT((order - 1) * (order - 2) / 2) -! CALL CellBasisGradient_Triangle2( & -! & order=order, & -! & L1=L1, & -! & Lo1=Lo1, & -! & Lo2=Lo2, & -! & dL1=dL1, & -! & dLo1=dLo1, & -! & dLo2=dLo2, & -! & eta_ij=x, ans=ans(:, a:b, 1:2)) -! END IF -! END FUNCTION HeirarchicalBasisGradient_Triangle1 diff --git a/src/submodules/Prism/CMakeLists.txt b/src/submodules/Prism/CMakeLists.txt new file mode 100644 index 000000000..d94c6cc5f --- /dev/null +++ b/src/submodules/Prism/CMakeLists.txt @@ -0,0 +1,21 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} PRIVATE ${src_path}/ReferencePrism_Method@Methods.F90 + ${src_path}/PrismInterpolationUtility@Methods.F90) diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Prism/src/PrismInterpolationUtility@Methods.F90 similarity index 100% rename from src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 rename to src/submodules/Prism/src/PrismInterpolationUtility@Methods.F90 diff --git a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 b/src/submodules/Prism/src/ReferencePrism_Method@Methods.F90 similarity index 95% rename from src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 rename to src/submodules/Prism/src/ReferencePrism_Method@Methods.F90 index 281bc250e..7f325ee24 100644 --- a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90 +++ b/src/submodules/Prism/src/ReferencePrism_Method@Methods.F90 @@ -377,13 +377,29 @@ ! GetFaceElemType_Prism !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Prism +MODULE PROCEDURE GetFaceElemType_Prism1 IF (PRESENT(faceElemType)) & faceElemType(1:5) = [Triangle3, Quadrangle4, Quadrangle4, Quadrangle4, & Triangle3] IF (PRESENT(tFaceNodes)) tFaceNodes(1:5) = [3, 4, 4, 4, 3] -END PROCEDURE GetFaceElemType_Prism +END PROCEDURE GetFaceElemType_Prism1 + +!---------------------------------------------------------------------------- +! GetFaceElemType_Prism +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Prism2 + +SELECT CASE (localFaceNumber) +CASE (1, 5) + faceElemType = Triangle3 + tFaceNodes = 3 +CASE DEFAULT + faceElemType = Quadrangle4 + tFaceNodes = 4 +END SELECT +END PROCEDURE GetFaceElemType_Prism2 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Projection/CMakeLists.txt b/src/submodules/Projection/CMakeLists.txt new file mode 100644 index 000000000..218b15a47 --- /dev/null +++ b/src/submodules/Projection/CMakeLists.txt @@ -0,0 +1,20 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources(${PROJECT_NAME} + PRIVATE ${src_path}/Projection_Method@L2Methods.F90) diff --git a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 new file mode 100644 index 000000000..c0f92d529 --- /dev/null +++ b/src/submodules/Projection/src/Projection_Method@L2Methods.F90 @@ -0,0 +1,203 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(Projection_Method) L2Methods +USE BaseType, ONLY: math => TypeMathOpt +USE InputUtility, ONLY: Input +USE Display_Method, ONLY: ToString +USE Display_Method, ONLY: Display +USE MassMatrix_Method, ONLY: MassMatrix_ +USE ForceVector_Method, ONLY: ForceVector_ +USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat + +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = "Projection_Method@L2Methods" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValueFromQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature1()" +LOGICAL(LGT) :: isok +INTEGER(I4B) :: n1 +#endif + +INTEGER(I4B) :: info, nrow, ncol + +#ifdef DEBUG_VER +n1 = SIZE(func) +isok = n1 .GE. elemsd%nips +CALL AssertError1( & + isok, myName, modName, __LINE__, & + 'Size of func='//ToString(n1)//' is lesser than elemsd%nips='// & + ToString(elemsd%nips)) +#endif + +CALL MassMatrix_( & + N=elemsd%N, M=elemsd%N, js=elemsd%js, ws=elemsd%ws, & + thickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, & + nns2=elemsd%nns, skipVertices=skipVertices, tVertices=tVertices, & + ans=massMat, nrow=nrow, ncol=ncol) + +CALL ForceVector_( & + N=elemsd%N, js=elemsd%js, ws=elemsd%ws, thickness=elemsd%thickness, & + nips=elemsd%nips, nns=elemsd%nns, skipVertices=skipVertices, & + tVertices=tVertices, ans=ans, tsize=tsize, c=func) + +CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info) + +CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & + IPIV=ipiv(1:tsize), info=info) +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1 + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValueFromQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature2()" +LOGICAL(LGT) :: isok +INTEGER(I4B) :: n1 +#endif + +INTEGER(I4B) :: info, nrow, ncol + +#ifdef DEBUG_VER +n1 = SIZE(func, 1) +isok = n1 .GE. elemsd%nips +CALL AssertError1( & + isok, myName, modName, __LINE__, & + 'Size of func='//ToString(n1)//' is lesser than elemsd%nips='// & + ToString(elemsd%nips)) +#endif + +#ifdef DEBUG_VER +n1 = SIZE(func, 2) +isok = n1 .GE. timeElemsd%nips +CALL AssertError1( & + isok, myName, modName, __LINE__, & + 'Size of func='//ToString(n1)//' is lesser than timeElemsd%nips='// & + ToString(timeElemsd%nips)) +#endif + +CALL MassMatrix_( & + spaceN=elemsd%N, spaceM=elemsd%N, js=elemsd%js, ws=elemsd%ws, & + spaceThickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, & + nns2=elemsd%nns, skipVertices=skipVertices, tSpaceVertices=tSpaceVertices, & + timeN=timeElemsd%N, timeM=timeElemsd%N, jt=timeElemsd%js, & + wt=timeElemsd%ws, timeThickness=timeElemsd%thickness, & + nipt=timeElemsd%nips, nnt1=timeElemsd%nns, nnt2=timeElemsd%nns, & + tTimeVertices=tTimeVertices, ans=massMat, nrow=nrow, ncol=ncol) + +CALL ForceVector_( & + spaceN=elemsd%N, js=elemsd%js, ws=elemsd%ws, & + spaceThickness=elemsd%thickness, nips=elemsd%nips, nns=elemsd%nns, & + timeN=timeElemsd%N, jt=timeElemsd%js, wt=timeElemsd%ws, & + timeThickness=timeElemsd%thickness, nipt=timeElemsd%nips, & + nnt=timeElemsd%nns, skipVertices=skipVertices, & + tSpaceVertices=tSpaceVertices, tTimeVertices=tTimeVertices, & + c=func, ans=ans, tsize=tsize) + +CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info) + +CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & + IPIV=ipiv(1:tsize), info=info) + +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2 + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValueFromQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature3 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature3()" +#endif + +INTEGER(I4B) :: info, nrow, ncol + +CALL MassMatrix_( & + N=elemsd%N, M=elemsd%N, js=elemsd%js, ws=elemsd%ws, & + thickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, & + nns2=elemsd%nns, skipVertices=skipVertices, tVertices=tVertices, & + ans=massMat, nrow=nrow, ncol=ncol) + +CALL ForceVector_( & + N=elemsd%N, js=elemsd%js, ws=elemsd%ws, thickness=elemsd%thickness, & + nips=elemsd%nips, nns=elemsd%nns, skipVertices=skipVertices, & + tVertices=tVertices, ans=ans, tsize=tsize) + +CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info) + +CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & + IPIV=ipiv(1:tsize), info=info) +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature3 + +!---------------------------------------------------------------------------- +! GetL2ProjectionDOFValueFromQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature4 +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature4()" +#endif + +INTEGER(I4B) :: info, nrow, ncol + + +CALL MassMatrix_( & + spaceN=elemsd%N, spaceM=elemsd%N, js=elemsd%js, ws=elemsd%ws, & + spaceThickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, & + nns2=elemsd%nns, skipVertices=skipVertices, tSpaceVertices=tSpaceVertices, & + timeN=timeElemsd%N, timeM=timeElemsd%N, jt=timeElemsd%js, & + wt=timeElemsd%ws, timeThickness=timeElemsd%thickness, & + nipt=timeElemsd%nips, nnt1=timeElemsd%nns, nnt2=timeElemsd%nns, & + tTimeVertices=tTimeVertices, ans=massMat, nrow=nrow, ncol=ncol) + +CALL ForceVector_( & + spaceN=elemsd%N, js=elemsd%js, ws=elemsd%ws, & + spaceThickness=elemsd%thickness, nips=elemsd%nips, nns=elemsd%nns, & + timeN=timeElemsd%N, jt=timeElemsd%js, wt=timeElemsd%ws, & + timeThickness=timeElemsd%thickness, nipt=timeElemsd%nips, & + nnt=timeElemsd%nns, skipVertices=skipVertices, & + tSpaceVertices=tSpaceVertices, tTimeVertices=tTimeVertices, & + ans=ans, tsize=tsize) + +CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info) + +CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), & + IPIV=ipiv(1:tsize), info=info) + +END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature4 + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE L2Methods + diff --git a/src/submodules/Pyramid/CMakeLists.txt b/src/submodules/Pyramid/CMakeLists.txt new file mode 100644 index 000000000..a1ab61058 --- /dev/null +++ b/src/submodules/Pyramid/CMakeLists.txt @@ -0,0 +1,22 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferencePyramid_Method@Methods.F90 + PRIVATE ${src_path}/PyramidInterpolationUtility@Methods.F90) diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Pyramid/src/PyramidInterpolationUtility@Methods.F90 similarity index 100% rename from src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 rename to src/submodules/Pyramid/src/PyramidInterpolationUtility@Methods.F90 diff --git a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 b/src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90 similarity index 95% rename from src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 rename to src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90 index d2638525f..14302d8de 100644 --- a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90 +++ b/src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90 @@ -352,14 +352,29 @@ ! GetFaceElemType_Pyramid !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Pyramid - +MODULE PROCEDURE GetFaceElemType_Pyramid1 IF (PRESENT(faceElemType)) & faceElemType(1:5) = [Quadrangle4, Triangle3, Triangle3, Triangle3, & Triangle3] IF (PRESENT(tFaceNodes)) tFaceNodes(1:5) = [4, 3, 3, 3, 3] -END PROCEDURE GetFaceElemType_Pyramid +END PROCEDURE GetFaceElemType_Pyramid1 + +!---------------------------------------------------------------------------- +! GetFaceElemType_Pyramid +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Pyramid2 + +SELECT CASE (localFaceNumber) +CASE (1) + faceElemType = Quadrangle4 + tFaceNodes = 4 +CASE DEFAULT + faceElemType = Triangle3 + tFaceNodes = 3 +END SELECT +END PROCEDURE GetFaceElemType_Pyramid2 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Quadrangle/CMakeLists.txt b/src/submodules/Quadrangle/CMakeLists.txt new file mode 100644 index 000000000..6b199a483 --- /dev/null +++ b/src/submodules/Quadrangle/CMakeLists.txt @@ -0,0 +1,29 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferenceQuadrangle_Method@Methods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@Methods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@DOFMethods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@LagrangeMethods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@TensorProdMethods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@HierarchicalMethods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@DubinerMethods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@InterpolationPointMethods.F90 + PRIVATE ${src_path}/QuadrangleInterpolationUtility@QuadratureMethods.F90) diff --git a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 similarity index 53% rename from src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 rename to src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 index d7e92e320..72a513a69 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90 @@ -13,66 +13,37 @@ ! ! You should have received a copy of the GNU General Public License ! along with this program. If not, see -! - -SUBMODULE(FEVariable_Method) EqualMethods -USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.) +SUBMODULE(QuadrangleInterpolationUtility) DOFMethods IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! NORM2 +! GetTotalDOF_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE fevar_isequal -!! Internal variable -ans = .FALSE. -IF (obj1%len .NE. obj2%len) RETURN -IF (obj1%defineon .NE. obj2%defineon) RETURN -IF (obj1%rank .NE. obj2%rank) RETURN -IF (obj1%varType .NE. obj2%varType) RETURN -IF (ANY(obj1%s .NE. obj2%s)) RETURN - -IF (ALL(obj1%val(1:obj1%len) .APPROXEQ.obj2%val(1:obj2%len))) ans = .TRUE. -!! -END PROCEDURE fevar_isequal +MODULE PROCEDURE GetTotalDOF_Quadrangle +ans = (order + 1)**2 +END PROCEDURE GetTotalDOF_Quadrangle !---------------------------------------------------------------------------- -! NORM2 +! GetTotalInDOF_Quadrangle !---------------------------------------------------------------------------- -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 +MODULE PROCEDURE GetTotalInDOF_Quadrangle1 +ans = (order - 1)**2 +END PROCEDURE GetTotalInDOF_Quadrangle1 -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 +!---------------------------------------------------------------------------- +! GetTotalInDOF_Quadrangle +!---------------------------------------------------------------------------- -END PROCEDURE fevar_notEqual +MODULE PROCEDURE GetTotalInDOF_Quadrangle2 +ans = (p - 1) * (q - 1) +END PROCEDURE GetTotalInDOF_Quadrangle2 !---------------------------------------------------------------------------- -! +! QuadraturePoint_Quadrangle3 !---------------------------------------------------------------------------- -END SUBMODULE EqualMethods +END SUBMODULE DOFMethods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90 new file mode 100644 index 000000000..2ac67d856 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90 @@ -0,0 +1,193 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) DubinerMethods +USE LegendrePolynomialUtility, ONLY: LegendreEvalAll_, & + LegendreGradientEvalAll_ +USE JacobiPolynomialUtility, ONLY: JacobiEvalAll_, & + JacobiGradientEvalAll_ + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL Dubiner_Quadrangle1_(xij=xij, order=order, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE Dubiner_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle1_ +REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1), & + temp(SIZE(xij, 2), 3) +REAL(DFP) :: alpha, beta +INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii + +nrow = SIZE(xij, 2) +ncol = (order + 1) * (order + 2) / 2 + +CALL LegendreEvalAll_(n=order, x=xij(1, :), ans=P1, nrow=indx(1), & + ncol=indx(2)) + +! we do not need x now, so let store (1-y)/2 in x +DO CONCURRENT(ii=1:nrow) + temp(ii, 3) = xij(2, ii) + temp(ii, 1) = 0.5_DFP * (1.0_DFP - temp(ii, 3)) +END DO + +alpha = 0.0_DFP +beta = 0.0_DFP +cnt = 0 + +! temp1 = 0.5 * (1.0 - y) +! temp3 = y + +DO k1 = 0, order + + !! note here temp1 is + !! note here x = 0.5_DFP*(1-y) + DO CONCURRENT(ii=1:nrow) + temp(ii, 2) = temp(ii, 1)**k1 + END DO + + alpha = 2.0_DFP * k1 + 1.0_DFP + + max_k2 = order - k1 + + ! P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta) + CALL JacobiEvalAll_(n=max_k2, x=temp(:, 3), alpha=alpha, beta=beta, ans=P2, & + nrow=indx(1), ncol=indx(2)) + + DO k2 = 0, max_k2 + cnt = cnt + 1 + + DO CONCURRENT(ii=1:nrow) + ans(ii, cnt) = P1(ii, k1 + 1) * temp(ii, 2) * P2(ii, k2 + 1) + END DO + END DO + +END DO + +END PROCEDURE Dubiner_Quadrangle1_ + +!---------------------------------------------------------------------------- +! DubinerGradient_Quadrangle1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DubinerGradient_Quadrangle1 +INTEGER(I4B) :: s(3) +CALL DubinerGradient_Quadrangle1_(xij=xij, order=order, ans=ans, & + tsize1=s(1), tsize2=s(2), tsize3=s(3)) +END PROCEDURE DubinerGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! DubinerGradient_Quadrangle1 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE DubinerGradient_Quadrangle1_ +REAL(DFP), DIMENSION(SIZE(xij, 2), order + 1) :: P1, P2, dP1, dP2 +REAL(DFP), DIMENSION(SIZE(xij, 2)) :: avec, bvec, x, y +REAL(DFP) :: alpha, beta, areal +INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii + +tsize1 = SIZE(xij, 2) +tsize2 = (order + 1) * (order + 2) / 2 +tsize3 = 2 + +x = xij(1, :) +y = xij(2, :) + +! P1 = LegendreEvalAll(n=order, x=x) +CALL LegendreEvalAll_(n=order, x=x, ans=P1, nrow=indx(1), ncol=indx(2)) + +! dP1 = LegendreGradientEvalAll(n=order, x=x) +CALL LegendreGradientEvalAll_(n=order, x=x, ans=dP1, nrow=indx(1), & + ncol=indx(2)) + +! we do not need x now, so let store (1-y)/2 in x +x = 0.5_DFP * (1.0_DFP - y) +alpha = 1.0_DFP +beta = 0.0_DFP +cnt = 0 + +DO k1 = 0, order + bvec = x**(MAX(k1 - 1_I4B, 0_I4B)) + avec = x * bvec + alpha = 2.0_DFP * k1 + 1.0_DFP + + max_k2 = order - k1 + + CALL JacobiEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, & + ans=P2, nrow=indx(1), ncol=indx(2)) + + CALL JacobiGradientEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, & + ans=dP2, nrow=indx(1), ncol=indx(2)) + + areal = REAL(k1, DFP) + + DO k2 = 0, max_k2 + cnt = cnt + 1 + + DO CONCURRENT(ii=1:tsize1) + ans(ii, cnt, 1) = dP1(ii, k1 + 1) * avec(ii) * P2(ii, k2 + 1) + ans(ii, cnt, 2) = P1(ii, k1 + 1) * bvec(ii) * & + (x(ii) * dP2(ii, k2 + 1) - 0.5_DFP * areal * P2(ii, k2 + 1)) + END DO + + END DO + +END DO +END PROCEDURE DubinerGradient_Quadrangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL Dubiner_Quadrangle2_(x=x, y=y, order=order, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE Dubiner_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Dubiner_Quadrangle2_ +REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) +INTEGER(I4B) :: ii, jj, cnt + +xij = 0.0_DFP +cnt = 0 +DO ii = 1, SIZE(x) + DO jj = 1, SIZE(y) + cnt = cnt + 1 + xij(1, cnt) = x(ii) + xij(2, cnt) = y(jj) + END DO +END DO +CALL Dubiner_Quadrangle1_(order=order, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE Dubiner_Quadrangle2_ + +END SUBMODULE DubinerMethods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 new file mode 100644 index 000000000..81b2f7e74 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 @@ -0,0 +1,953 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) HierarchicalMethods +USE LobattoPolynomialUtility, ONLY: LobattoEvalAll_, & + LobattoGradientEvalAll_ + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! GetHierarchicalDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetHierarchicalDOF_Quadrangle +ans = 0 + +SELECT CASE (opt) + +CASE ("v", "V") + ans = 4 + +CASE ("e", "E") + ans = qe1 + qe2 + pe3 + pe4 - 4 + +CASE ("c", "C") + ans = (pb - 1) * (qb - 1) + +CASE DEFAULT + ans = qe1 + qe2 + pe3 + pe4 + (pb - 1) * (qb - 1) + +END SELECT +END PROCEDURE GetHierarchicalDOF_Quadrangle + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL VertexBasis_Quadrangle1_(x=x, y=y, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE VertexBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle1_ +nrow = SIZE(x) +ncol = 4 +ans(1:nrow, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y) +ans(1:nrow, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y) +ans(1:nrow, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y) +ans(1:nrow, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y) +END PROCEDURE VertexBasis_Quadrangle1_ + +!---------------------------------------------------------------------------- +! VertexBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL VertexBasis_Quadrangle2_(xij=xij, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE VertexBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VertexBasis_Quadrangle2_ +CALL VertexBasis_Quadrangle1_(x=xij(1, :), y=xij(2, :), ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE VertexBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! VertexBasisGradient_Quadrangle2_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE VertexBasisGradient_Quadrangle2_(L1, L2, dL1, dL2, & + ans, dim1, dim2, dim3) + REAL(DFP), INTENT(IN) :: L1(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + REAL(DFP), INTENT(IN) :: L2(1:, 0:) + !! L2 is Lobatto polynomial evaluated at y coordinates + REAL(DFP), INTENT(IN) :: dL1(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + REAL(DFP), INTENT(IN) :: dL2(1:, 0:) + !! L2 is Lobatto polynomial evaluated at y coordinates + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1= SIZE(L1, 1) + !! dim2= 4 + !! dim3 = 2 + !! Gradient of vertex basis + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + dim1 = SIZE(L1, 1) + dim2 = 4 + dim3 = 2 + ans(1:dim1, 1, 1) = dL1(1:dim1, 0) * L2(1:dim1, 0) + ans(1:dim1, 2, 1) = dL1(1:dim1, 1) * L2(1:dim1, 0) + ans(1:dim1, 3, 1) = dL1(1:dim1, 1) * L2(1:dim1, 1) + ans(1:dim1, 4, 1) = dL1(1:dim1, 0) * L2(1:dim1, 1) + ans(1:dim1, 1, 2) = L1(1:dim1, 0) * dL2(1:dim1, 0) + ans(1:dim1, 2, 2) = L1(1:dim1, 1) * dL2(1:dim1, 0) + ans(1:dim1, 3, 2) = L1(1:dim1, 1) * dL2(1:dim1, 1) + ans(1:dim1, 4, 2) = L1(1:dim1, 0) * dL2(1:dim1, 1) +END SUBROUTINE VertexBasisGradient_Quadrangle2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE VertexBasis_Quadrangle3_(L1, L2, ans, nrow, ncol) + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! L1 Lobatto polynomial evaluated at x coordinates + !! L2 is Lobatto polynomial evaluated at y coordinates + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), 4) + !! ans(:,v1) basis function of vertex v1 at all points + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + !! internal variable + INTEGER(I4B) :: ii + + nrow = SIZE(L1, 1) + ncol = 4 + + DO CONCURRENT(ii=1:nrow) + ans(ii, 1) = L1(ii, 0) * L2(ii, 0) + ans(ii, 2) = L1(ii, 1) * L2(ii, 0) + ans(ii, 3) = L1(ii, 1) * L2(ii, 1) + ans(ii, 4) = L1(ii, 0) * L2(ii, 1) + END DO +END SUBROUTINE VertexBasis_Quadrangle3_ + +!---------------------------------------------------------------------------- +! VerticalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle +INTEGER(I4B) :: nrow, ncol +CALL VerticalEdgeBasis_Quadrangle_(qe1=qe1, qe2=qe2, x=x, y=y, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE VerticalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE VerticalEdgeBasis_Quadrangle_ +! REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2)) +INTEGER(I4B) :: maxQ, aint, bint +INTEGER(I4B), PARAMETER :: maxP = 1, orient = 1 +REAL(DFP), ALLOCATABLE :: L2(:, :), L1(:, :) + +nrow = SIZE(x) +ncol = 0 + +maxQ = MAX(qe1, qe2) +aint = SIZE(y) +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) + +CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) +CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) + +! Left vertical +CALL LeftVerticalEdgeBasis_Quadrangle_( & + order=qe1, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, & + orient=orient, offset=ncol) +ncol = ncol + aint + +! Right vertical +CALL RightVerticalEdgeBasis_Quadrangle_( & + order=qe2, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, & + orient=orient, offset=ncol) +ncol = ncol + aint + +DEALLOCATE (L2, L1) +END PROCEDURE VerticalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! LeftVerticalEdgeBasis_Quadrangle_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE LeftVerticalEdgeBasis_Quadrangle_( & + order, L1, L2, ans, nrow, ncol, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on left vertical edge (e1), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), qe1 + qe2 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of left and right vertical edge + !! it can be 1 or -1 + INTEGER(I4B), INTENT(IN) :: offset + !! data will we written in ans from offset + 1 + !! If you want to start from ans(:, 1) then set offset = 0 + + INTEGER(I4B) :: k2, ii + REAL(DFP) :: o1 + + o1 = REAL(-orient, kind=DFP) + ! Here we multiply by -1 because the left edge is oriented downwards + ! in master element + + nrow = SIZE(L1, 1) !! Number of points of evaluation + ncol = order - 1 !! these are internal DOFs on edge + + DO CONCURRENT(k2=2:order, ii=1:nrow) + ans(ii, offset + k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2) + END DO + +END SUBROUTINE LeftVerticalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! RightVerticalEdgeBasis_Quadrangle_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE RightVerticalEdgeBasis_Quadrangle_( & + order, L1, L2, ans, nrow, ncol, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on left vertical edge (e1), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), qe1 + qe2 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of left and right vertical edge + !! it can be 1 or -1 + INTEGER(I4B), INTENT(IN) :: offset + !! data will we written in ans from offset + 1 + !! If you want to start from ans(:, 1) then set offset = 0 + + INTEGER(I4B) :: k2, ii + REAL(DFP) :: mysign + + mysign = REAL(orient, kind=DFP) + + nrow = SIZE(L1, 1) !! number of points of evaluation + ncol = order - 1 !! these are internal dof on edge + + !! right vertical + DO CONCURRENT(k2=2:order, ii=1:nrow) + ans(ii, offset + k2 - 1) = (mysign**k2) * L1(ii, 1) * L2(ii, k2) + END DO + +END SUBROUTINE RightVerticalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! LeftVerticalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +PURE SUBROUTINE LeftVerticalEdgeBasisGradient_Quadrangle_( & + order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on left vertical edge (e1), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1=SIZE(L1, 1) + !! dim2=order-1 + !! dim3= 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! range of data written to ans + INTEGER(I4B), INTENT(IN) :: orient + !! orientation fo left and write vertical edge + !! it can be 1 or -1 + INTEGER(I4B), INTENT(IN) :: offset + + INTEGER(I4B) :: k2, ii + REAL(DFP) :: mysign + + mysign = REAL(-orient, kind=DFP) + ! Here we multiply by -1 because the left edge is oriented downwards & + ! in master element + + dim1 = SIZE(L1, 1) + dim2 = order - 1 + dim3 = 2 + + DO CONCURRENT(k2=2:order, ii=1:dim1) + ans(ii, offset + k2 - 1, 1) = (mysign**k2) * dL1(ii, 0) * L2(ii, k2) + ans(ii, offset + k2 - 1, 2) = (mysign**k2) * L1(ii, 0) * dL2(ii, k2) + END DO + +END SUBROUTINE LeftVerticalEdgeBasisGradient_Quadrangle_ + +!---------------------------------------------------------------------------- +! VerticalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +!> author: Vikas Sharma, Ph. D. +! date: 28 Oct 2022 +! summary: Returns the vertex basis functions on biunit quadrangle + +PURE SUBROUTINE RightVerticalEdgeBasisGradient_Quadrangle_( & + order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on right vertical edge(e2), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + !! Lobatto polynomials in x and y direction. + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + !! dim1=SIZE(L1, 1) + !! dim2=order-1 + !! dim3= 2 + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! range of data written to ans + INTEGER(I4B), INTENT(IN) :: orient + !! orientation fo left and write vertical edge + !! it can be 1 or -1 + INTEGER(I4B), INTENT(IN) :: offset + + INTEGER(I4B) :: k2, ii + REAL(DFP) :: mysign + + mysign = REAL(orient, kind=DFP) + + dim1 = SIZE(L1, 1) + dim2 = order - 1 + dim3 = 2 + + ! Right vertical + DO CONCURRENT(k2=2:order, ii=1:dim1) + ans(ii, offset + k2 - 1, 1) = (mysign**k2) * dL1(ii, 1) * L2(ii, k2) + ans(ii, offset + k2 - 1, 2) = (mysign**k2) * L1(ii, 1) * dL2(ii, k2) + END DO +END SUBROUTINE RightVerticalEdgeBasisGradient_Quadrangle_ + +!---------------------------------------------------------------------------- +! HorizontalEdgeBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle +INTEGER(I4B) :: nrow, ncol +CALL HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, ans, nrow, ncol) +END PROCEDURE HorizontalEdgeBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle_ +INTEGER(I4B) :: maxP, aint, bint +INTEGER(I4B), PARAMETER :: maxQ = 1, orient = 1 + +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) + +maxP = MAX(pe3, pe4) + +nrow = SIZE(x) +ncol = 0 +aint = SIZE(y) + +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ)) + +CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint) +CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint) + +! Bottom Horizontal +CALL BottomHorizontalEdgeBasis_Quadrangle_( & + order=pe3, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, orient=orient, & + offset=ncol) +ncol = ncol + aint + +! Top Horizontal +CALL TopHorizontalEdgeBasis_Quadrangle_( & + order=pe4, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, orient=orient, & + offset=ncol) +ncol = ncol + aint + +DEALLOCATE (L1, L2) + +END PROCEDURE HorizontalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! BottomHorizontalEdgeBasis_Quadrangle_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE BottomHorizontalEdgeBasis_Quadrangle_( & + order, L1, L2, ans, nrow, ncol, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on bottom vertical edge (e3), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), pe3 + pe4 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + INTEGER(I4B), INTENT(IN) :: orient + !! orientaion of bottom and top edge + INTEGER(I4B), INTENT(IN) :: offset + + INTEGER(I4B) :: k1, ii + REAL(DFP) :: mysign + + mysign = REAL(orient, kind=DFP) + + nrow = SIZE(L1, 1) !! number of points of evaluation + ncol = order - 1 !! these are internal dof on edge + + !! bottom edge + DO CONCURRENT(k1=2:order, ii=1:nrow) + ans(ii, offset + k1 - 1) = (mysign**k1) * L1(ii, k1) * L2(ii, 0) + END DO + +END SUBROUTINE BottomHorizontalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! TopHorizontalEdgeBasis_Quadrangle_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE TopHorizontalEdgeBasis_Quadrangle_( & + order, L1, L2, ans, nrow, ncol, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on bottom vertical edge (e3), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), pe3 + pe4 - 2) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and columns written to ans + INTEGER(I4B), INTENT(IN) :: orient + !! orientaion of bottom and top edge + INTEGER(I4B), INTENT(IN) :: offset + + INTEGER(I4B) :: k1, ii + REAL(DFP) :: mysign + + mysign = REAL(-orient, kind=DFP) + ! We multiply by -1 because the top edge is oriented leftwards + ! in master element + + nrow = SIZE(L1, 1) !! number of points of evaluation + ncol = order - 1 !! these are internal dof on edge + + !! top edge + DO CONCURRENT(k1=2:order, ii=1:nrow) + ans(ii, offset + k1 - 1) = (mysign**k1) * L1(ii, k1) * L2(ii, 1) + END DO +END SUBROUTINE TopHorizontalEdgeBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! BottomHorizontalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +PURE SUBROUTINE BottomHorizontalEdgeBasisGradient_Quadrangle_( & + order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on bottom vertical edge (e3), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(L1, 1) + !! dim2 = pe3 + pe4 - 2 + !! dim3 = 2 + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of bottom and top horizontal edge + INTEGER(I4B), INTENT(IN) :: offset + + !! internal variable + INTEGER(I4B) :: k1, ii + REAL(DFP) :: mysign + + mysign = REAL(orient, kind=DFP) + + dim1 = SIZE(L1, 1) !! number of points of evaluation + dim2 = order - 1 !! these are internal dof on edge + dim3 = 2 !! x and y component of gradient + + !! bottom edge + DO CONCURRENT(k1=2:order, ii=1:dim1) + ans(ii, offset + k1 - 1, 1) = (mysign**k1) * dL1(ii, k1) * L2(ii, 0) + ans(ii, offset + k1 - 1, 2) = (mysign**k1) * L1(ii, k1) * dL2(ii, 0) + END DO + +END SUBROUTINE BottomHorizontalEdgeBasisGradient_Quadrangle_ + +!---------------------------------------------------------------------------- +! TopHorizontalEdgeBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +PURE SUBROUTINE TopHorizontalEdgeBasisGradient_Quadrangle_( & + order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset) + INTEGER(I4B), INTENT(IN) :: order + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1 = SIZE(L1, 1) + !! dim2 = order - 1 + !! dim3 = 2 + INTEGER(I4B), INTENT(IN) :: orient + !! orientation of bottom and top horizontal edge + INTEGER(I4B), INTENT(IN) :: offset + !! data will we written in ans from offset + 1 + + !! internal variable + INTEGER(I4B) :: k1, ii + REAL(DFP) :: mysign + + mysign = REAL(-orient, kind=DFP) + ! Here we multiply by -1 because the top edge is oriented leftwards & + ! in master element + + dim1 = SIZE(L1, 1) !! number of points of evaluation + dim2 = order - 1 !! these are internal dof on edge + dim3 = 2 + + !! top edge + DO CONCURRENT(k1=2:order, ii=1:dim1) + ans(ii, offset + k1 - 1, 1) = (mysign**k1) * dL1(ii, k1) * L2(ii, 1) + ans(ii, offset + k1 - 1, 2) = (mysign**k1) * L1(ii, k1) * dL2(ii, 1) + END DO +END SUBROUTINE TopHorizontalEdgeBasisGradient_Quadrangle_ + +!---------------------------------------------------------------------------- +! CellBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle +INTEGER(I4B) :: nrow, ncol +CALL CellBasis_Quadrangle_(pb=pb, qb=qb, x=x, y=y, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE CellBasis_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE CellBasis_Quadrangle_ +REAL(DFP) :: L1(1:SIZE(x), 0:pb) +REAL(DFP) :: L2(1:SIZE(y), 0:qb) +INTEGER(I4B), PARAMETER :: faceOrient(3) = [1, 1, 1] + +CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=nrow, ncol=ncol) +CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=nrow, ncol=ncol) + +CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, ans=ans, nrow=nrow, & + ncol=ncol, faceOrient=faceOrient, offset=0_I4B) + +END PROCEDURE CellBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, & + faceOrient, offset) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + !! point of evaluation + REAL(DFP), INTENT(INOUT) :: ans(:, :) + !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1)) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + !! number of rows and cols written to ans + INTEGER(I4B), INTENT(IN) :: faceOrient(3) + !! face orientation + INTEGER(I4B), INTENT(IN) :: offset + !! data will we written in ans from offset + 1 + + !! Internal variables + INTEGER(I4B) :: k1, k2, ii, p, q + REAL(DFP) :: o1, o2 + + nrow = SIZE(L1, 1) + ncol = (pb - 1) * (qb - 1) + + o1 = REAL(faceOrient(1), kind=DFP) + o2 = REAL(faceOrient(2), kind=DFP) + + p = pb + q = qb + IF (faceOrient(3) .LT. 0_I4B) THEN + p = qb + q = pb + END IF + + DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow) + ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1) = & + (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2) + END DO + +END SUBROUTINE CellBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! CellBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +PURE SUBROUTINE CellBasisGradient_Quadrangle2_( & + pb, qb, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, faceOrient, offset) + INTEGER(I4B), INTENT(IN) :: pb + !! order on bottom vertical edge (e3), it should be greater than 1 + INTEGER(I4B), INTENT(IN) :: qb + !! order on top vertical edge(e4), it should be greater than 1 + REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:) + REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:) + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + !! dim1=SIZE(L1, 1) + !! dim2=(pb - 1) * (qb - 1) + !! dim3=2 + INTEGER(I4B), INTENT(IN) :: faceOrient(3) + !! face orientation + INTEGER(I4B), INTENT(IN) :: offset + !! data will we written in ans from offset + 1 + + !! internal variables + INTEGER(I4B) :: k1, k2, ii, p, q + REAL(DFP) :: o1, o2 + + dim1 = SIZE(L1, 1) + dim2 = (pb - 1) * (qb - 1) + dim3 = 2 + + o1 = REAL(faceOrient(1), kind=DFP) + o2 = REAL(faceOrient(2), kind=DFP) + p = pb + q = qb + + IF (faceOrient(3) .LT. 0_I4B) THEN + p = qb + q = pb + END IF + + DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1) + ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 1) = & + (o1**k1) * (o2**k2) * dL1(ii, k1) * L2(ii, k2) + + ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 2) = & + (o1**k1) * (o2**k2) * L1(ii, k1) * dL2(ii, k2) + END DO + +END SUBROUTINE CellBasisGradient_Quadrangle2_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Quadrangle_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_ +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1] +CALL HeirarchicalBasis_Quadrangle_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, & + pe3Orient=orient, pe4Orient=orient, qe1Orient=orient, qe2Orient=orient, & + faceOrient=faceOrient, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle1_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL HeirarchicalBasis_Quadrangle_( & + pb=p, pe3=p, pe4=p, qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! HeirarchicalBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle2_ +CALL HeirarchicalBasis_Quadrangle_( & + pb=p, pe3=p, pe4=p, qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, & + ncol=ncol) +END PROCEDURE HeirarchicalBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle3 +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(xij, 2) +ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL HeirarchicalBasis_Quadrangle_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, & + pe3Orient=pe3Orient, pe4Orient=pe4Orient, qe1Orient=qe1Orient, & + qe2Orient=qe2Orient, faceOrient=faceOrient, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE HeirarchicalBasis_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_ +INTEGER(I4B) :: indx(4), maxP, maxQ +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :) +LOGICAL(LGT) :: isok + +nrow = SIZE(xij, 2) +! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 +ncol = 0 + +maxP = MAX(pe3, pe4, pb) +maxQ = MAX(qe1, qe2, qb) + +ALLOCATE (L1(1:nrow, 0:maxP), L2(1:nrow, 0:maxQ)) + +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) + +! Vertex basis function +CALL VertexBasis_Quadrangle3_(L1=L1, L2=L2, ans=ans, nrow=indx(1), & + ncol=indx(2)) + +ncol = indx(2) + +! Bottom Horizontal Edge +isok = (pe3 .GE. 2_I4B) +IF (isok) THEN + CALL BottomHorizontalEdgeBasis_Quadrangle_( & + order=pe3, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), & + orient=pe3Orient, offset=ncol) + ncol = ncol + indx(2) +END IF + +! Right Vertical Edge +isok = (qe2 .GE. 2_I4B) +IF (isok) THEN + CALL RightVerticalEdgeBasis_Quadrangle_( & + order=qe2, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), & + orient=qe2Orient, offset=ncol) + ncol = ncol + indx(2) +END IF + +! Top Horizontal Edge +isok = (pe4 .GE. 2_I4B) +IF (isok) THEN + CALL TopHorizontalEdgeBasis_Quadrangle_( & + order=pe4, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), & + orient=pe4Orient, offset=ncol) + ncol = ncol + indx(2) +END IF + +! Left Vertical Edge +isok = (qe1 .GE. 2_I4B) +IF (isok) THEN + CALL LeftVerticalEdgeBasis_Quadrangle_( & + order=qe1, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), & + orient=qe1Orient, offset=ncol) + ncol = ncol + indx(2) +END IF + +! Cell basis function +isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) +IF (isok) THEN + CALL CellBasis_Quadrangle2_( & + pb=pb, qb=qb, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), & + faceOrient=faceOrient, offset=ncol) + ncol = ncol + indx(2) +END IF + +DEALLOCATE (L1, L2) +END PROCEDURE HeirarchicalBasis_Quadrangle3_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalBasisGradient_Quadrangle1_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ +INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(3) = [1, 1, 1] +CALL HeirarchicalBasisGradient_Quadrangle3_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, & + qe1Orient=orient, qe2Orient=orient, pe3Orient=orient, pe4Orient=orient, & + faceOrient=faceOrient, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle1_ + +!---------------------------------------------------------------------------- +! HeirarchicalBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL HeirarchicalBasisGradient_Quadrangle2_(p=p, q=q, xij=xij, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2_ +CALL HeirarchicalBasisGradient_Quadrangle1_( & + pb=p, pe3=p, pe4=p, qb=q, qe1=q, qe2=q, xij=xij, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle3 +INTEGER(I4B) :: dim1, dim2, dim3 +dim1 = SIZE(xij, 2) +dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1 +dim3 = 2 + +ALLOCATE (ans(1:dim1, 1:dim2, 1:dim3)) + +CALL HeirarchicalBasisGradient_Quadrangle3_( & + pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, qe2=qe2, xij=xij, & + qe1Orient=qe1Orient, qe2Orient=qe2Orient, pe3Orient=pe3Orient, & + pe4Orient=pe4Orient, faceOrient=faceOrient, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ +INTEGER(I4B) :: maxP, maxQ, indx(3) +REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :), dL1(:, :), dL2(:, :) +LOGICAL(LGT) :: isok + +dim1 = SIZE(xij, 2) +dim2 = 0 +dim3 = 2 + +maxP = MAX(pe3, pe4, pb) +maxQ = MAX(qe1, qe2, qb) + +ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), & + dL1(1:dim1, 0:maxP), dL2(1:dim1, 0:maxQ)) + +CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2)) +CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2)) + +CALL LobattoGradientEvalAll_(n=maxP, x=xij(1, :), ans=dL1, nrow=indx(1), & + ncol=indx(2)) +CALL LobattoGradientEvalAll_(n=maxQ, x=xij(2, :), ans=dL2, nrow=indx(1), & + ncol=indx(2)) + +CALL VertexBasisGradient_Quadrangle2_( & + L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), dim2=indx(2), & + dim3=indx(3)) + +dim2 = indx(2) + +! Bottom Horizontal Edge basis function +isok = (pe3 .GE. 2_I4B) +IF (isok) THEN + CALL BottomHorizontalEdgeBasisGradient_Quadrangle_( & + order=pe3, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), & + dim2=indx(2), dim3=indx(3), orient=pe3Orient, offset=dim2) + dim2 = dim2 + indx(2) +END IF + +! Right Vertical Edge basis function +isok = (qe2 .GE. 2_I4B) +IF (isok) THEN + CALL RightVerticalEdgeBasisGradient_Quadrangle_( & + order=qe2, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), & + dim2=indx(2), dim3=indx(3), orient=qe2Orient, offset=dim2) + dim2 = dim2 + indx(2) +END IF + +! Top Horizontal Edge basis function +isok = (pe4 .GE. 2_I4B) +IF (isok) THEN + CALL TopHorizontalEdgeBasisGradient_Quadrangle_( & + order=pe4, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), & + dim2=indx(2), dim3=indx(3), orient=pe4Orient, offset=dim2) + dim2 = dim2 + indx(2) +END IF + +! Left Vertical Edge basis function +isok = (qe1 .GE. 2_I4B) +IF (isok) THEN + CALL LeftVerticalEdgeBasisGradient_Quadrangle_( & + order=qe1, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), & + dim2=indx(2), dim3=indx(3), orient=qe1Orient, offset=dim2) + dim2 = dim2 + indx(2) +END IF + +! Cell basis function +isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B) +IF (isok) THEN + CALL CellBasisGradient_Quadrangle2_( & + pb=pb, qb=qb, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, & + dim1=indx(1), dim2=indx(2), dim3=indx(3), faceOrient=faceOrient, & + offset=dim2) + + dim2 = dim2 + indx(2) +END IF + +DEALLOCATE (L1, L2, dL1, dL2) +END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE HierarchicalMethods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90 new file mode 100644 index 000000000..3b1eb41eb --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90 @@ -0,0 +1,632 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) InterpolationPointMethods +USE LineInterpolationUtility, ONLY: InterpolationPoint_Line_ +USE ReallocateUtility, ONLY: Reallocate +USE MappingUtility, ONLY: FromBiUnitQuadrangle2Quadrangle_ + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +nrow = 2_I4B +isok = PRESENT(xij) +IF (isok) nrow = SIZE(xij, 1) + +ncol = LagrangeDOF_Quadrangle(order=order) + +ALLOCATE (ans(nrow, ncol)) + +CALL EquidistancePoint_Quadrangle1_(order=order, ans=ans, nrow=nrow, & + ncol=ncol, xij=xij) + +END PROCEDURE EquidistancePoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle1_ +CALL EquidistancePoint_Quadrangle2_(p=order, q=order, ans=ans, nrow=nrow, & + ncol=ncol, xij=xij) +END PROCEDURE EquidistancePoint_Quadrangle1_ + +!---------------------------------------------------------------------------- +! EquidistancePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +ncol = (p + 1) * (q + 1) +ALLOCATE (ans(nrow, ncol)) +CALL EquidistancePoint_Quadrangle2_(p=p, q=q, ans=ans, nrow=nrow, ncol=ncol, & + xij=xij) +END PROCEDURE EquidistancePoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistancePoint_Quadrangle2_ +CALL InterpolationPoint_Quadrangle2_( & + p=p, q=q, ipType1=TypeInterpolationOpt%equidistance, & + ipType2=TypeInterpolationOpt%equidistance, ans=ans, & + nrow=nrow, ncol=ncol, layout="VEFC", xij=xij) +END PROCEDURE EquidistancePoint_Quadrangle2_ + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +isok = PRESENT(xij) + +IF (isok) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2 +END IF + +ncol = LagrangeInDOF_Quadrangle(order=order) + +IF (ncol .EQ. 0) THEN + ALLOCATE (ans(0, 0)) + RETURN +END IF + +ALLOCATE (ans(nrow, ncol)) +ans(1:nrow, 1:ncol) = EquidistanceInPoint_Quadrangle2(p=order, q=order, & + xij=xij) +END PROCEDURE EquidistanceInPoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! EquidistanceInPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE EquidistanceInPoint_Quadrangle2 +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: a, b, nrow, ncol +LOGICAL(LGT) :: isok + +a = LagrangeDOF_Quadrangle(p=p, q=q) +b = LagrangeInDOF_Quadrangle(p=p, q=q) + +isok = PRESENT(xij) +IF (isok) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2 +END IF + +ALLOCATE (temp(nrow, a)) + +CALL EquidistancePoint_Quadrangle2_(p=p, q=q, xij=xij, ans=temp, & + nrow=nrow, ncol=ncol) + +IF (b .EQ. 0) THEN + ALLOCATE (ans(0, 0)) +ELSE + ALLOCATE (ans(nrow, b)) + + ans(1:nrow, 1:b) = temp(1:nrow, a - b + 1:) +END IF + +DEALLOCATE (temp) + +END PROCEDURE EquidistanceInPoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Quadrangle +CALL IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, temp, p, q, 1_I4B) +END PROCEDURE IJ2VEFC_Quadrangle + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise +! internal variables +INTEGER(I4B) :: cnt, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B), PARAMETER :: tEdges = 4 +INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & + pointsOrder(4) +REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & + temp_in(:, :) + +LOGICAL(LGT) :: isok, abool + +! vertices +N = (p + 1) * (q + 1) +cnt = 0 +ll = -1 + +CALL GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, startNode) + +isok = (p .EQ. 0) .AND. (q .EQ. 0) +IF (isok) THEN + temp(1, 1) = xi(1, 1) + temp(2, 1) = eta(1, 1) + RETURN +END IF + +! INFO: This case is p = 0 and q .GE. 1 +abool = (p .EQ. 0) .AND. (q .GE. 1) +IF (abool) THEN + DO jj = 1, q + 1 + cnt = cnt + 1 + temp(1, jj) = xi(1, jj) + temp(2, jj) = eta(1, jj) + END DO + RETURN +END IF + +! INFO: This case is q = 0 and p .GE. 1 +abool = (q .EQ. 0) .AND. (p .GE. 1) +IF (abool) THEN + DO ii = 1, p + 1 + cnt = cnt + 1 + temp(1, ii) = xi(ii, 1) + temp(2, ii) = eta(ii, 1) + END DO + RETURN +END IF + +ij(1, 1) = 1 +ij(2, 1) = 1 + +ij(1, 2) = p + 1 +ij(2, 2) = 1 + +ij(1, 3) = p + 1 +ij(2, 3) = q + 1 + +ij(1, 4) = 1 +ij(2, 4) = q + 1 + +isok = (p .GE. 1) .AND. (q .GE. 1) + +IF (isok) THEN + + DO ii = 1, 4 + cnt = cnt + 1 + jj = pointsOrder(ii) + temp(1, ii) = xi(ij(1, jj), ij(2, jj)) + + temp(2, ii) = eta(ij(1, jj), ij(2, jj)) + + END DO + +END IF + +abool = (p .EQ. 1) .AND. (q .EQ. 1) +IF (abool) RETURN + +isok = (p .GE. 1) .AND. (q .GE. 1) +IF (.NOT. isok) RETURN + +DO iedge = 1, tEdges + p1 = edgeConnectivity(1, iedge) + p2 = edgeConnectivity(2, iedge) + + IF (ij(1, p1) .EQ. ij(1, p2)) THEN + ii1 = ij(1, p1) + ii2 = ii1 + dii = 1 + ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN + ii1 = ij(1, p1) + 1 + ii2 = ij(1, p2) - 1 + dii = 1 + ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN + ii1 = ij(1, p1) - 1 + ii2 = ij(1, p2) + 1 + dii = -1 + END IF + + IF (ij(2, p1) .EQ. ij(2, p2)) THEN + jj1 = ij(2, p1) + jj2 = jj1 + djj = 1 + ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN + jj1 = ij(2, p1) + 1 + jj2 = ij(2, p2) - 1 + djj = 1 + ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN + jj1 = ij(2, p1) - 1 + jj2 = ij(2, p2) + 1 + djj = -1 + END IF + + DO ii = ii1, ii2, dii + DO jj = jj1, jj2, djj + cnt = cnt + 1 + temp(1, cnt) = xi(ii, jj) + temp(2, cnt) = eta(ii, jj) + END DO + END DO +END DO + +! internal nodes +isok = (p .GE. 2) .AND. (q .GE. 2) +IF (.NOT. isok) RETURN + +CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) +CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) +CALL Reallocate(temp_in, 2, SIZE(xi_in)) + +IF (p .LE. 1_I4B) THEN + ii1 = 1 + ii2 = 1 +ELSE + ii1 = 2 + ii2 = p +END IF + +IF (q .LE. 1_I4B) THEN + jj1 = 1 + jj2 = 1 +ELSE + jj1 = 2 + jj2 = q +END IF + +xi_in = xi(ii1:ii2, jj1:jj2) +eta_in = eta(ii1:ii2, jj1:jj2) + +CALL IJ2VEFC_Quadrangle_Clockwise(xi=xi_in, & + eta=eta_in, & + temp=temp_in, & + p=MAX(p - 2, 0_I4B), & + q=MAX(q - 2, 0_I4B), & + startNode=startNode) + +ii1 = cnt + 1 +ii2 = ii1 + SIZE(temp_in, 2) - 1 +temp(1:2, ii1:ii2) = temp_in + +IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) +IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) +IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) + +END PROCEDURE IJ2VEFC_Quadrangle_Clockwise + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise +! internal variables +INTEGER(I4B) :: cnt, ii, jj, ll, N, ij(2, 4), iedge, p1, p2 +INTEGER(I4B), PARAMETER :: tEdges = 4 +INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, & + pointsOrder(4) +REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), & + temp_in(:, :) +LOGICAL(LGT) :: isok, abool + +! vertices +N = (p + 1) * (q + 1) +cnt = 0 +ll = -1 + +CALL GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, startNode) + +isok = (p .EQ. 0) .AND. (q .EQ. 0) +IF (isok) THEN + temp(1, 1) = xi(1, 1) + temp(2, 1) = eta(1, 1) + RETURN +END IF + +ij(1:2, 1) = [1, 1] +ij(1:2, 2) = [p + 1, 1] +ij(1:2, 3) = [p + 1, q + 1] +ij(1:2, 4) = [1, q + 1] + +isok = (p .GE. 1) .AND. (q .GE. 1) +IF (isok) THEN + DO ii = 1, 4 + cnt = cnt + 1 + jj = pointsOrder(ii) + temp(1:2, ii) = [& + & xi(ij(1, jj), ij(2, jj)), & + & eta(ij(1, jj), ij(2, jj)) & + & ] + END DO + + abool = (p .EQ. 1) .AND. (q .EQ. 1) + IF (abool) RETURN + +ELSE + + DO ii = 1, MIN(p, 1) + 1 + DO jj = 1, MIN(q, 1) + 1 + cnt = cnt + 1 + temp(1:2, cnt) = [& + & xi(ij(1, cnt), ij(2, cnt)), & + & eta(ij(1, cnt), ij(2, cnt))] + END DO + END DO +END IF + +IF (ALL([p, q] .GE. 1_I4B)) THEN + DO iedge = 1, tEdges + p1 = edgeConnectivity(1, iedge) + p2 = edgeConnectivity(2, iedge) + + IF (ij(1, p1) .EQ. ij(1, p2)) THEN + ii1 = ij(1, p1) + ii2 = ii1 + dii = 1 + ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN + ii1 = ij(1, p1) + 1 + ii2 = ij(1, p2) - 1 + dii = 1 + ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN + ii1 = ij(1, p1) - 1 + ii2 = ij(1, p2) + 1 + dii = -1 + END IF + + IF (ij(2, p1) .EQ. ij(2, p2)) THEN + jj1 = ij(2, p1) + jj2 = jj1 + djj = 1 + ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN + jj1 = ij(2, p1) + 1 + jj2 = ij(2, p2) - 1 + djj = 1 + ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN + jj1 = ij(2, p1) - 1 + jj2 = ij(2, p2) + 1 + djj = -1 + END IF + + DO ii = ii1, ii2, dii + DO jj = jj1, jj2, djj + cnt = cnt + 1 + temp(:, cnt) = [xi(ii, jj), eta(ii, jj)] + END DO + END DO + END DO + + ! internal nodes + IF (ALL([p, q] .GE. 2_I4B)) THEN + + CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B)) + CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2)) + CALL Reallocate(temp_in, 2, SIZE(xi_in)) + + IF (p .LE. 1_I4B) THEN + ii1 = 1 + ii2 = 1 + ELSE + ii1 = 2 + ii2 = p + END IF + + IF (q .LE. 1_I4B) THEN + jj1 = 1 + jj2 = 1 + ELSE + jj1 = 2 + jj2 = q + END IF + + xi_in = xi(ii1:ii2, jj1:jj2) + eta_in = eta(ii1:ii2, jj1:jj2) + + CALL IJ2VEFC_Quadrangle_AntiClockwise( & + xi=xi_in, eta=eta_in, temp=temp_in, p=MAX(p - 2, 0_I4B), & + q=MAX(q - 2, 0_I4B), startNode=startNode) + + ii1 = cnt + 1 + ii2 = ii1 + SIZE(temp_in, 2) - 1 + temp(1:2, ii1:ii2) = temp_in + END IF + +END IF + +IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in) +IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in) +IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in) + +END PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle1 +ans = InterpolationPoint_Quadrangle2( & + p=order, q=order, ipType1=ipType, ipType2=ipType, xij=xij, & + layout=layout, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda) +END PROCEDURE InterpolationPoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle1_ +CALL InterpolationPoint_Quadrangle2_( & + p=order, q=order, ipType1=ipType, ipType2=ipType, xij=xij, layout=layout, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE InterpolationPoint_Quadrangle1_ + +!---------------------------------------------------------------------------- +! InterpolationPoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle2 +INTEGER(I4B) :: nrow, ncol + +nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +ncol = (p + 1) * (q + 1) +ALLOCATE (ans(nrow, ncol)) + +CALL InterpolationPoint_Quadrangle2_( & + p=p, q=q, ipType1=ipType1, ipType2=ipType2, ans=ans, nrow=nrow, ncol=ncol, & + layout=layout, xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + alpha2=alpha2, beta2=beta2, lambda2=lambda2) + +END PROCEDURE InterpolationPoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE InterpolationPoint_Quadrangle2_ +REAL(DFP), PARAMETER :: biunit_xij(2) = [-1.0_DFP, 1.0_DFP] + +REAL(DFP) :: x(p + 1), y(q + 1), xi(p + 1, q + 1), eta(p + 1, q + 1) +INTEGER(I4B) :: ii, jj, kk, tsize + +IF (PRESENT(xij)) THEN + nrow = SIZE(xij, 1) +ELSE + nrow = 2 +END IF + +ncol = (p + 1) * (q + 1) + +CALL InterpolationPoint_Line_( & + order=p, ipType=ipType1, xij=biunit_xij, layout="INCREASING", & + alpha=alpha1, beta=beta1, lambda=lambda1, ans=x, tsize=tsize) + +CALL InterpolationPoint_Line_( & + order=q, ipType=ipType2, xij=biunit_xij, layout="INCREASING", & + alpha=alpha2, beta=beta2, lambda=lambda2, ans=y, tsize=tsize) + +kk = 0 +DO ii = 1, p + 1 + DO jj = 1, q + 1 + kk = kk + 1 + xi(ii, jj) = x(ii) + ans(1, kk) = x(ii) + + eta(ii, jj) = y(jj) + ans(2, kk) = y(jj) + END DO +END DO + +IF (layout(1:4) .EQ. "VEFC") THEN + CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=ans(1:2, 1:ncol), p=p, q=q) +END IF + +IF (PRESENT(xij)) THEN + CALL FromBiUnitQuadrangle2Quadrangle_( & + xin=ans(1:2, 1:ncol), x1=xij(:, 1), x2=xij(:, 2), & + x3=xij(:, 3), x4=xij(:, 4), ans=ans, nrow=ii, ncol=jj) +END IF + +END PROCEDURE InterpolationPoint_Quadrangle2_ + +!---------------------------------------------------------------------------- +! GetEdgeConnectivityHelpAntiClock +!---------------------------------------------------------------------------- + +PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, & + pointsOrder, startNode) + INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) + INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) + INTEGER(I4B), INTENT(IN) :: startNode + + SELECT CASE (startNode) + CASE (1) + edgeConnectivity(1:2, 1) = [1, 2] + edgeConnectivity(1:2, 2) = [2, 3] + edgeConnectivity(1:2, 3) = [3, 4] + edgeConnectivity(1:2, 4) = [4, 1] + pointsOrder = [1, 2, 3, 4] + CASE (2) + edgeConnectivity(1:2, 1) = [2, 3] + edgeConnectivity(1:2, 2) = [3, 4] + edgeConnectivity(1:2, 3) = [4, 1] + edgeConnectivity(1:2, 4) = [1, 2] + pointsOrder = [2, 3, 4, 1] + CASE (3) + edgeConnectivity(1:2, 1) = [3, 4] + edgeConnectivity(1:2, 2) = [4, 1] + edgeConnectivity(1:2, 3) = [1, 2] + edgeConnectivity(1:2, 4) = [2, 3] + pointsOrder = [3, 4, 1, 2] + CASE (4) + edgeConnectivity(1:2, 1) = [4, 1] + edgeConnectivity(1:2, 2) = [1, 2] + edgeConnectivity(1:2, 3) = [2, 3] + edgeConnectivity(1:2, 4) = [3, 4] + pointsOrder = [4, 1, 2, 3] + END SELECT + +END SUBROUTINE GetEdgeConnectivityHelpAntiClock + +!---------------------------------------------------------------------------- +! GetEdgeConnectivityHelpClock +!---------------------------------------------------------------------------- + +PURE SUBROUTINE GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, & + startNode) + INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :) + INTEGER(I4B), INTENT(OUT) :: pointsOrder(:) + INTEGER(I4B), INTENT(IN) :: startNode + + SELECT CASE (startNode) + CASE (1) + edgeConnectivity(1:2, 1) = [1, 4] + edgeConnectivity(1:2, 2) = [4, 3] + edgeConnectivity(1:2, 3) = [3, 2] + edgeConnectivity(1:2, 4) = [2, 1] + pointsOrder = [1, 4, 3, 2] + CASE (2) + edgeConnectivity(1:2, 1) = [2, 1] + edgeConnectivity(1:2, 2) = [1, 4] + edgeConnectivity(1:2, 3) = [4, 3] + edgeConnectivity(1:2, 4) = [3, 2] + pointsOrder = [2, 1, 4, 3] + CASE (3) + edgeConnectivity(1:2, 1) = [3, 2] + edgeConnectivity(1:2, 2) = [2, 1] + edgeConnectivity(1:2, 3) = [1, 4] + edgeConnectivity(1:2, 4) = [4, 3] + pointsOrder = [3, 2, 1, 4] + CASE (4) + edgeConnectivity(1:2, 1) = [4, 3] + edgeConnectivity(1:2, 2) = [3, 2] + edgeConnectivity(1:2, 3) = [2, 1] + edgeConnectivity(1:2, 4) = [1, 4] + pointsOrder = [4, 3, 2, 1] + END SELECT + +END SUBROUTINE GetEdgeConnectivityHelpClock + +END SUBMODULE InterpolationPointMethods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 new file mode 100644 index 000000000..4b0cd5320 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 @@ -0,0 +1,587 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) LagrangeMethods +USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ +USE GE_LUMethods, ONLY: GetLU, LUSolve +USE InputUtility, ONLY: Input +USE ErrorHandling, ONLY: Errormsg +USE F95_BLAS, ONLY: GEMM +USE StringUtility, ONLY: UpperCase +USE GE_CompRoutineMethods, ONLY: GetInvMat + +IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "QuadrangleInterpolationUtility@LagrangeMethods" +#endif + +CONTAINS + +!---------------------------------------------------------------------------- +! LagrangeDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Quadrangle1 +ans = (order + 1)**2 +END PROCEDURE LagrangeDOF_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDOF_Quadrangle2 +ans = (p + 1) * (q + 1) +END PROCEDURE LagrangeDOF_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Quadrangle1 +ans = (order - 1)**2 +END PROCEDURE LagrangeInDOF_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeInDOF_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeInDOF_Quadrangle2 +ans = (p - 1) * (q - 1) +END PROCEDURE LagrangeInDOF_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +nrow = LagrangeDOF_Quadrangle(order=order) +ALLOCATE (ans(nrow, 2)) +CALL LagrangeDegree_Quadrangle1_(ans=ans, nrow=nrow, ncol=ncol, order=order) +END PROCEDURE LagrangeDegree_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle1_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Quadrangle1_ +CALL LagrangeDegree_Quadrangle2_(ans=ans, p=order, q=order, nrow=nrow, & + ncol=ncol) +END PROCEDURE LagrangeDegree_Quadrangle1_ + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Quadrangle2 +INTEGER(I4B) :: nrow, ncol + +nrow = LagrangeDOF_Quadrangle(p=p, q=q) +ALLOCATE (ans(nrow, 2)) +CALL LagrangeDegree_Quadrangle2_(ans=ans, nrow=nrow, ncol=ncol, & + p=p, q=q) +END PROCEDURE LagrangeDegree_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle2_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeDegree_Quadrangle2_ +INTEGER(I4B) :: ii, jj, p1 + +nrow = LagrangeDOF_Quadrangle(p=p, q=q) +ncol = 2 +p1 = p + 1 + +DO CONCURRENT(jj=0:q, ii=0:p) + ans(p1 * jj + ii + 1, 1) = ii + ans(p1 * jj + ii + 1, 2) = jj +END DO + +END PROCEDURE LagrangeDegree_Quadrangle2_ + +!---------------------------------------------------------------------------- +! LagrangeDegree_Quadrangle2_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE MonomialBasis_Quadrangle_ +INTEGER(I4B) :: ii, jj, p1, ip + +nrow = SIZE(xij, 2) +ncol = (p + 1) * (q + 1) + +p1 = p + 1 + +DO CONCURRENT(ii=0:p, jj=0:q, ip=1:nrow) + ans(ip, p1 * jj + ii + 1) = xij(1, ip)**ii * xij(2, ip)**jj +END DO + +END PROCEDURE MonomialBasis_Quadrangle_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle1 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Quadrangle1_(order=order, i=i, xij=xij, ans=ans, & + tsize=tsize) +END PROCEDURE LagrangeCoeff_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle1_ +REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V +INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv +INTEGER(I4B) :: info, nrow, ncol + +tsize = SIZE(xij, 2) + +ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LagrangeVandermonde_( & + order=order, xij=xij, elemType=TypeElemNameOpt%Quadrangle, ans=V, & + nrow=nrow, ncol=ncol) +CALL GetLU(A=V, IPIV=ipiv, info=info) +CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle1_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle2 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Quadrangle2_(order=order, i=i, v=v, isVandermonde=.TRUE., & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Quadrangle2 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle2_ +REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp +INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv +INTEGER(I4B) :: info + +tsize = SIZE(v, 1) + +vtemp = v; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B +CALL GetLU(A=vtemp, IPIV=ipiv, info=info) +CALL LUSolve(A=vtemp, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle2_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle3 +INTEGER(I4B) :: tsize +CALL LagrangeCoeff_Quadrangle3_(order=order, i=i, v=v, ipiv=ipiv, & + ans=ans, tsize=tsize) +END PROCEDURE LagrangeCoeff_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle3_ +INTEGER(I4B) :: info +tsize = SIZE(v, 1) +ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP +CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info) +END PROCEDURE LagrangeCoeff_Quadrangle3_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle4 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Quadrangle4_( & + order=order, xij=xij, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeCoeff_Quadrangle4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle4_ +INTEGER(I4B) :: basisType0 + +basisType0 = Input(default=TypePolynomialOpt%monomial, option=basisType) + +IF (basisType0 .EQ. TypePolynomialOpt%hierarchical) THEN + CALL HeirarchicalBasis_Quadrangle2_(p=order, q=order, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + CALL GetInvMat(ans(1:nrow, 1:ncol)) + RETURN +END IF + +! ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=order, q=order, & +CALL TensorProdBasis_Quadrangle1_( & + p=order, q=order, xij=xij, basisType1=basisType0, basisType2=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) + +CALL GetInvMat(ans(1:nrow, 1:ncol)) + +END PROCEDURE LagrangeCoeff_Quadrangle4_ + +!---------------------------------------------------------------------------- +! LagrangeCoeff_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle5 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeCoeff_Quadrangle5_( & + p=p, q=q, xij=xij, basisType1=basisType1, basisType2=basisType2, & + alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, beta2=beta2, & + lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE LagrangeCoeff_Quadrangle5 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Quadrangle5_ +INTEGER(I4B) :: basisType(2) +LOGICAL(LGT) :: isok + +basisType(1) = Input(default=TypePolynomialOpt%monomial, option=basisType1) +basisType(2) = Input(default=TypePolynomialOpt%monomial, option=basisType2) + +isok = ALL(basisType .EQ. TypePolynomialOpt%hierarchical) +IF (isok) THEN + ! ans(1:nrow, 1:ncol) = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij) + CALL HeirarchicalBasis_Quadrangle2_(p=p, q=q, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) + + CALL GetInvMat(ans(1:nrow, 1:ncol)) + RETURN +END IF + +CALL TensorProdBasis_Quadrangle1_( & + p=p, q=q, xij=xij, basisType1=basisType(1), alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, basisType2=basisType(2), alpha2=alpha2, beta2=beta2, & + lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) + +CALL GetInvMat(ans(1:nrow, 1:ncol)) + +END PROCEDURE LagrangeCoeff_Quadrangle5_ + +!---------------------------------------------------------------------------- +! LagrangeEvallAll_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle1 +INTEGER(I4B) :: tsize +CALL LagrangeEvalAll_Quadrangle1_( & + order=order, x=x, xij=xij, ans=ans, tsize=tsize, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE LagrangeEvalAll_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle1_ +LOGICAL(LGT) :: firstCall0, isCoeff +INTEGER(I4B) :: ii, basisType0, degree(SIZE(xij, 2), 2), indx(2) +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), & + x21(2, 1) + +tsize = SIZE(xij, 2) + +basisType0 = INPUT(default=TypePolynomialOpt%monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +isCoeff = PRESENT(coeff) +IF (isCoeff) THEN + + IF (firstCall0) THEN + CALL LagrangeCoeff_Quadrangle_( & + order=order, xij=xij, basisType=basisType0, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff, nrow=indx(1), ncol=indx(2)) + END IF + + ! coeff0 = TRANSPOSE(coeff) + coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize) + +ELSE + + CALL LagrangeCoeff_Quadrangle_( & + order=order, xij=xij, basisType=basisType0, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff0, nrow=indx(1), ncol=indx(2)) + + ! coeff0 = TRANSPOSE(coeff0) + +END IF + +SELECT CASE (basisType0) + +CASE (TypePolynomialOpt%monomial) + + CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) +#ifdef DEBUG_VER + + IF (tsize .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Quadrangle1", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN + END IF + +#endif + + DO ii = 1, tsize + indx(1:2) = degree(ii, 1:2) + xx(1, ii) = x(1)**indx(1) * x(2)**indx(2) + END DO + +CASE (TypePolynomialOpt%hierarchical) + + ! xx = HeirarchicalBasis_Quadrangle( & + x21(1:2, 1) = x(1:2) + CALL HeirarchicalBasis_Quadrangle_( & + p=order, q=order, xij=x21, ans=xx, nrow=indx(1), ncol=indx(2)) + +CASE DEFAULT + + x21(1:2, 1) = x(1:2) + CALL TensorProdBasis_Quadrangle_( & + p=order, q=order, xij=x21, basisType1=basisType0, basisType2=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, ans=xx, nrow=indx(1), ncol=indx(2)) + +END SELECT + +DO CONCURRENT(ii=1:tsize) + ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :)) +END DO + +END PROCEDURE LagrangeEvalAll_Quadrangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL LagrangeEvalAll_Quadrangle2_( & + order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda) +END PROCEDURE LagrangeEvalAll_Quadrangle2 + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Quadrangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle2_ +LOGICAL(LGT) :: isok, firstCall0 +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2)) + +firstCall0 = Input(default=.TRUE., option=firstCall) +isok = PRESENT(coeff) + +IF (isok) THEN + + CALL LagrangeEvalAll_Quadrangle_( & + order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff, & + xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) + +ELSE + + CALL LagrangeEvalAll_Quadrangle_( & + order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff0, & + xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) + +END IF +END PROCEDURE LagrangeEvalAll_Quadrangle2_ + +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Quadrangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Quadrangle3_ +INTEGER(I4B) :: basisType0, indx(2) + +! coeff0(SIZE(xij, 2), SIZE(xij, 2)) +! xx(SIZE(x, 2), SIZE(xij, 2)) +! degree(SIZE(xij, 2), 2) + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) + +basisType0 = INPUT(default=TypePolynomialOpt%Monomial, option=basisType) + +! coeff = LagrangeCoeff_Quadrangle(& +IF (firstCall) & + CALL LagrangeCoeff_Quadrangle_( & + order=order, xij=xij, basisType=basisType0, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff, nrow=indx(1), ncol=indx(2)) + +SELECT CASE (basisType0) + +CASE (TypePolynomialOpt%Monomial) + CALL MonomialBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & + nrow=indx(1), ncol=indx(2)) + +CASE (TypePolynomialOpt%Hierarchical) + CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, & + nrow=indx(1), ncol=indx(2)) + +CASE DEFAULT + CALL TensorProdBasis_Quadrangle_( & + p=order, q=order, xij=x, basisType1=basisType0, basisType2=basisType0, & + alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & + lambda2=lambda, ans=xx, nrow=indx(1), ncol=indx(2)) + +END SELECT + +! indx(1) should be equal to nrow +! indx(2) should be equal to ncol +! ans = MATMUL(xx, coeff0) +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx(1:nrow, 1:ncol), & + B=coeff(1:ncol, 1:ncol)) + +END PROCEDURE LagrangeEvalAll_Quadrangle3_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL LagrangeGradientEvalAll_Quadrangle1_( & + order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & + beta=beta, lambda=lambda) +END PROCEDURE LagrangeGradientEvalAll_Quadrangle1 + +!---------------------------------------------------------------------------- +! LagrangeGradientEvalAll_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ +LOGICAL(LGT) :: firstCall0, isCoeff +INTEGER(I4B) :: ii, basisType0, ai, bi, indx(3), degree(SIZE(xij, 2), 2), jj +REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), & + xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br, areal, breal + +dim1 = SIZE(x, 2) +dim2 = SIZE(xij, 2) +dim3 = 2 + +basisType0 = INPUT(default=TypePolynomialOpt%monomial, option=basisType) +firstCall0 = INPUT(default=.TRUE., option=firstCall) + +isCoeff = PRESENT(coeff) + +IF (isCoeff) THEN + + IF (firstCall0) THEN + ! coeff = LagrangeCoeff_Quadrangle(& + CALL LagrangeCoeff_Quadrangle_( & + order=order, xij=xij, basisType=basisType0, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff, nrow=indx(1), ncol=indx(2)) + END IF + + coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) + +ELSE + + ! coeff0 = LagrangeCoeff_Quadrangle(& + CALL LagrangeCoeff_Quadrangle_( & + order=order, xij=xij, basisType=basisType0, alpha=alpha, beta=beta, & + lambda=lambda, ans=coeff0, nrow=indx(1), ncol=indx(2)) + +END IF + +SELECT CASE (basisType0) + +CASE (TypePolynomialOpt%monomial) + ! degree = LagrangeDegree_Quadrangle(order=order) + CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), & + ncol=indx(2)) + +#ifdef DEBUG_VER + IF (dim2 .NE. SIZE(degree, 1)) THEN + CALL Errormsg(msg="tdof is not same as size(degree,1)", & + routine="LagrangeEvalAll_Quadrangle1", & + file=__FILE__, line=__LINE__, unitno=stderr) + RETURN + END IF +#endif + + DO ii = 1, dim2 + ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B) + bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B) + ar = REAL(degree(ii, 1_I4B), DFP) + br = REAL(degree(ii, 2_I4B), DFP) + + indx(1:2) = degree(ii, 1:2) + + DO jj = 1, dim1 + areal = (ar * x(1, jj)**ai) * x(2, jj)**indx(2) + breal = x(1, jj)**indx(1) * (br * x(2, jj)**bi) + xx(jj, ii, 1) = areal + xx(jj, ii, 2) = breal + + END DO + + END DO + +CASE (TypePolynomialOpt%hierarchical) + + ! xx = HeirarchicalBasisGradient_Quadrangle( & + CALL HeirarchicalBasisGradient_Quadrangle_( & + p=order, q=order, xij=x, ans=xx, dim1=indx(1), dim2=indx(2), dim3=indx(3)) + +CASE DEFAULT + + ! xx = OrthogonalBasisGradient_Quadrangle( & + CALL OrthogonalBasisGradient_Quadrangle_(p=order, q=order, xij=x, & + basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, & + lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, & + dim1=indx(1), dim2=indx(2), dim3=indx(3)) + +END SELECT + +DO ii = 1, 2 + ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0)) + ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0) +END DO + +END PROCEDURE LagrangeGradientEvalAll_Quadrangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + +END SUBMODULE LagrangeMethods diff --git a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 similarity index 55% rename from src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 rename to src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 index 800f72949..11cc697b5 100644 --- a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90 @@ -13,40 +13,32 @@ ! ! 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 +SUBMODULE(QuadrangleInterpolationUtility) Methods IMPLICIT NONE CONTAINS !---------------------------------------------------------------------------- -! Power +! RefElemDomain_Quadrangle !---------------------------------------------------------------------------- -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 +MODULE PROCEDURE RefElemDomain_Quadrangle +ans = "BIUNIT" +END PROCEDURE RefElemDomain_Quadrangle !---------------------------------------------------------------------------- -! +! FacetConnectivity +!---------------------------------------------------------------------------- + +MODULE PROCEDURE FacetConnectivity_Quadrangle +ans(1:2, 1) = [1, 2] +ans(1:2, 2) = [2, 3] +ans(1:2, 3) = [3, 4] +ans(1:2, 4) = [4, 1] +END PROCEDURE FacetConnectivity_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle3 !---------------------------------------------------------------------------- -END SUBMODULE PowerMethods +END SUBMODULE Methods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90 new file mode 100644 index 000000000..565f4ee37 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90 @@ -0,0 +1,206 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) QuadratureMethods +USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, & + QuadraturePoint_Line_ +USE MappingUtility, ONLY: FromBiUnitQuadrangle2Quadrangle_, & + FromBiUnitQuadrangle2UnitQuadrangle_, & + JacobianQuadrangle +USE StringUtility, ONLY: UpperCase + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! QuadratureNumber_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadratureNumber_Quadrangle +ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1) +ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2) +END PROCEDURE QuadratureNumber_Quadrangle + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle1 +INTEGER(I4B) :: nips(1), nrow, ncol + +nips(1) = QuadratureNumber_Line(order=order, quadType=quadType) + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF + +nrow = nrow + 1 +ncol = nips(1) * nips(1) + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, & + quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE QuadraturePoint_Quadrangle1 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle2 +INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol + +nipsx(1) = QuadratureNumber_Line(order=p, quadType=quadType1) +nipsy(1) = QuadratureNumber_Line(order=q, quadType=quadType2) + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF + +nrow = nrow + 1 +ncol = nipsx(1) * nipsy(1) + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, & + quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & + beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE QuadraturePoint_Quadrangle2 + +!---------------------------------------------------------------------------- +! QuadraturePoint_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle3 +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF + +nrow = nrow + 1 +ncol = nips(1) * nips(1) + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, & + quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, & + beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE QuadraturePoint_Quadrangle3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle4 +INTEGER(I4B) :: nrow, ncol + +IF (PRESENT(xij)) THEN + nrow = MAX(SIZE(xij, 1), 2) +ELSE + nrow = 2 +END IF + +nrow = nrow + 1 +ncol = nipsx(1) * nipsy(1) + +ALLOCATE (ans(1:nrow, 1:ncol)) + +CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, & + quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, & + xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, & + beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE QuadraturePoint_Quadrangle4 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE QuadraturePoint_Quadrangle1_ +! internal variables +REAL(DFP) :: x(4, nipsx(1)), y(2, nipsy(1)), areal +INTEGER(I4B) :: ii, jj, nsd, np, nq +CHARACTER(len=1) :: astr + +REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2]) + +IF (PRESENT(xij)) THEN + nsd = MAX(SIZE(xij, 1), 2) +ELSE + nsd = 2 +END IF + +nrow = nsd + 1 +ncol = nipsx(1) * nipsy(1) + +CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadType1, xij=x12, & + layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, ans=x, & + nrow=ii, ncol=np) + +CALL QuadraturePoint_Line_(nips=nipsy, quadType=quadType2, xij=x12, & + layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, ans=y, & + nrow=ii, ncol=nq) + +DO CONCURRENT(ii=1:np, jj=1:nq) + ans(1, nq * (ii - 1) + jj) = x(1, ii) + ans(2, nq * (ii - 1) + jj) = y(1, jj) + ans(nrow, nq * (ii - 1) + jj) = x(2, ii) * y(2, jj) +END DO + +IF (PRESENT(xij)) THEN + CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, :), x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, nrow=ii, ncol=jj) + + areal = JacobianQuadrangle(from="BIUNIT", to="QUADRANGLE", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN +END IF + +astr = UpperCase(refQuadrangle(1:1)) +IF (astr .EQ. "U") THEN + CALL FromBiUnitQuadrangle2UnitQuadrangle_(xin=ans(1:2, :), ans=ans, & + nrow=ii, ncol=jj) + + areal = JacobianQuadrangle(from="BIUNIT", to="UNIT", xij=xij) + + DO CONCURRENT(ii=1:ncol) + ans(nrow, ii) = ans(nrow, ii) * areal + END DO + + RETURN +END IF + +END PROCEDURE QuadraturePoint_Quadrangle1_ + +END SUBMODULE QuadratureMethods diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90 new file mode 100644 index 000000000..8ee7e7fc8 --- /dev/null +++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90 @@ -0,0 +1,163 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +SUBMODULE(QuadrangleInterpolationUtility) TensorProdMethods +USE LineInterpolationUtility, ONLY: BasisEvalAll_Line_, & + BasisGradientEvalAll_Line_ + +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! TensorProdOrthoPol_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle1 +INTEGER(I4B) :: nrow, ncol +CALL TensorProdBasis_Quadrangle1_( & + p=p, q=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol, basisType1=basisType1, & + basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + alpha2=alpha2, beta2=beta2, lambda2=lambda2) +END PROCEDURE TensorProdBasis_Quadrangle1 + +!---------------------------------------------------------------------------- +! TensorProdBasis_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle1_ +REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) +INTEGER(I4B) :: k1, k2, ii + +nrow = SIZE(xij, 2) +ncol = (p + 1) * (q + 1) + +CALL BasisEvalAll_Line_( & + order=p, x=xij(1, :), refLine="BIUNIT", basisType=basisType1, & + alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, nrow=k1, ncol=k2) + +CALL BasisEvalAll_Line_( & + order=q, x=xij(2, :), refLine="BIUNIT", basisType=basisType1, & + alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, nrow=k1, ncol=k2) + +DO CONCURRENT(k1=1:p + 1, k2=1:q + 1, ii=1:nrow) + ans(ii, (k2 - 1) * (p + 1) + k1) = P1(ii, k1) * Q1(ii, k2) +END DO + +END PROCEDURE TensorProdBasis_Quadrangle1_ + +!---------------------------------------------------------------------------- +! TensorProdOrthoPol_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle2 +INTEGER(I4B) :: nrow, ncol +CALL TensorProdBasis_Quadrangle2_( & + p=p, q=q, x=x, y=y, ans=ans, nrow=nrow, ncol=ncol, basisType1=basisType1, & + basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, & + alpha2=alpha2, beta2=beta2, lambda2=lambda2) +END PROCEDURE TensorProdBasis_Quadrangle2 + +!---------------------------------------------------------------------------- +! TensorProdOrthoPol_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasis_Quadrangle2_ +REAL(DFP) :: xij(2, SIZE(x) * SIZE(y)) +INTEGER(I4B) :: ii, jj + +nrow = SIZE(x) +ncol = SIZE(y) + +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + xij(1, ncol * (ii - 1) + jj) = x(ii) + xij(2, ncol * (ii - 1) + jj) = y(jj) +END DO + +CALL TensorProdBasis_Quadrangle1_( & + p=p, q=q, xij=xij, basisType1=basisType1, basisType2=basisType2, & + alpha1=alpha1, alpha2=alpha2, beta1=beta1, beta2=beta2, lambda1=lambda1, & + lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol) + +END PROCEDURE TensorProdBasis_Quadrangle2_ + +!---------------------------------------------------------------------------- +! TensorProdBasisGradient_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL TensorProdBasisGradient_Quadrangle1_( & + p=p, q=q, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + basisType1=basisType1, basisType2=basisType2, alpha1=alpha1, & + beta1=beta1, lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2) +END PROCEDURE TensorProdBasisGradient_Quadrangle1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_ +REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1) +REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1) +INTEGER(I4B) :: k1, k2, cnt, indx(3) + +dim1 = SIZE(xij, 2) +dim2 = (p + 1) * (q + 1) +dim3 = 2 + +! P1 +CALL BasisEvalAll_Line_( & + order=p, x=xij(1, :), refLine="BIUNIT", basisType=basisType1, & + alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, nrow=indx(1), & + ncol=indx(2)) + +! Q1 = BasisEvalAll_Line( & +CALL BasisEvalAll_Line_( & + order=q, x=xij(2, :), refLine="BIUNIT", basisType=basisType1, & + alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, nrow=indx(1), & + ncol=indx(2)) + +! dP1 = BasisGradientEvalAll_Line( & +CALL BasisGradientEvalAll_Line_( & + order=p, x=xij(1, :), refLine="BIUNIT", basisType=basisType1, & + alpha=alpha1, beta=beta1, lambda=lambda1, ans=dP1, nrow=indx(1), & + ncol=indx(2)) + +! dQ1 = BasisGradientEvalAll_Line( & +CALL BasisGradientEvalAll_Line_( & + order=q, x=xij(2, :), refLine="BIUNIT", basisType=basisType1, & + alpha=alpha2, beta=beta2, lambda=lambda2, ans=dQ1, nrow=indx(1), & + ncol=indx(2)) + +cnt = 0 + +DO k2 = 1, q + 1 + + DO k1 = 1, p + 1 + cnt = cnt + 1 + ans(1:dim1, cnt, 1) = dP1(1:dim1, k1) * Q1(1:dim1, k2) + ans(1:dim1, cnt, 2) = P1(1:dim1, k1) * dQ1(1:dim1, k2) + END DO + +END DO + +END PROCEDURE TensorProdBasisGradient_Quadrangle1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE TensorProdMethods diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90 similarity index 88% rename from src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 rename to src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90 index b7f438a7f..a530d0826 100644 --- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 +++ b/src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90 @@ -20,9 +20,7 @@ ! summary: This submodule contains method for [[ReferenceQuadrangle_]] SUBMODULE(ReferenceQuadrangle_Method) Methods - -USE GlobalData, ONLY: Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, & - Quadrangle16, Point, Line2, Equidistance, INT8 +USE GlobalData, ONLY: INT8 USE ReferenceElement_Method, ONLY: ReferenceTopology, DEALLOCATE, & ReferenceElement_Initiate => Initiate @@ -40,7 +38,7 @@ USE ApproxUtility, ONLY: OPERATOR(.approxeq.) -USE AppendUtility +USE AppendUtility, ONLY: OPERATOR(.append.) USE StringUtility, ONLY: UpperCase @@ -56,6 +54,8 @@ USE MiscUtility, ONLY: Int2Str +USE BaseType, ONLY: TypeElemNameOpt, TypeInterpolationOpt + IMPLICIT NONE CONTAINS @@ -65,15 +65,15 @@ MODULE PROCEDURE ElementName_Quadrangle SELECT CASE (elemType) -CASE (Quadrangle4) +CASE (TypeElemNameOpt%Quadrangle) ans = "Quadrangle4" -CASE (Quadrangle8) +CASE (TypeElemNameOpt%Quadrangle8) ans = "Quadrangle8" -CASE (Quadrangle9) +CASE (TypeElemNameOpt%Quadrangle9) ans = "Quadrangle9" -CASE (Quadrangle16) +CASE (TypeElemNameOpt%Quadrangle16) ans = "Quadrangle16" -CASE default +CASE DEFAULT ans = "" END SELECT END PROCEDURE ElementName_Quadrangle @@ -117,13 +117,13 @@ MODULE PROCEDURE TotalNodesInElement_Quadrangle SELECT CASE (elemType) -CASE (Quadrangle4) +CASE (TypeElemNameOpt%Quadrangle) ans = 4 -CASE (Quadrangle8) +CASE (TypeElemNameOpt%Quadrangle8) ans = 8 -CASE (Quadrangle9) +CASE (TypeElemNameOpt%Quadrangle9) ans = 9 -CASE (Quadrangle16) +CASE (TypeElemNameOpt%Quadrangle16) ans = 16 CASE DEFAULT ans = 0 @@ -136,13 +136,13 @@ MODULE PROCEDURE ElementOrder_Quadrangle SELECT CASE (elemType) -CASE (Quadrangle4) +CASE (TypeElemNameOpt%Quadrangle) ans = 1 -CASE (Quadrangle8) +CASE (TypeElemNameOpt%Quadrangle8) ans = 2 -CASE (Quadrangle9) +CASE (TypeElemNameOpt%Quadrangle9) ans = 2 -CASE (Quadrangle16) +CASE (TypeElemNameOpt%Quadrangle16) ans = 3 END SELECT END PROCEDURE ElementOrder_Quadrangle @@ -154,13 +154,13 @@ MODULE PROCEDURE ElementType_Quadrangle SELECT CASE (elemName) CASE ("Quadrangle4", "Quadrangle") - ans = Quadrangle4 + ans = TypeElemNameOpt%Quadrangle CASE ("Quadrangle8") - ans = Quadrangle8 + ans = TypeElemNameOpt%Quadrangle8 CASE ("Quadrangle9") - ans = Quadrangle9 + ans = TypeElemNameOpt%Quadrangle9 CASE ("Quadrangle16") - ans = Quadrangle16 + ans = TypeElemNameOpt%Quadrangle16 CASE DEFAULT ans = 0 END SELECT @@ -201,7 +201,7 @@ DO jj = 1, tsize ans(ii)%topology(jj) = Referencetopology( & - & nptrs=topo%nptrs(jj:jj), name=Point) + nptrs=topo%nptrs(jj:jj), name=TypeElemNameOpt%Point) END DO ans(ii)%topology(tsize + 1) = Referencetopology( & @@ -232,9 +232,10 @@ ans(ii)%xiDimension = 1 ans(ii)%order = order ans(ii)%name = ElementType_Line("Line"//tostring(order + 1)) - ans(ii)%interpolationPointType = Equidistance - ans(ii)%xij = InterpolationPoint_Line(order=order, ipType=Equidistance, & - layout="VEFC") + ans(ii)%interpolationPointType = TypeInterpolationOpt%Equidistance + ans(ii)%xij = InterpolationPoint_Line( & + order=order, ipType=TypeInterpolationOpt%Equidistance, & + layout="VEFC") ans(ii)%nsd = nsd ans(ii)%entityCounts = [order + 1, 1, 0, 0] @@ -242,7 +243,7 @@ DO jj = 1, order + 1 ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), & - name=Point) + name=TypeElemNameOpt%Point) END DO ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), & @@ -261,13 +262,13 @@ MODULE PROCEDURE Quadranglename1 SELECT CASE (order) CASE (1) - ans = Quadrangle4 + ans = TypeElemNameOpt%Quadrangle CASE (2) - ans = Quadrangle9 + ans = TypeElemNameOpt%Quadrangle9 CASE (3) - ans = Quadrangle16 + ans = TypeElemNameOpt%Quadrangle16 CASE (4:) - ans = Quadrangle16 + order - 3_I4B + ans = TypeElemNameOpt%Quadrangle16 + order - 3_I4B END SELECT END PROCEDURE Quadranglename1 @@ -308,19 +309,19 @@ obj%entityCounts = [4, 4, 1, 0] obj%xidimension = 2 -obj%name = Quadrangle4 +obj%name = TypeElemNameOpt%Quadrangle obj%order = 1 obj%NSD = NSD ALLOCATE (obj%topology(9)) -obj%topology(1) = ReferenceTopology([1], Point) -obj%topology(2) = ReferenceTopology([2], Point) -obj%topology(3) = ReferenceTopology([3], Point) -obj%topology(4) = ReferenceTopology([4], Point) -obj%topology(5) = ReferenceTopology([1, 2], Line2) -obj%topology(6) = ReferenceTopology([2, 3], Line2) -obj%topology(7) = ReferenceTopology([3, 4], Line2) -obj%topology(8) = ReferenceTopology([4, 1], Line2) -obj%topology(9) = ReferenceTopology([1, 2, 3, 4], Quadrangle4) +obj%topology(1) = ReferenceTopology([1], TypeElemNameOpt%Point) +obj%topology(2) = ReferenceTopology([2], TypeElemNameOpt%Point) +obj%topology(3) = ReferenceTopology([3], TypeElemNameOpt%Point) +obj%topology(4) = ReferenceTopology([4], TypeElemNameOpt%Point) +obj%topology(5) = ReferenceTopology([1, 2], TypeElemNameOpt%Line) +obj%topology(6) = ReferenceTopology([2, 3], TypeElemNameOpt%Line) +obj%topology(7) = ReferenceTopology([3, 4], TypeElemNameOpt%Line) +obj%topology(8) = ReferenceTopology([4, 1], TypeElemNameOpt%Line) +obj%topology(9) = ReferenceTopology([1, 2, 3, 4], TypeElemNameOpt%Quadrangle) obj%highorderElement => highorderElement_Quadrangle END PROCEDURE Initiate_ref_Quadrangle @@ -365,7 +366,7 @@ obj%NSD = refelem%NSD ALLOCATE (obj%topology(SUM(obj%entityCounts))) DO I = 1, NNS - obj%topology(I) = ReferenceTopology([I], Point) + obj%topology(I) = ReferenceTopology([I], TypeElemNameOpt%Point) END DO aintvec = [1, 2] .append.arange(5_I4B, 3_I4B + order) obj%topology(NNS + 1) = ReferenceTopology(aintvec, Linename(order=order)) @@ -663,11 +664,24 @@ END SUBROUTINE PARALLELOGRAMAREA2D ! GetFaceElemType_Quadrangle !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Quadrangle -INTEGER(I4B) :: order -order = ElementOrder_Quadrangle(Input(default=Quadrangle, option=elemType)) +MODULE PROCEDURE GetFaceElemType_Quadrangle1 +INTEGER(I4B) :: order, elemType0 + +elemType0 = Input(default=TypeElemNameOpt%Quadrangle, option=elemType) +order = ElementOrder_Quadrangle(elemType0) IF (PRESENT(faceElemType)) faceElemType(1:4) = LineName(order) IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = order + 1 -END PROCEDURE GetFaceElemType_Quadrangle +END PROCEDURE GetFaceElemType_Quadrangle1 + +!---------------------------------------------------------------------------- +! GetFaceElemType_Quadrangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Quadrangle2 +INTEGER(I4B) :: order +order = ElementOrder_Quadrangle(elemType) +faceElemType = LineName(order) +tFaceNodes = order + 1 +END PROCEDURE GetFaceElemType_Quadrangle2 END SUBMODULE Methods diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt index 9e9866be4..218d4895d 100644 --- a/src/submodules/QuadraturePoint/CMakeLists.txt +++ b/src/submodules/QuadraturePoint/CMakeLists.txt @@ -20,4 +20,6 @@ target_sources( ${PROJECT_NAME} PRIVATE ${src_path}/QuadraturePoint_Method@IOMethods.F90 ${src_path}/QuadraturePoint_Method@GetMethods.F90 - ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90) + ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90 + ${src_path}/QuadraturePoint_Method@FacetQuadratureMethods.F90 + ${src_path}/QuadraturePoint_Method@SetMethods.F90) diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 index cf90c2a59..93cb47ddd 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 @@ -15,8 +15,6 @@ ! along with this program. If not, see ! -!> author: Vikas Sharma, Ph. D. -! date: 3 March 2021 ! summary: Constructor methods for [[QuadraturePoint_]] SUBMODULE(QuadraturePoint_Method) ConstructorMethods @@ -24,9 +22,10 @@ USE ErrorHandling, ONLY: ErrorMsg -USE BaseInterpolation_Method, ONLY: BaseInterpolation_ToString, & - BaseInterpolation_ToInteger, & - BaseInterpolation_ToChar +USE BaseInterpolation_Method, ONLY: InterpolationPoint_ToChar, & + InterpolationPoint_ToInteger, & + InterpolationPoint_ToString + USE ReallocateUtility, ONLY: Reallocate USE ReferenceElement_Method, ONLY: ElementTopology, & @@ -57,7 +56,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePointIDToName -ans = BaseInterpolation_ToString(name) +ans = InterpolationPoint_ToString(name) END PROCEDURE QuadraturePointIDToName !---------------------------------------------------------------------------- @@ -65,7 +64,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_ToChar -ans = BaseInterpolation_ToChar(name) +ans = InterpolationPoint_ToChar(name) END PROCEDURE QuadraturePoint_ToChar !---------------------------------------------------------------------------- @@ -73,7 +72,7 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePointNameToID -ans = BaseInterpolation_ToInteger(name) +ans = InterpolationPoint_ToInteger(name) END PROCEDURE QuadraturePointNameToID !---------------------------------------------------------------------------- @@ -109,24 +108,18 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_QuadratureNumber1 -INTEGER(I4B) :: ncol - SELECT CASE (topo) CASE (elem%line) - ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) CASE (elem%triangle) - ans = QuadratureNumber_Triangle(order=order, quadtype=quadratureType) CASE (elem%quadrangle) - ans = QuadratureNumber_Line(order=order, quadtype=quadratureType) CASE (elem%tetrahedron) - ans = QuadratureNumber_Tetrahedron(order=order, quadtype=quadratureType) ! CASE (elem%hexahedron) @@ -135,11 +128,15 @@ ! ! CASE (elem%pyramid) +#ifdef DEBUG_VER CASE DEFAULT CALL Errormsg(msg="No case found for give topo", & - file=__FILE__, routine="obj_QuadratureNumber1()", line=__LINE__, & + file=__FILE__, & + routine="obj_QuadratureNumber1()", & + line=__LINE__, & unitno=stderr) STOP +#endif END SELECT @@ -151,8 +148,12 @@ MODULE PROCEDURE obj_Copy INTEGER(I4B) :: s(2) +LOGICAL(LGT) :: isok + obj%txi = obj2%txi -IF (ALLOCATED(obj2%points)) THEN +isok = ALLOCATED(obj2%points) + +IF (isok) THEN s = SHAPE(obj2%points) CALL Reallocate(obj%points, s(1), s(2)) obj%points(1:s(1), 1:s(2)) = obj2%points(1:s(1), 1:s(2)) @@ -212,9 +213,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Initiate5 -CALL obj_Initiate9(obj=obj, elemType=refelem%name, & - domainName=refelem%domainName, order=order, quadratureType=quadratureType, & - alpha=alpha, beta=beta, lambda=lambda, xij=refelem%xij) +CALL obj_Initiate9(obj=obj, & + elemType=refelem%name, & + domainName=refelem%domainName, & + order=order, & + quadratureType=quadratureType, & + alpha=alpha, & + beta=beta, & + lambda=lambda, & + xij=refelem%xij) END PROCEDURE obj_Initiate5 !---------------------------------------------------------------------------- @@ -222,9 +229,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Initiate6 -CALL obj_Initiate10(obj=obj, elemType=refelem%name, & - domainName=refelem%domainName, nips=nips, quadratureType=quadratureType, & - alpha=alpha, beta=beta, lambda=lambda, xij=refelem%xij) +CALL obj_Initiate10(obj=obj, & + elemType=refelem%name, & + domainName=refelem%domainName, & + nips=nips, & + quadratureType=quadratureType, & + alpha=alpha, & + beta=beta, & + lambda=lambda, & + xij=refelem%xij) END PROCEDURE obj_Initiate6 !---------------------------------------------------------------------------- @@ -232,12 +245,23 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE obj_Initiate8 -CALL obj_Initiate12(obj=obj, elemType=refelem%name, & - domainName=refelem%domainName, nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & - quadratureType1=quadratureType1, quadratureType2=quadratureType2, & - quadratureType3=quadratureType3, alpha1=alpha1, beta1=beta1, & - lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & - alpha3=alpha3, beta3=beta3, lambda3=lambda3, xij=refelem%xij) +CALL obj_Initiate12(obj=obj, & + elemType=refelem%name, & + domainName=refelem%domainName, & + nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & + quadratureType1=quadratureType1, & + quadratureType2=quadratureType2, & + quadratureType3=quadratureType3, & + alpha1=alpha1, & + beta1=beta1, & + lambda1=lambda1, & + alpha2=alpha2, & + beta2=beta2, & + lambda2=lambda2, & + alpha3=alpha3, & + beta3=beta3, & + lambda3=lambda3, & + xij=refelem%xij) END PROCEDURE obj_Initiate8 !---------------------------------------------------------------------------- @@ -246,10 +270,14 @@ MODULE PROCEDURE obj_Initiate9 CALL obj_Initiate11(obj=obj, elemType=elemtype, domainName=domainname, & - p=order, q=order, r=order, quadratureType1=quadratureType, & - quadratureType2=quadratureType, quadratureType3=quadratureType, & - alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & - lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, xij=xij) + p=order, q=order, r=order, & + quadratureType1=quadratureType, & + quadratureType2=quadratureType, & + quadratureType3=quadratureType, & + alpha1=alpha, beta1=beta, lambda1=lambda, & + alpha2=alpha, beta2=beta, lambda2=lambda, & + alpha3=alpha, beta3=beta, lambda3=lambda, & + xij=xij) END PROCEDURE obj_Initiate9 !---------------------------------------------------------------------------- @@ -258,10 +286,14 @@ MODULE PROCEDURE obj_Initiate10 CALL obj_Initiate12(obj=obj, elemType=elemtype, domainName=domainName, & - nipsx=nips, nipsy=nips, nipsz=nips, quadratureType1=quadratureType, & - quadratureType2=quadratureType, quadratureType3=quadratureType, & - alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, & - lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, xij=xij) + nipsx=nips, nipsy=nips, nipsz=nips, & + quadratureType1=quadratureType, & + quadratureType2=quadratureType, & + quadratureType3=quadratureType, & + alpha1=alpha, beta1=beta, lambda1=lambda, & + alpha2=alpha, beta2=beta, lambda2=lambda, & + alpha3=alpha, beta3=beta, lambda3=lambda, & + xij=xij) END PROCEDURE obj_Initiate10 !---------------------------------------------------------------------------- @@ -270,12 +302,14 @@ MODULE PROCEDURE obj_Initiate11 INTEGER(I4B) :: topo, nrow, ncol, ii, nipsx(1), nipsy(1), nipsz(1) +LOGICAL(LGT) :: isok topo = ElementTopology(elemType) ii = XiDimension(elemType) -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) +IF (isok) THEN nrow = MAX(SIZE(xij, 1), ii) ELSE nrow = ii @@ -288,39 +322,43 @@ CASE (elem%line) nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) - ncol = nipsx(1) - CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadratureType1, & - layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, & - lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol) + layout="INCREASING", xij=xij, alpha=alpha1, & + beta=beta1, lambda=lambda1, ans=obj%points, & + nrow=nrow, ncol=ncol) CASE (elem%triangle) nipsx(1) = QuadratureNumber_Triangle(order=p, quadtype=quadratureType1) ncol = nipsx(1) - CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, & - refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + refTriangle=domainName, xij=xij, & + ans=obj%points, nrow=nrow, ncol=ncol) CASE (elem%quadrangle) nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2) - ncol = nipsx(1) * nipsy(1) CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & - quadType1=quadratureType1, quadType2=quadratureType2, & - refQuadrangle=domainName, xij=xij, alpha1=alpha1, beta1=beta1, & - lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & - ans=obj%points, nrow=nrow, ncol=ncol) + quadType1=quadratureType1, & + quadType2=quadratureType2, & + refQuadrangle=domainName, & + xij=xij, & + alpha1=alpha1, & + beta1=beta1, & + lambda1=lambda1, & + alpha2=alpha2, & + beta2=beta2, & + lambda2=lambda2, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) CASE (elem%tetrahedron) @@ -330,7 +368,11 @@ CALL Reallocate(obj%points, nrow, ncol) CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & - refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + refTetrahedron=domainName, & + xij=xij, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) CASE (elem%hexahedron) @@ -347,25 +389,33 @@ quadType2=quadratureType2, & quadType3=quadratureType3, & refHexahedron=domainName, xij=xij, & - alpha1=alpha1, beta1=beta1, lambda1=lambda1, & - alpha2=alpha2, beta2=beta2, lambda2=lambda2, & - alpha3=alpha3, beta3=beta3, lambda3=lambda3, & - ans=obj%points, nrow=nrow, ncol=ncol) + alpha1=alpha1, & + beta1=beta1, & + lambda1=lambda1, & + alpha2=alpha2, & + beta2=beta2, & + lambda2=lambda2, & + alpha3=alpha3, & + beta3=beta3, & + lambda3=lambda3, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) ! CASE (Prism) - ! CASE (Pyramid) +#ifdef DEBUG_VER CASE DEFAULT CALL Errormsg(msg="No case found for give topo", & - file=__FILE__, routine="obj_Initiate11()", line=__LINE__, & - unitno=stderr) + file=__FILE__, routine="obj_Initiate11()", & + line=__LINE__, unitno=stderr) STOP +#endif END SELECT obj%txi = SIZE(obj%points, 1) - 1 - END PROCEDURE obj_Initiate11 !---------------------------------------------------------------------------- @@ -374,12 +424,14 @@ MODULE PROCEDURE obj_Initiate12 INTEGER(I4B) :: topo, nrow, ncol, ii +LOGICAL(LGT) :: isok topo = ElementTopology(elemType) ii = XiDimension(elemType) -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) +IF (isok) THEN nrow = MAX(SIZE(xij, 1), ii) ELSE nrow = ii @@ -390,74 +442,93 @@ SELECT CASE (topo) CASE (elem%line) + ncol = nipsx(1) CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadratureType1, & - layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, & - lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol) + layout="INCREASING", & + xij=xij, & + alpha=alpha1, & + beta=beta1, & + lambda=lambda1, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) CASE (elem%triangle) ncol = nipsx(1) - CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, & - refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + refTriangle=domainName, & + xij=xij, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) CASE (elem%quadrangle) ncol = nipsx(1) * nipsy(1) - CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & - quadType1=quadratureType1, quadType2=quadratureType2, & - refQuadrangle=domainName, xij=xij, alpha1=alpha1, beta1=beta1, & - lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, & + quadType1=quadratureType1, & + quadType2=quadratureType2, & + refQuadrangle=domainName, & + xij=xij, alpha1=alpha1, beta1=beta1, & + lambda1=lambda1, alpha2=alpha2, & + beta2=beta2, lambda2=lambda2, & ans=obj%points, nrow=nrow, ncol=ncol) CASE (elem%tetrahedron) ncol = nipsx(1) - CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, & - refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol) + refTetrahedron=domainName, & + xij=xij, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) CASE (elem%hexahedron) ncol = nipsx(1) * nipsy(1) * nipsz(1) - CALL Reallocate(obj%points, nrow, ncol) - CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, & quadType1=quadratureType1, & quadType2=quadratureType2, & quadType3=quadratureType3, & refHexahedron=domainName, & xij=xij, & - alpha1=alpha1, beta1=beta1, lambda1=lambda1, & - alpha2=alpha2, beta2=beta2, lambda2=lambda2, & - alpha3=alpha3, beta3=beta3, lambda3=lambda3, & - ans=obj%points, nrow=nrow, ncol=ncol) + alpha1=alpha1, & + beta1=beta1, & + lambda1=lambda1, & + alpha2=alpha2, & + beta2=beta2, & + lambda2=lambda2, & + alpha3=alpha3, & + beta3=beta3, & + lambda3=lambda3, & + ans=obj%points, & + nrow=nrow, & + ncol=ncol) ! CASE (Prism) -! ! CASE (Pyramid) +#ifdef DEBUG_VER CASE DEFAULT CALL Errormsg(msg="No case found for give topo", & - file=__FILE__, routine="obj_Initiate12()", line=__LINE__, & + file=__FILE__, & + routine="obj_Initiate12()", & + line=__LINE__, & unitno=stderr) STOP +#endif END SELECT obj%txi = SIZE(obj%points, 1) - 1 - END PROCEDURE obj_Initiate12 !---------------------------------------------------------------------------- diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 new file mode 100644 index 000000000..4f2cbc017 --- /dev/null +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90 @@ -0,0 +1,202 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(QuadraturePoint_Method) FacetQuadratureMethods +USE GlobalData, ONLY: stderr +USE ErrorHandling, ONLY: ErrorMsg +USE BaseInterpolation_Method, ONLY: InterpolationPoint_ToChar, & + InterpolationPoint_ToInteger, & + InterpolationPoint_ToString + +USE ReallocateUtility, ONLY: Reallocate + +USE ReferenceElement_Method, ONLY: ElementTopology, & + XiDimension, ReferenceElementInfo + +USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, & + QuadraturePoint_Line_ +USE TriangleInterpolationUtility, ONLY: QuadraturePoint_Triangle_, & + QuadratureNumber_Triangle, & + FacetConnectivity_Triangle + +USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_, & + QuadratureNumber_Quadrangle, & + FacetConnectivity_Quadrangle + +USE TetrahedronInterpolationUtility, ONLY: QuadraturePoint_Tetrahedron_, & + QuadratureNumber_Tetrahedron + +USE HexahedronInterpolationUtility, ONLY: QuadraturePoint_Hexahedron_, & + QuadratureNumber_Hexahedron + +USE BaseType, ONLY: elem => TypeElemNameOpt + +USE MappingUtility, ONLY: FromBiUnitLine2Segment_ + +IMPLICIT NONE + +CONTAINS + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_InitiateFacetQuadrature1 +CALL InitiateFacetQuadrature(obj=obj, facetQuad=facetQuad, & + localFaceNumber=localFaceNumber, & + elemType=elemtype, & + domainName=domainname, & + p=order, q=order, r=order, & + quadratureType1=quadratureType, & + quadratureType2=quadratureType, & + quadratureType3=quadratureType, & + alpha1=alpha, beta1=beta, lambda1=lambda, & + alpha2=alpha, beta2=beta, lambda2=lambda, & + alpha3=alpha, beta3=beta, lambda3=lambda, & + xij=xij) +END PROCEDURE obj_InitiateFacetQuadrature1 + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_InitiateFacetQuadrature2 +CALL InitiateFacetQuadrature(obj=obj, facetQuad=facetQuad, & + localFaceNumber=localFaceNumber, & + elemType=elemtype, domainName=domainName, & + nipsx=nips, nipsy=nips, nipsz=nips, & + quadratureType1=quadratureType, & + quadratureType2=quadratureType, & + quadratureType3=quadratureType, & + alpha1=alpha, beta1=beta, lambda1=lambda, & + alpha2=alpha, beta2=beta, lambda2=lambda, & + alpha3=alpha, beta3=beta, lambda3=lambda, & + xij=xij) +END PROCEDURE obj_InitiateFacetQuadrature2 + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_InitiateFacetQuadrature3 +INTEGER(I4B) :: topo, nrow, ncol, nipsx(1), nsd +INTEGER(I4B) :: facecon(ReferenceElementInfo%maxPoints, & + ReferenceElementInfo%maxEdges) +REAL(DFP) :: x1(3), x2(3) + +topo = ElementTopology(elemType) + +SELECT CASE (topo) + +CASE (elem%triangle) + + nsd = SIZE(xij, 1) + nrow = nsd + 1 + nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + CALL Reallocate(facetQuad%points, 2, ncol) + + ! Get quadrature points on [-1, 1] + CALL QuadraturePoint_Line_(nips=nipsx, & + quadType=quadratureType1, & + layout="INCREASING", & + alpha=alpha1, & + beta=beta1, & + lambda=lambda1, & + ans=facetQuad%points, & + nrow=nrow, ncol=ncol) + + facecon(1:2, 1:3) = FacetConnectivity_Triangle() + x1(1:nsd) = xij(1:nsd, facecon(1, localFaceNumber)) + x2(1:nsd) = xij(1:nsd, facecon(2, localFaceNumber)) + + ! Map quadrature points from[-1, 1] to the face of quadrangle + CALL FromBiUnitLine2Segment_(xin=facetQuad%points(1, :), & + x1=x1(1:nsd), & + x2=x2(1:nsd), & + ans=obj%points, & + nrow=nrow, ncol=ncol) + + obj%txi = SIZE(obj%points, 1) - 1 + facetQuad%txi = SIZE(facetQuad%points, 1) - 1 + + CALL GetQuadratureWeights_(obj=facetQuad, & + weights=obj%points(obj%txi + 1, :), & + tsize=ncol) + +CASE (elem%quadrangle) + + nsd = SIZE(xij, 1) + nrow = nsd + 1 + nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1) + ncol = nipsx(1) + + CALL Reallocate(obj%points, nrow, ncol) + CALL Reallocate(facetQuad%points, 2, ncol) + + ! Get quadrature points on [-1, 1] + CALL QuadraturePoint_Line_(nips=nipsx, & + quadType=quadratureType1, & + layout="INCREASING", & + alpha=alpha1, & + beta=beta1, & + lambda=lambda1, & + ans=facetQuad%points, & + nrow=nrow, ncol=ncol) + + facecon(1:2, 1:4) = FacetConnectivity_Quadrangle() + x1(1:nsd) = xij(1:nsd, facecon(1, localFaceNumber)) + x2(1:nsd) = xij(1:nsd, facecon(2, localFaceNumber)) + + ! Map quadrature points from[-1, 1] to the face of quadrangle + CALL FromBiUnitLine2Segment_(xin=facetQuad%points(1, :), & + x1=x1(1:nsd), & + x2=x2(1:nsd), & + ans=obj%points, & + nrow=nrow, ncol=ncol) + + obj%txi = SIZE(obj%points, 1) - 1 + facetQuad%txi = SIZE(facetQuad%points, 1) - 1 + + CALL GetQuadratureWeights_(obj=facetQuad, & + weights=obj%points(obj%txi + 1, :), & + tsize=ncol) + +#ifdef DEBUG_VER +CASE DEFAULT + CALL Errormsg(msg="No case found for give topo", & + file=__FILE__, routine="obj_Initiate11()", & + line=__LINE__, unitno=stderr) + STOP +#endif + +END SELECT + +END PROCEDURE obj_InitiateFacetQuadrature3 + +!---------------------------------------------------------------------------- +! InitiateFacetQuadrature +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_InitiateFacetQuadrature4 + +END PROCEDURE obj_InitiateFacetQuadrature4 + +END SUBMODULE FacetQuadratureMethods diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 index 61cc73fc2..67ae240d0 100755 --- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 @@ -21,6 +21,14 @@ SUBMODULE(QuadraturePoint_Method) GetMethods USE ReallocateUtility, ONLY: Reallocate +USE BaseType, ONLY: TypeElemNameOpt + +USE LineInterpolationUtility, ONLY: QuadratureNumber_Line +USE TriangleInterpolationUtility, ONLY: QuadratureNumber_Triangle +USE QuadrangleInterpolationUtility, ONLY: QuadratureNumber_Quadrangle +USE TetrahedronInterpolationUtility, ONLY: QuadratureNumber_Tetrahedron +USE HexahedronInterpolationUtility, ONLY: QuadratureNumber_Hexahedron +USE ReferenceElement_Method, ONLY: ElementTopology IMPLICIT NONE CONTAINS @@ -37,9 +45,48 @@ ! getTotalQuadraturepoints !---------------------------------------------------------------------------- -MODULE PROCEDURE obj_GetTotalQuadraturepoints +MODULE PROCEDURE obj_GetTotalQuadraturepoints1 ans = SIZE(obj, 2) -END PROCEDURE obj_GetTotalQuadraturepoints +END PROCEDURE obj_GetTotalQuadraturepoints1 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_GetTotalQuadraturePoints2 +INTEGER(I4B) :: topo, myint(3) + +topo = ElementTopology(elemType) + +SELECT CASE (topo) +CASE (TypeElemNameOpt%line) + ans = QuadratureNumber_Line(order=p, quadtype=quadratureType1) + +CASE (TypeElemNameOpt%triangle) + ans = QuadratureNumber_Triangle(order=p, quadtype=quadratureType1) + +CASE (TypeElemNameOpt%quadrangle) + myint(1:2) = QuadratureNumber_Quadrangle(p=p, q=q, & + quadType1=quadratureType1, & + quadType2=quadratureType2) + ans = myint(1) * myint(2) + +CASE (TypeElemNameOpt%tetrahedron) + ans = QuadratureNumber_Tetrahedron(order=p, quadtype=quadratureType1) + +CASE (TypeElemNameOpt%hexahedron) + myint(1:3) = QuadratureNumber_Hexahedron(p=p, q=q, r=r, & + quadType1=quadratureType1, & + quadType2=quadratureType2, & + quadType3=quadratureType3) + ans = PRODUCT(myint) + +! CASE (Prism) +! CASE (Pyramid) + +END SELECT + +END PROCEDURE obj_GetTotalQuadraturePoints2 !---------------------------------------------------------------------------- ! getQuadraturepoints diff --git a/src/submodules/STForceVector/src/STFV_8.inc b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 similarity index 53% rename from src/submodules/STForceVector/src/STFV_8.inc rename to src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 index dfe340b3f..d4f75dae1 100644 --- a/src/submodules/STForceVector/src/STFV_8.inc +++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90 @@ -1,5 +1,6 @@ ! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com ! ! This program is free software: you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by @@ -15,39 +16,26 @@ ! along with this program. If not, see ! +SUBMODULE(QuadraturePoint_Method) SetMethods +USE ReallocateUtility, ONLY: Reallocate +IMPLICIT NONE + +CONTAINS + !---------------------------------------------------------------------------- -! STForceVector +! Set !---------------------------------------------------------------------------- -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 +MODULE PROCEDURE obj_Set1 +INTEGER(I4B) :: nrow, ncol + +nrow = SIZE(points, 1) +ncol = SIZE(points, 2) + +CALL Reallocate(obj%points, nrow, ncol) + +obj%points(1:nrow, 1:ncol) = points +obj%tXi = nrow - 1 +END PROCEDURE obj_Set1 + +END SUBMODULE SetMethods diff --git a/src/submodules/STConvectiveMatrix/src/STCM_1.inc b/src/submodules/STConvectiveMatrix/src/STCM_1.inc index 83bace805..8badb54d3 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_1.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_1.inc @@ -45,7 +45,8 @@ PURE SUBROUTINE STCM_1a(ans, test, trial, term1, term2, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -95,7 +96,8 @@ PURE SUBROUTINE STCM_1b(ans, test, trial, term1, term2, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_10.inc b/src/submodules/STConvectiveMatrix/src/STCM_10.inc index 7f4492b77..a91c471ef 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_10.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_10.inc @@ -45,14 +45,15 @@ PURE SUBROUTINE STCM_10a(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -100,14 +101,15 @@ PURE SUBROUTINE STCM_10b(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc index 1b76e4d6d..6a92007b5 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc @@ -43,7 +43,7 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! if( opt .eq. 1 ) then !! @@ -59,7 +59,8 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -90,7 +91,8 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -144,7 +146,7 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! if( opt .eq. 1 ) then CALL Reallocate(m6, & @@ -159,7 +161,8 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -189,7 +192,8 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p,c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) diff --git a/src/submodules/STConvectiveMatrix/src/STCM_12.inc b/src/submodules/STConvectiveMatrix/src/STCM_12.inc index ffb27a1d8..d03ec6132 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_12.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_12.inc @@ -46,14 +46,15 @@ PURE SUBROUTINE STCM_12a(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -99,14 +100,15 @@ PURE SUBROUTINE STCM_12b(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc index dfe461067..c17547546 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_13.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_13.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE STCM_13a(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -104,7 +104,7 @@ PURE SUBROUTINE STCM_13b(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -168,7 +168,7 @@ PURE SUBROUTINE STCM_13c(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -232,7 +232,7 @@ PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -269,4 +269,3 @@ PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt) DEALLOCATE (m6, realval, vbar) !! END SUBROUTINE STCM_13d - diff --git a/src/submodules/STConvectiveMatrix/src/STCM_14.inc b/src/submodules/STConvectiveMatrix/src/STCM_14.inc index 8e7a0fae7..81d864d18 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_14.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_14.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE STCM_14a(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -104,7 +104,7 @@ PURE SUBROUTINE STCM_14b(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -168,7 +168,7 @@ PURE SUBROUTINE STCM_14c(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -232,7 +232,7 @@ PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt) !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -269,4 +269,3 @@ PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt) DEALLOCATE (m6, realval, vbar) !! END SUBROUTINE STCM_14d - diff --git a/src/submodules/STConvectiveMatrix/src/STCM_15.inc b/src/submodules/STConvectiveMatrix/src/STCM_15.inc index 07bc3e9c8..7ed27ea92 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_15.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_15.inc @@ -44,8 +44,8 @@ PURE SUBROUTINE STCM_15a(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -113,8 +113,8 @@ PURE SUBROUTINE STCM_15b(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -182,8 +182,8 @@ PURE SUBROUTINE STCM_15c(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -251,8 +251,8 @@ PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -289,4 +289,3 @@ PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, & DEALLOCATE (m6, realval, vbar, rhobar) !! END SUBROUTINE STCM_15d - diff --git a/src/submodules/STConvectiveMatrix/src/STCM_16.inc b/src/submodules/STConvectiveMatrix/src/STCM_16.inc index 42d6fde39..6b77ac369 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_16.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_16.inc @@ -44,8 +44,8 @@ PURE SUBROUTINE STCM_16a(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -113,8 +113,8 @@ PURE SUBROUTINE STCM_16b(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -182,8 +182,8 @@ PURE SUBROUTINE STCM_16c(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -251,8 +251,8 @@ PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -289,4 +289,3 @@ PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, & DEALLOCATE (m6, realval, vbar, rhobar) !! END SUBROUTINE STCM_16d - diff --git a/src/submodules/STConvectiveMatrix/src/STCM_17.inc b/src/submodules/STConvectiveMatrix/src/STCM_17.inc index 091bf4901..de96d90a6 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc @@ -46,9 +46,9 @@ PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -62,7 +62,8 @@ PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, & realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -120,9 +121,9 @@ PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -136,7 +137,8 @@ PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, & realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -194,9 +196,9 @@ PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) !! - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -210,7 +212,8 @@ PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, & realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -268,8 +271,8 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, & !! !! main !! - CALL GetInterpolation(obj=trial, interpol=vbar, val=c) - CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=vbar, val=c) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -283,7 +286,8 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, & realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFeVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -308,4 +312,3 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, & DEALLOCATE (m6, realval, vbar, rhobar, p) !! END SUBROUTINE STCM_17d - diff --git a/src/submodules/STConvectiveMatrix/src/STCM_2.inc b/src/submodules/STConvectiveMatrix/src/STCM_2.inc index cb5ec15db..7f7db05cb 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_2.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_2.inc @@ -41,7 +41,7 @@ PURE SUBROUTINE STCM_2a(ans, test, trial, term1, term2, c, opt) !! !! make c bar at ips and ipt IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP @@ -101,7 +101,7 @@ PURE SUBROUTINE STCM_2b(ans, test, trial, term1, term2, c, opt) !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP diff --git a/src/submodules/STConvectiveMatrix/src/STCM_3.inc b/src/submodules/STConvectiveMatrix/src/STCM_3.inc index dbaf727b9..a8a274d3b 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_3.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_3.inc @@ -43,7 +43,7 @@ PURE SUBROUTINE STCM_3a(ans, test, trial, term1, & !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP @@ -152,7 +152,7 @@ PURE SUBROUTINE STCM_3b(ans, test, trial, term1, & !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP diff --git a/src/submodules/STConvectiveMatrix/src/STCM_4.inc b/src/submodules/STConvectiveMatrix/src/STCM_4.inc index 24aeacc50..58913d9ea 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_4.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_4.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE STCM_4a(ans, test, trial, term1, term2, c, opt) !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP @@ -96,7 +96,7 @@ PURE SUBROUTINE STCM_4b(ans, test, trial, term1, term2, c, opt) !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP diff --git a/src/submodules/STConvectiveMatrix/src/STCM_5.inc b/src/submodules/STConvectiveMatrix/src/STCM_5.inc index 0e0019c5c..d87a94409 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_5.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_5.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt) !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP @@ -146,7 +146,7 @@ PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt) !! make c bar at ips and ipt !! IF (PRESENT(c)) THEN - CALL GetInterpolation(obj=trial, val=c, interpol=cbar) + CALL GetInterpolation(obj=trial, val=c, ans=cbar) ELSE CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial)) cbar = 1.0_DFP diff --git a/src/submodules/STConvectiveMatrix/src/STCM_6.inc b/src/submodules/STConvectiveMatrix/src/STCM_6.inc index 700f7db54..9b93f3405 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_6.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_6.inc @@ -48,7 +48,8 @@ PURE SUBROUTINE STCM_6a(ans, test, trial, term1, term2, c, projecton, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -100,7 +101,8 @@ PURE SUBROUTINE STCM_6b(ans, test, trial, term1, term2, c, projecton, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & diff --git a/src/submodules/STConvectiveMatrix/src/STCM_7.inc b/src/submodules/STConvectiveMatrix/src/STCM_7.inc index 949ebea9b..5e13cc4ea 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_7.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_7.inc @@ -54,7 +54,8 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p,c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -84,7 +85,8 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -146,7 +148,8 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) @@ -176,7 +179,8 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) DO b = 1, SIZE(m6, 6) diff --git a/src/submodules/STConvectiveMatrix/src/STCM_8.inc b/src/submodules/STConvectiveMatrix/src/STCM_8.inc index 5aac726a1..28f777f99 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_8.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_8.inc @@ -47,7 +47,8 @@ PURE SUBROUTINE STCM_8a(ans, test, trial, c, term1, term2, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -95,7 +96,8 @@ PURE SUBROUTINE STCM_8b(ans, test, trial, c, term1, term2, opt) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -109,4 +111,4 @@ PURE SUBROUTINE STCM_8b(ans, test, trial, c, term1, term2, opt) !! DEALLOCATE (IaJb, p, realval) !! -END SUBROUTINE STCM_8b \ No newline at end of file +END SUBROUTINE STCM_8b diff --git a/src/submodules/STConvectiveMatrix/src/STCM_9.inc b/src/submodules/STConvectiveMatrix/src/STCM_9.inc index 301ffc2e9..09162f556 100644 --- a/src/submodules/STConvectiveMatrix/src/STCM_9.inc +++ b/src/submodules/STConvectiveMatrix/src/STCM_9.inc @@ -42,14 +42,15 @@ PURE SUBROUTINE STCM_9a(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) IaJb = IaJb + realval(ips) & @@ -94,14 +95,14 @@ PURE SUBROUTINE STCM_9b(ans, test, trial, term1, term2, rho, c, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar) + CALL GetInterpolation(obj=trial, val=rho, ans=rhobar) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & & trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt) !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) !! diff --git a/src/submodules/STDiffusionMatrix/src/STDM_1.inc b/src/submodules/STDiffusionMatrix/src/STDM_1.inc index 62ab2a90f..a8c2985e5 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_1.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_1.inc @@ -33,7 +33,7 @@ PURE SUBROUTINE STDM_1(ans, test, trial, k, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) diff --git a/src/submodules/STDiffusionMatrix/src/STDM_11.inc b/src/submodules/STDiffusionMatrix/src/STDM_11.inc index 45d6b94cf..b6cbf4061 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_11.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_11.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%refelem%nsd !! @@ -111,7 +111,7 @@ PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%refelem%nsd !! diff --git a/src/submodules/STDiffusionMatrix/src/STDM_12.inc b/src/submodules/STDiffusionMatrix/src/STDM_12.inc index 8c8e1ee34..210819e12 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_12.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_12.inc @@ -39,7 +39,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) + CALL getInterpolation(obj=trial, ans=vbar, val=k) !! CALL Reallocate( & & IJab, & @@ -121,7 +121,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) + CALL getInterpolation(obj=trial, ans=vbar, val=k) !! CALL Reallocate( & & IJab, & @@ -178,4 +178,3 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) DEALLOCATE (realval, IJab, vbar, m6) !! END SUBROUTINE STDM_12b - diff --git a/src/submodules/STDiffusionMatrix/src/STDM_13.inc b/src/submodules/STDiffusionMatrix/src/STDM_13.inc index 07e8c1420..1ef4439f7 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_13.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_13.inc @@ -48,8 +48,8 @@ PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=c2bar, val=c2) !! nsd = trial(1)%refelem%nsd !! @@ -118,8 +118,8 @@ PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=c2bar, val=c2) !! nsd = trial(1)%refelem%nsd !! diff --git a/src/submodules/STDiffusionMatrix/src/STDM_14.inc b/src/submodules/STDiffusionMatrix/src/STDM_14.inc index b4415905a..67f78aa00 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_14.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_14.inc @@ -42,8 +42,8 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=cbar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate( & & IJab, & @@ -128,8 +128,8 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=cbar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate( & & IJab, & diff --git a/src/submodules/STDiffusionMatrix/src/STDM_3.inc b/src/submodules/STDiffusionMatrix/src/STDM_3.inc index e753853ac..984393b36 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_3.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_3.inc @@ -35,7 +35,7 @@ PURE SUBROUTINE STDM_3(ans, test, trial, k, opt) CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%refelem%nsd !! diff --git a/src/submodules/STDiffusionMatrix/src/STDM_5.inc b/src/submodules/STDiffusionMatrix/src/STDM_5.inc index 392dec893..ab311cb44 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_5.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_5.inc @@ -47,8 +47,8 @@ PURE SUBROUTINE STDM_5(ans, test, trial, c1, c2, opt) CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=rhobar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + CALL getInterpolation(obj=trial, ans=rhobar, val=c1) + CALL getInterpolation(obj=trial, ans=kbar, val=c2) !! nsd = trial(1)%refelem%nsd !! diff --git a/src/submodules/STDiffusionMatrix/src/STDM_6.inc b/src/submodules/STDiffusionMatrix/src/STDM_6.inc index abb4efdb8..85b591ac1 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_6.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_6.inc @@ -39,8 +39,8 @@ PURE SUBROUTINE STDM_6(ans, test, trial, c1, c2, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=c2bar, val=c2) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) diff --git a/src/submodules/STDiffusionMatrix/src/STDM_7.inc b/src/submodules/STDiffusionMatrix/src/STDM_7.inc index 60a248dc0..c2c73c83d 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_7.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_7.inc @@ -41,7 +41,7 @@ PURE SUBROUTINE STDM_7(ans, test, trial, c1, c2, opt) !! main CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) !! DO ipt = 1, SIZE(trial) !! diff --git a/src/submodules/STDiffusionMatrix/src/STDM_8.inc b/src/submodules/STDiffusionMatrix/src/STDM_8.inc index 3e4c46518..efcd377ec 100644 --- a/src/submodules/STDiffusionMatrix/src/STDM_8.inc +++ b/src/submodules/STDiffusionMatrix/src/STDM_8.inc @@ -40,8 +40,8 @@ PURE SUBROUTINE STDM_8(ans, test, trial, c1, c2, opt) !! main CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) + CALL getInterpolation(obj=trial, ans=k1bar, val=c1) + CALL getInterpolation(obj=trial, ans=k2bar, val=c2) nsd = trial(1)%refelem%nsd !! DO ipt = 1, SIZE(trial) diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 index de726de3e..221c93fa0 100644 --- a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 +++ b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 @@ -51,7 +51,7 @@ PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) + CALL GetInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%nsd !! @@ -117,7 +117,7 @@ PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=kbar, val=k) + CALL getInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%nsd !! @@ -177,7 +177,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) + CALL getInterpolation(obj=trial, ans=vbar, val=k) !! CALL Reallocate( & & IJab, & @@ -259,7 +259,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=k) + CALL getInterpolation(obj=trial, ans=vbar, val=k) !! CALL Reallocate( & & IJab, & @@ -351,8 +351,8 @@ PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) + CALL GetInterpolation(obj=trial, ans=c2bar, val=c2) !! nsd = trial(1)%nsd !! @@ -421,8 +421,8 @@ PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt) & SIZE(test(1)%T), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) + CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) + CALL GetInterpolation(obj=trial, ans=c2bar, val=c2) !! nsd = trial(1)%nsd !! @@ -485,8 +485,8 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL GetInterpolation(obj=trial, ans=cbar, val=c1) + CALL GetInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate( & & IJab, & @@ -571,8 +571,8 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt) !! !! main !! - CALL getInterpolation(obj=trial, interpol=cbar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL GetInterpolation(obj=trial, ans=cbar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate( & & IJab, & @@ -706,7 +706,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! !! main !! -CALL getInterpolation(obj=trial, interpol=kbar, val=k) +CALL GetInterpolation(obj=trial, ans=kbar, val=k) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) @@ -759,9 +759,11 @@ END SUBROUTINE MakeDiagonalCopiesIJab realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & & * trial(ipt)%wt * trial(ipt)%jt !! - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p1, c=k, & + crank=TypeFEVariableVector) !! - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p2, c=k, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) !! @@ -791,7 +793,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! -CALL getInterpolation(obj=trial, interpol=kbar, val=k) +CALL getInterpolation(obj=trial, ans=kbar, val=k) !! nsd = trial(1)%nsd !! @@ -843,8 +845,8 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=c2bar, val=c2) +CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) +CALL GetInterpolation(obj=trial, ans=c2bar, val=c2) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) @@ -897,14 +899,16 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! main CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) +CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) !! DO ipt = 1, SIZE(trial) !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p1, c=c2, & + crank=TypeFEVariableVector) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p2, c=c2, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) !! @@ -943,8 +947,8 @@ END SUBROUTINE MakeDiagonalCopiesIJab CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) !! -CALL getInterpolation(obj=trial, interpol=rhobar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +CALL GetInterpolation(obj=trial, ans=rhobar, val=c1) +CALL GetInterpolation(obj=trial, ans=kbar, val=c2) !! nsd = trial(1)%nsd !! @@ -1016,8 +1020,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness & & * trial(ipt)%wt * trial(ipt)%jt - CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1) - CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2) + CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p1, c=c1, & + crank=TypeFEVariableVector) + CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p2, c=c2, & + crank=TypeFEVariableVector) !! DO ips = 1, SIZE(realval) !! @@ -1096,8 +1102,8 @@ END SUBROUTINE MakeDiagonalCopiesIJab !! main CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) -CALL getInterpolation(obj=trial, interpol=k1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=k2bar, val=c2) +CALL getInterpolation(obj=trial, ans=k1bar, val=c1) +CALL getInterpolation(obj=trial, ans=k2bar, val=c2) nsd = trial(1)%nsd !! DO ipt = 1, SIZE(trial) diff --git a/src/submodules/STForceVector/src/STFV_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_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_9.inc b/src/submodules/STForceVector/src/STFV_9.inc deleted file mode 100644 index 2ec1de665..000000000 --- a/src/submodules/STForceVector/src/STFV_9.inc +++ /dev/null @@ -1,58 +0,0 @@ -! This program is a part of EASIFEM library -! Copyright (C) 2020-2021 Vikas Sharma, Ph.D -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see -! - -!---------------------------------------------------------------------------- -! STForceVector -!---------------------------------------------------------------------------- - -PURE SUBROUTINE STFV_9(ans, test, term1, c, crank) - !! intent of dummy variable - REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :) - CLASS(STElemshapeData_), INTENT(IN) :: test(:) - INTEGER(I4B), INTENT(IN) :: term1 - !! DEL_t - TYPE(FEVariable_), INTENT(IN) :: c - TYPE(FEVariableScalar_), INTENT(IN) :: crank - !! - !! Define internal variable - !! - REAL(DFP), ALLOCATABLE :: realval(:) - REAL(DFP), ALLOCATABLE :: cbar(:, :) - INTEGER(I4B) :: ips, ipt - !! - !! main - !! - CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! - CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! - DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips) - END DO - !! - END DO - !! - DEALLOCATE (realval, cbar) - !! -END SUBROUTINE STFV_9 diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 index aced7d296..8202dc6bb 100644 --- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 +++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 @@ -16,850 +16,2074 @@ ! SUBMODULE(STForceVector_Method) Methods -USE BaseMethod +USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_ +USE FEVariable_Method, ONLY: FEVariableSize => Size +USE ReallocateUtility, ONLY: Reallocate +USE ProductUtility, ONLY: OuterProd_ +USE BaseType, ONLY: TypeDerivativeTerm +USE BaseType, ONLY: TypeFEVariableSpace, TypeFEVariableVector +USE BaseType, ONLY: TypeFEVariableMatrix +USE BaseType, ONLY: math => TypeMathOpt +USE ElemshapeData_Method, ONLY: GetProjectionOfdNTdXt_ +USE Display_Method, ONLY: display + IMPLICIT NONE CONTAINS -#include "./STFV_1.inc" -#include "./STFV_2.inc" -#include "./STFV_3.inc" -#include "./STFV_4.inc" -#include "./STFV_5.inc" -#include "./STFV_6.inc" -#include "./STFV_7.inc" - -#include "./STFV_8.inc" -#include "./STFV_9.inc" -#include "./STFV_10.inc" -#include "./STFV_11.inc" -#include "./STFV_12.inc" -#include "./STFV_13.inc" -#include "./STFV_14.inc" - -#include "./STFV_15.inc" -#include "./STFV_16.inc" -#include "./STFV_17.inc" -#include "./STFV_18.inc" -#include "./STFV_19.inc" -#include "./STFV_20.inc" -#include "./STFV_21.inc" - !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_1 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * & - & test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval) - !! -END PROCEDURE STForceVector_1 +MODULE PROCEDURE obj_STForceVector1 +INTEGER(I4B) :: nrow, ncol + +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(ans=ans, test=test, nrow=nrow, ncol=ncol) +END PROCEDURE obj_STForceVector1 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_2 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * cbar(:, ipt) * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! +MODULE PROCEDURE obj_STForceVector_1 +REAL(DFP) :: realval +INTEGER(I4B) :: ips, ipt, nipt, i1, i2 + +nipt = SIZE(test) + +nrow = test(1)%nns +ncol = test(1)%nnt + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL OuterProd_( & + a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=math%one, & + scale=realval, ans=ans, nrow=i1, ncol=i2) + END DO END DO - !! -DEALLOCATE (realval, cbar) - !! -END PROCEDURE STForceVector_2 +END PROCEDURE obj_STForceVector_1 !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_3 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & cbar(:, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! +MODULE PROCEDURE obj_STForceVector_22 +REAL(DFP) :: realval +INTEGER(I4B) :: ips, ipt, nipt, nips, i1, i2 + +nrow = testSpace%nns +ncol = testTime%nns + +nips = testSpace%nips +nipt = testTime%nips + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, nips + realval = testSpace%js(ips) * testSpace%ws(ips) * & + testSpace%thickness(ips) * testTime%ws(ipt) * testTime%js(ipt) + + CALL OuterProd_( & + a=testSpace%N(1:nrow, ips), b=testTime%N(1:ncol, ipt), & + anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2) + END DO END DO - !! -DEALLOCATE (realval, cbar) - !! -END PROCEDURE STForceVector_3 +END PROCEDURE obj_STForceVector_22 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_4 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=cbar, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(cbar, 1), & - & SIZE(cbar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & cbar(:, :, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! +MODULE PROCEDURE obj_STForceVector2 +INTEGER(I4B) :: nrow, ncol + +nrow = test(1)%nns +ncol = test(1)%nnt + +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(ans=ans, test=test, nrow=nrow, ncol=ncol, c=c, & + crank=crank) +END PROCEDURE obj_STForceVector2 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_2 +REAL(DFP) :: realval, cbar +INTEGER(I4B) :: nipt, ipt, ips, i1, i2 + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar) + + realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=math%one, & + scale=realval, ans=ans, nrow=i1, ncol=i2) + + END DO END DO - !! -DEALLOCATE (realval, cbar) - !! -END PROCEDURE STForceVector_4 +END PROCEDURE obj_STForceVector_2 !---------------------------------------------------------------------------- -! STForceVector +! STForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_5 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & a=test(ipt)%N(:, ips), & - & b=test(ipt)%T) - END DO - !! +MODULE PROCEDURE obj_STForceVector_23 +REAL(DFP) :: realval, cbar +INTEGER(I4B) :: ips, ipt, nipt, nips, i1, i2 + +nrow = testSpace%nns +ncol = testTime%nns + +nips = testSpace%nips +nipt = testTime%nips + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=testSpace%N, nns=testSpace%nns, spaceIndx=ips, & + timeIndx=ipt, T=testTime%N(:, ipt), nnt=testTime%nns, scale=math%one, & + addContribution=math%no, ans=cbar) + + realval = cbar * testSpace%js(ips) * testSpace%ws(ips) * & + testSpace%thickness(ips) * testTime%ws(ipt) * testTime%js(ipt) + + CALL OuterProd_( & + a=testSpace%N(1:nrow, ips), b=testTime%N(1:ncol, ipt), & + anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2) + END DO END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_5 +END PROCEDURE obj_STForceVector_23 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_6 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%Jt - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! -END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_6 +MODULE PROCEDURE obj_STForceVector3 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = FEVariableSize(obj=c, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt +CALL Reallocate(ans, dim1, dim2, dim3) +CALL STForceVector_(test=test, c=c, crank=crank, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3) +END PROCEDURE obj_STForceVector3 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_7 - !! Define internal variable -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c1bar(:, :) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL getInterpolation(obj=test, interpol=c1bar, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c1bar(:, ipt) * test(ipt)%jt - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD( & - & c2bar(:, :, ips, ipt), & - & test(ipt)%N(:, ips), & - & test(ipt)%T) - END DO - !! +MODULE PROCEDURE obj_STForceVector_3 +INTEGER(I4B) :: ips, ipt, nipt, spaceCompo, i1, i2, i3 +REAL(DFP) :: cbar(3), realval + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3) = math%zero + +DO ipt = 1, nipt + + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, spaceIndx=ips, & + timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, scale=math%one, & + addContribution=math%no, ans=cbar, tsize=spaceCompo) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_(a=cbar(1:dim1), b=test(ipt)%N(1:dim2, ips), & + c=test(ipt)%T(1:dim3), anscoeff=math%one, scale=realval, & + ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO END DO - !! -DEALLOCATE (realval, c1bar, c2bar) - !! -END PROCEDURE STForceVector_7 +END PROCEDURE obj_STForceVector_3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_8 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_1(ans=ans, test=test, term1=term1) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_8(ans=ans, test=test, term1=term1) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_15(ans=ans, test=test, term1=term1) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_8 +MODULE PROCEDURE obj_STForceVector_24 +INTEGER(I4B) :: ips, ipt, nipt, nips, spaceCompo, i1, i2, i3 +REAL(DFP) :: cbar(3), realval + +dim1 = FEVariableSize(obj=c, dim=1) + +dim2 = testSpace%nns +nips = testSpace%nips + +dim3 = testTime%nns +nipt = testTime%nips + +ans(1:dim1, 1:dim2, 1:dim3) = math%zero + +DO ipt = 1, nipt + + DO ips = 1, nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=testSpace%N, nns=testSpace%nns, spaceIndx=ips, & + timeIndx=ipt, T=testTime%N(:, ipt), nnt=testTime%nns, scale=math%one, & + addContribution=math%no, ans=cbar, tsize=spaceCompo) + + realval = testSpace%js(ips) * testSpace%ws(ips) * & + testSpace%thickness(ips) * testTime%js(ipt) * testTime%ws(ipt) + + CALL OuterProd_(a=cbar(1:dim1), b=testSpace%N(1:dim2, ips), & + c=testtime%N(1:dim3, ipt), & + anscoeff=math%one, scale=realval, & + ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO +END DO + +END PROCEDURE obj_STForceVector_24 !---------------------------------------------------------------------------- -! +! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_9 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_2(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_9(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_16(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_9 +MODULE PROCEDURE obj_STForceVector4 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 + +dim1 = FEVariableSize(obj=c, dim=1) +dim2 = FEVariableSize(obj=c, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +CALL Reallocate(ans, dim1, dim2, dim3, dim4) + +CALL STForceVector_(test=test, c=c, crank=crank, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3, dim4=dim4) +END PROCEDURE obj_STForceVector4 !---------------------------------------------------------------------------- -! +! STForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_10 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_3(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_10(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_17(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_10 +MODULE PROCEDURE obj_STForceVector_4 +INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 +REAL(DFP) :: cbar(3, 3), realval + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c, dim=1) +dim2 = FEVariableSize(obj=c, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + +DO ipt = 1, nipt + + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, spaceIndx=ips, & + timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, scale=math%one, & + addContribution=math%no, ans=cbar, nrow=i1, ncol=i2) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_(a=cbar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), & + c=test(ipt)%T(1:dim4), anscoeff=math%one, scale=realval, & + ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4) + + END DO +END DO +END PROCEDURE obj_STForceVector_4 !---------------------------------------------------------------------------- -! +! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_11 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_4(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_11(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_18(ans=ans, test=test, term1=term1, c=c, crank=crank) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_11 +MODULE PROCEDURE obj_STForceVector5 +INTEGER(I4B) :: nrow, ncol + +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(test=test, ans=ans, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, nrow=nrow, ncol=ncol) +END PROCEDURE obj_STForceVector5 !---------------------------------------------------------------------------- -! +! STForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_12 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_5(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_12(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_19(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_12 +MODULE PROCEDURE obj_STForceVector_5 +REAL(DFP) :: realval, c1bar, c2bar +INTEGER(I4B) :: nipt, ipt, ips, i1, i2 + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=math%one, & + scale=realval, ans=ans, nrow=i1, ncol=i2) + + END DO +END DO +END PROCEDURE obj_STForceVector_5 !---------------------------------------------------------------------------- -! +! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_13 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_6(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_13(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_20(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_13 +MODULE PROCEDURE obj_STForceVector6 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt +CALL Reallocate(ans, dim1, dim2, dim3) +CALL STForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE obj_STForceVector6 !---------------------------------------------------------------------------- -! +! STForceVector_ !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_14 - !! -SELECT CASE (term1) - !! - !! - !! -CASE (DEL_NONE) - !! - CALL STFV_7(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_t) - !! - CALL STFV_14(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_X, DEL_Y, DEL_Z) - !! - CALL STFV_21(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, & - & c2=c2, c2rank=c2rank) - !! - !! - !! -CASE (DEL_X_ALL) - !! - !! TODO - !! -END SELECT - !! -END PROCEDURE STForceVector_14 +MODULE PROCEDURE obj_STForceVector_6 +REAL(DFP) :: realval, c1bar, c2bar(3) +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3 + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1), b=test(ipt)%N(1:dim2, ips), & + c=test(ipt)%T(1:dim3), anscoeff=math%one, & + scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO +END DO +END PROCEDURE obj_STForceVector_6 !---------------------------------------------------------------------------- -! STForceVector +! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_15 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO - !! +MODULE PROCEDURE obj_STForceVector7 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 + +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = FEVariableSize(obj=c2, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL STForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4) +END PROCEDURE obj_STForceVector7 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_7 +INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 +REAL(DFP) :: realval, c1bar, c2bar(3, 3) + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = FEVariableSize(obj=c2, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + +DO ipt = 1, nipt + + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), & + c=test(ipt)%T(1:dim4), anscoeff=math%one, & + scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4) + + END DO END DO - !! -DEALLOCATE (realval, p1) - !! -END PROCEDURE STForceVector_15 +END PROCEDURE obj_STForceVector_7 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_16 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO - !! -END DO - !! -DEALLOCATE (realval, p1, c2bar) - !! +MODULE PROCEDURE obj_STForceVector15 +REAL(DFP), ALLOCATABLE :: temp(:, :) +INTEGER(I4B) :: nrow, ncol + +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(temp, nrow, ncol) +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(test=test, projection=projection, c=c, crank=crank, & + ans=ans, nrow=nrow, ncol=ncol, temp=temp) + +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector15 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_15 +REAL(DFP) :: realval +INTEGER(I4B) :: ips, ipt, nipt, i1, i2 + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt -END PROCEDURE STForceVector_16 + CALL GetProjectionOfdNTdXt_( & + obj=test, ans=temp, c=c, crank=crank, nrow=i1, ncol=i2, ips=ips, & + ipt=ipt) + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + realval * temp(1:i1, 1:i2) + END DO + +END DO +END PROCEDURE obj_STForceVector_15 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_17 - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD( & - & c2bar(:, ips, ipt), & - & p1(:, :, ips, ipt)) - END DO - !! +MODULE PROCEDURE obj_STForceVector16 +INTEGER(I4B) :: nrow, ncol +REAL(DFP), ALLOCATABLE :: temp(:, :) + +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(temp, nrow, ncol) +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_( & + test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, nrow=nrow, ncol=ncol, temp=temp) +END PROCEDURE obj_STForceVector16 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_16 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2 +REAL(DFP) :: realval + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=realval) + + realval = realval * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, & + ans=temp, nrow=i1, ncol=i2) + + ans(1:i1, 1:i2) = ans(1:i1, 1:i2) + realval * temp(1:i1, 1:i2) + END DO END DO - !! -DEALLOCATE (realval, p1, c2bar) - !! -END PROCEDURE STForceVector_17 +END PROCEDURE obj_STForceVector_16 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_18 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) - !! -CALL reallocate( & - & ans, & - & SIZE(c2bar, 1), & - & SIZE(c2bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) & - & * OUTERPROD(c2bar(:, :, ips, ipt), p1(:, :, ips, ipt)) - END DO - !! +MODULE PROCEDURE obj_STForceVector17 +INTEGER(I4B) :: dim1, dim2, dim3 +REAL(DFP), ALLOCATABLE :: temp(:, :) + +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt +CALL Reallocate(temp, dim2, dim3) +CALL Reallocate(ans, dim1, dim2, dim3) +CALL STForceVector_( & + test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, temp=temp) +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector17 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_17 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3 +REAL(DFP) :: realval, c2bar(3) + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1) + + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, & + ncol=i2) + + CALL OuterProd_( & + a=c2bar(1:dim1), b=temp(1:dim2, 1:dim3), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) + + END DO END DO - !! -DEALLOCATE (realval, p1, c2bar) - !! -END PROCEDURE STForceVector_18 +END PROCEDURE obj_STForceVector_17 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_19 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) -CALL getInterpolation(obj=test, interpol=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js & - & * test(ipt)%ws & - & * test(ipt)%thickness & - & * c2bar(:, ipt) & - & * c3bar(:, ipt) - !! - !! - DO ips = 1, SIZE(realval) - ans = ans + realval(ips) * p1(:, :, ips, ipt) - END DO - !! +MODULE PROCEDURE obj_STForceVector18 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +REAL(DFP), ALLOCATABLE :: temp(:, :) + +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = FEVariableSize(obj=c2, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +CALL Reallocate(temp, dim3, dim4) +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL STForceVector_( & + test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4, & + temp=temp) + +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector18 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_18 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3, i4 +REAL(DFP) :: realval, c2bar(3, 3) + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = FEVariableSize(obj=c2, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2) + + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, & + ncol=i2) + + CALL OuterProd_( & + a=c2bar(1:dim1, 1:dim2), b=temp(1:dim3, 1:dim4), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, & + anscoeff=math%one, scale=realval) + + END DO END DO - !! -DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_19 +END PROCEDURE obj_STForceVector_18 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_20 - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) -CALL getInterpolation(obj=test, interpol=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(c3bar, 1), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness & - & * c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - ans = ans & - & + realval(ips) & - & * OUTERPROD(c3bar(:, ips, ipt), p1(:, :, ips, ipt)) - END DO - !! +MODULE PROCEDURE obj_STForceVector19 +INTEGER(I4B) :: nrow, ncol +REAL(DFP), ALLOCATABLE :: temp(:, :) + +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(temp, nrow, ncol) +CALL Reallocate(ans, nrow, ncol) + +CALL STForceVector_( & + test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, c3=c3, c3rank=c3rank, ans=ans, nrow=nrow, ncol=ncol, & + temp=temp) + +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector19 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_19 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2 +REAL(DFP) :: realval, c2bar, c3bar + +nipt = SIZE(test) +nrow = test(1)%nns +ncol = test(1)%nnt + +ans(1:nrow, 1:ncol) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + CALL FEVariableGetInterpolation_( & + obj=c3, rank=c3rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c3bar) + + realval = c2bar * c3bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, & + ans=temp, nrow=i1, ncol=i2) + + ans(1:i1, 1:i2) = ans(1:i1, 1:i2) + realval * temp(1:i1, 1:i2) + END DO END DO - !! -DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_20 +END PROCEDURE obj_STForceVector_19 !---------------------------------------------------------------------------- ! STForceVector !---------------------------------------------------------------------------- -MODULE PROCEDURE STForceVector_21 - !! - !! Define internal variable - !! -REAL(DFP), ALLOCATABLE :: realval(:) -REAL(DFP), ALLOCATABLE :: c2bar(:, :) -REAL(DFP), ALLOCATABLE :: c3bar(:, :, :, :) -REAL(DFP), ALLOCATABLE :: p1(:, :, :, :) -INTEGER(I4B) :: ips, ipt - !! - !! main - !! -CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1) -CALL getInterpolation(obj=test, interpol=c2bar, val=c2) -CALL getInterpolation(obj=test, interpol=c3bar, val=c3) - !! -CALL reallocate( & - & ans, & - & SIZE(c3bar, 1), & - & SIZE(c3bar, 2), & - & SIZE(test(1)%N, 1), & - & SIZE(test(1)%T)) - !! -DO ipt = 1, SIZE(test) - !! - realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * & - & c2bar(:, ipt) - !! - DO ips = 1, SIZE(realval) - !! - ans = ans + realval(ips) * OUTERPROD( & - & c3bar(:, :, ips, ipt), & - & p1(:, :, ips, ipt)) - !! +MODULE PROCEDURE obj_STForceVector20 +INTEGER(I4B) :: dim1, dim2, dim3 +REAL(DFP), ALLOCATABLE :: temp(:, :) + +dim1 = FEVariableSize(obj=c3, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt + +CALL Reallocate(temp, dim2, dim3) +CALL Reallocate(ans, dim1, dim2, dim3) + +CALL STForceVector_( & + test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, c3=c3, c3rank=c3rank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, temp=temp) + +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector20 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_20 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3 +REAL(DFP) :: realval, c2bar, c3bar(3) + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c3, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + CALL FEVariableGetInterpolation_( & + obj=c3, rank=c3rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c3bar, tsize=i1) + + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, & + ncol=i2) + + realval = c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL OuterProd_( & + a=c3bar(1:dim1), b=temp(1:dim2, 1:dim3), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) + END DO END DO - !! -DEALLOCATE (realval, p1, c2bar, c3bar) - !! -END PROCEDURE STForceVector_21 +END PROCEDURE obj_STForceVector_20 !---------------------------------------------------------------------------- -! +! STForceVector +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector21 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +REAL(DFP), ALLOCATABLE :: temp(:, :) + +dim1 = FEVariableSize(obj=c3, dim=1) +dim2 = FEVariableSize(obj=c3, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +CALL Reallocate(temp, dim3, dim4) +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL STForceVector_( & + test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, c3=c3, c3rank=c3rank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4, temp=temp) + +DEALLOCATE (temp) +END PROCEDURE obj_STForceVector21 + +!---------------------------------------------------------------------------- +! STForceVector21_ !---------------------------------------------------------------------------- +MODULE PROCEDURE obj_STForceVector_21 +INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3, i4 +REAL(DFP) :: realval, c3bar(3, 3), c2bar + +nipt = SIZE(test) +dim1 = FEVariableSize(obj=c3, dim=1) +dim2 = FEVariableSize(obj=c3, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + +DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL GetProjectionOfdNTdXt_( & + obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, & + ncol=i2) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + CALL FEVariableGetInterpolation_( & + obj=c3, rank=c3rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c3bar, nrow=i1, ncol=i2) + + realval = c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt + + CALL OuterProd_( & + a=c3bar(1:dim1, 1:dim2), b=temp(1:dim3, 1:dim4), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, & + anscoeff=math%one, scale=realval) + + END DO +END DO +END PROCEDURE obj_STForceVector_21 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector8 +INTEGER(I4B) :: nrow, ncol +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(test=test, term1=term1, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE obj_STForceVector8 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_8 +SELECT CASE (term1) +CASE (TypeDerivativeTerm%NONE) + CALL STFV_8a(test=test, ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeDerivativeTerm%t) + CALL STFV_8b(test=test, ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_8c(test=test, ans=ans, term1=term1, nrow=nrow, ncol=ncol) + +! CASE (TypeDerivativeTerm%xAll) + +END SELECT +END PROCEDURE obj_STForceVector_8 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! term1 is NONE +PURE SUBROUTINE STFV_8a(test, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Internal variables + INTEGER(I4B) :: ips, ipt, nipt, i1, i2 + REAL(DFP) :: realval + + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_(a=test(ipt)%N(1:nrow, ips), & + b=test(ipt)%T(1:ncol), & + anscoeff=math%one, scale=realval, & + ans=ans, nrow=i1, ncol=i2) + END DO + END DO +END SUBROUTINE STFV_8a + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_8b(test, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval + INTEGER(I4B) :: ips, ipt, nipt + + !! main + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * test(ipt)%dNTdt(1:nrow, 1:ncol, ips) + END DO + END DO +END SUBROUTINE STFV_8b + +!---------------------------------------------------------------------------- +! STFV_15 +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_8c(test, ans, term1, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + !! DEL_x, DEL_y, DEL_z + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval + INTEGER(I4B) :: ips, ipt, nipt + + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) & + + realval * test(ipt)%dNTdXt(1:nrow, 1:ncol, term1, ips) + END DO + END DO +END SUBROUTINE STFV_8c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector9 +INTEGER(I4B) :: nrow, ncol +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(test=test, term1=term1, c=c, crank=crank, ans=ans, & + nrow=nrow, ncol=ncol) +END PROCEDURE obj_STForceVector9 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_9 +SELECT CASE (term1) +CASE (TypeDerivativeTerm%NONE) + CALL STFV_9a(test=test, c=c, crank=crank, ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeDerivativeTerm%t) + CALL STFV_9b(test=test, c=c, crank=crank, ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_9c(test=test, term1=term1, c=c, crank=crank, ans=ans, & + nrow=nrow, ncol=ncol) +! CASE (TypeDerivativeTerm%xAll) +END SELECT +END PROCEDURE obj_STForceVector_9 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_9a(test, c, crank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + INTEGER(I4B) :: ips, ipt, nipt, i1, i2 + REAL(DFP) :: realval, cbar + + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * cbar * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), & + anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2) + END DO + END DO +END SUBROUTINE STFV_9a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! term is t +PURE SUBROUTINE STFV_9b(test, c, crank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval, cbar + INTEGER(I4B) :: ips, ipt, nipt + + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar) + + realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * test(ipt)%dNTdt(1:nrow, 1:ncol, ips) + END DO + END DO +END SUBROUTINE STFV_9b + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term is x, y, z +PURE SUBROUTINE STFV_9c(test, term1, c, crank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + ! DEL_x, DEL_y, DEL_z + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableScalar_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval, cbar + INTEGER(I4B) :: ips, ipt, nipt + + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar) + + realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + realval * & + test(ipt)%dNTdXt(1:nrow, 1:ncol, term1, ips) + END DO + END DO +END SUBROUTINE STFV_9c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector10 +INTEGER(I4B) :: dim1, dim2, dim3 +dim1 = FEVariableSize(obj=c, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt +CALL Reallocate(ans, dim1, dim2, dim3) +CALL STForceVector_(test=test, term1=term1, c=c, crank=crank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE obj_STForceVector10 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_10 +SELECT CASE (term1) +CASE (TypeDerivativeTerm%NONE) + CALL STFV_10a(test=test, c=c, crank=crank, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3) + +CASE (TypeDerivativeTerm%t) + CALL STFV_10b(test=test, c=c, crank=crank, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_10c(test=test, c=c, crank=crank, ans=ans, dim1=dim1, & + dim2=dim2, dim3=dim3, term1=term1) + +! CASE (TypeDerivativeTerm%xAll) + +END SELECT +END PROCEDURE obj_STForceVector_10 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_10a(test, c, crank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + ! Define internal variable + REAL(DFP) :: realval, cbar(3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c, dim=1) + dim2 = test(1)%nns + dim3 = test(1)%nnt + + ans(1:dim1, 1:dim2, 1:dim3) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar, tsize=i1) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=cbar(1:dim1), b=test(ipt)%N(1:dim2, ips), & + c=test(ipt)%T(1:dim3), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, & + anscoeff=math%one, scale=realval) + END DO + END DO +END SUBROUTINE STFV_10a + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_10b(test, c, crank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + ! Define internal variable + REAL(DFP) :: realval, cbar(3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c, dim=1) + dim2 = test(1)%nns + dim3 = test(1)%nnt + + ans(1:dim1, 1:dim2, 1:dim3) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar, tsize=i1) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=cbar(1:dim1), b=test(ipt)%dNTdt(1:dim2, 1:dim3, ips), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_10b + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +! term1 is x, y, z +PURE SUBROUTINE STFV_10c(test, term1, c, crank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableVector_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + ! Define internal variable + REAL(DFP) :: realval, cbar(3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c, dim=1) + dim2 = test(1)%nns + dim3 = test(1)%nnt + + ans(1:dim1, 1:dim2, 1:dim3) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar, tsize=i1) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=cbar(1:dim1), b=test(ipt)%dNTdXt(1:dim2, 1:dim3, term1, ips), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_10c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector11 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 + +dim1 = FEVariableSize(obj=c, dim=1) +dim2 = FEVariableSize(obj=c, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL STForceVector_( & + test=test, term1=term1, c=c, crank=crank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4) +END PROCEDURE obj_STForceVector11 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_11 +SELECT CASE (term1) +CASE (TypeDerivativeTerm%NONE) + CALL STFV_11a(test=test, c=c, crank=crank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4) + +CASE (TypeDerivativeTerm%t) + CALL STFV_11b(test=test, c=c, crank=crank, ans=ans, dim1=dim1, dim2=dim2, & + dim3=dim3, dim4=dim4) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_11c(test=test, term1=term1, c=c, crank=crank, ans=ans, & + dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) + +END SELECT +END PROCEDURE obj_STForceVector_11 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! term1 is NONE +PURE SUBROUTINE STFV_11a(test, c, crank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + ! Define internal variable + REAL(DFP) :: realval, cbar(3, 3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 + + dim1 = FEVariableSize(obj=c, dim=1) + dim2 = FEVariableSize(obj=c, dim=2) + dim3 = test(1)%nns + dim4 = test(1)%nnt + nipt = SIZE(test) + + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar, nrow=i1, ncol=i2) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=cbar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), & + c=test(ipt)%T(1:dim4), ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, & + anscoeff=math%one, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_11a + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_11b(test, c, crank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + ! Define internal variable + REAL(DFP) :: realval, cbar(3, 3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 + + dim1 = FEVariableSize(obj=c, dim=1) + dim2 = FEVariableSize(obj=c, dim=2) + dim3 = test(1)%nns + dim4 = test(1)%nnt + nipt = SIZE(test) + + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar, nrow=i1, ncol=i2) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=cbar(1:dim1, 1:dim2), b=test(ipt)%dNTdt(1:dim3, 1:dim4, ips), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, & + anscoeff=math%one, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_11b + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_11c(test, term1, c, crank, ans, dim1, dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c + TYPE(FEVariableMatrix_), INTENT(IN) :: crank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + ! Define internal variable + REAL(DFP) :: realval, cbar(3, 3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 + + dim1 = FEVariableSize(obj=c, dim=1) + dim2 = FEVariableSize(obj=c, dim=2) + dim3 = test(1)%nns + dim4 = test(1)%nnt + nipt = SIZE(test) + + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=cbar, nrow=i1, ncol=i2) + + realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * & + test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=cbar(1:dim1, 1:dim2), & + b=test(ipt)%dNTdXt(1:dim3, 1:dim4, term1, ips), & + ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, & + anscoeff=math%one, scale=realval) + + END DO + END DO +END SUBROUTINE STFV_11c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector12 +INTEGER(I4B) :: nrow, ncol +nrow = test(1)%nns +ncol = test(1)%nnt +CALL Reallocate(ans, nrow, ncol) +CALL STForceVector_(test=test, term1=term1, c1=c1, c1rank=c1rank, & + c2=c2, c2rank=c2rank, ans=ans, nrow=nrow, ncol=ncol) +END PROCEDURE obj_STForceVector12 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_12 +SELECT CASE (term1) +CASE (TypeDerivativeTerm%NONE) + CALL STFV_12a(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, nrow=nrow, ncol=ncol) +CASE (TypeDerivativeTerm%t) + CALL STFV_12b(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_12c(test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, nrow=nrow, ncol=ncol) + +! CASE (TypeDerivativeTerm%xAll) + +END SELECT +END PROCEDURE obj_STForceVector_12 + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +! term1 is none +PURE SUBROUTINE STFV_12a(test, c1, c1rank, c2, c2rank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval, c1bar, c2bar + INTEGER(I4B) :: ips, ipt, nipt, i1, i2 + + ! main + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), & + anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2) + + END DO + END DO +END SUBROUTINE STFV_12a + +!---------------------------------------------------------------------------- +! STForceVector +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_12b(test, c1, c1rank, c2, c2rank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval, c1bar, c2bar + INTEGER(I4B) :: ips, ipt, nipt + + ! main + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * test(ipt)%dNTdt(1:nrow, 1:ncol, ips) + + END DO + END DO +END SUBROUTINE STFV_12b + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term1 is x, y, z +PURE SUBROUTINE STFV_12c(test, term1, c1, c1rank, c2, c2rank, ans, nrow, ncol) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableScalar_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :) + INTEGER(I4B), INTENT(OUT) :: nrow, ncol + + ! Define internal variable + REAL(DFP) :: realval, c1bar, c2bar + INTEGER(I4B) :: ips, ipt, nipt + + ! main + nipt = SIZE(test) + nrow = test(1)%nns + ncol = test(1)%nnt + + ans(1:nrow, 1:ncol) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar) + + realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + & + realval * test(ipt)%dNTdXt(1:nrow, 1:ncol, term1, ips) + + END DO + END DO +END SUBROUTINE STFV_12c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector13 +INTEGER(I4B) :: dim1, dim2, dim3 + +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = test(1)%nns +dim3 = test(1)%nnt +CALL Reallocate(ans, dim1, dim2, dim3) +CALL STForceVector_( & + test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE obj_STForceVector13 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_13 +SELECT CASE (term1) + +CASE (TypeDerivativeTerm%NONE) + CALL STFV_13a(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (TypeDerivativeTerm%t) + CALL STFV_13b(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_13c(test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) + +! CASE (TypeDerivativeTerm%xAll) +END SELECT +END PROCEDURE obj_STForceVector_13 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +PURE SUBROUTINE STFV_13a(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + ! Internal variables + REAL(DFP) :: realval, c2bar(3), c1bar + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c2, dim=1) + dim2 = test(1)%nns + dim3 = test(1)%nnt + + ans(1:dim1, 1:dim2, 1:dim3) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1), b=test(ipt)%N(1:dim2, ips), c=test(ipt)%T(1:dim3), & + anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO + END DO +END SUBROUTINE STFV_13a + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_13b(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + ! Internal variables + REAL(DFP) :: realval, c2bar(3), c1bar + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c2, dim=1) + dim2 = test(1)%nns + dim3 = test(1)%nnt + + ans(1:dim1, 1:dim2, 1:dim3) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1), b=test(ipt)%dNTdt(1:dim2, 1:dim3, ips), & + anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO + END DO +END SUBROUTINE STFV_13b + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term1 is x, y, z +PURE SUBROUTINE STFV_13c(test, term1, c1, c1rank, c2, c2rank, ans, dim1, & + dim2, dim3) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableVector_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3 + + ! Internal variables + REAL(DFP) :: realval, c2bar(3), c1bar + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c2, dim=1) + dim2 = test(1)%nns + dim3 = test(1)%nnt + + ans(1:dim1, 1:dim2, 1:dim3) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1), b=test(ipt)%dNTdXt(1:dim2, 1:dim3, term1, ips), & + anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3) + + END DO + END DO +END SUBROUTINE STFV_13c + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector14 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +dim1 = FEVariableSize(obj=c2, dim=1) +dim2 = FEVariableSize(obj=c2, dim=2) +dim3 = test(1)%nns +dim4 = test(1)%nnt + +CALL Reallocate(ans, dim1, dim2, dim3, dim4) +CALL STForceVector_( & + test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) +END PROCEDURE obj_STForceVector14 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_STForceVector_14 +SELECT CASE (term1) + +CASE (TypeDerivativeTerm%NONE) + CALL STFV_14a(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) + +CASE (TypeDerivativeTerm%t) + CALL STFV_14b(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, & + ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) + +CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z) + CALL STFV_14c(test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, & + c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) + +CASE (TypeDerivativeTerm%xAll) +END SELECT +END PROCEDURE obj_STForceVector_14 + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term1 is none +PURE SUBROUTINE STFV_14a(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, & + dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + !! Internal variables + REAL(DFP) :: realval, c1bar, c2bar(3, 3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c2, dim=1) + dim2 = FEVariableSize(obj=c2, dim=2) + dim3 = test(1)%nns + dim4 = test(1)%nnt + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), & + c=test(ipt)%T(1:dim4), anscoeff=math%one, scale=realval, ans=ans, & + dim1=i1, dim2=i2, dim3=i3, dim4=i4) + + END DO + END DO +END SUBROUTINE STFV_14a + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term1 is t +PURE SUBROUTINE STFV_14b(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, & + dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + !! Internal variables + REAL(DFP) :: realval, c1bar, c2bar(3, 3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c2, dim=1) + dim2 = FEVariableSize(obj=c2, dim=2) + dim3 = test(1)%nns + dim4 = test(1)%nnt + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1, 1:dim2), b=test(ipt)%dNTdt(1:dim3, 1:dim4, ips), & + anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, & + dim3=i3, dim4=i4) + + END DO + END DO +END SUBROUTINE STFV_14b + +!---------------------------------------------------------------------------- +! STForceVector_ +!---------------------------------------------------------------------------- + +! term1 is x, y, z +PURE SUBROUTINE STFV_14c(test, term1, c1, c1rank, c2, c2rank, ans, dim1, & + dim2, dim3, dim4) + CLASS(STElemshapeData_), INTENT(IN) :: test(:) + INTEGER(I4B), INTENT(IN) :: term1 + TYPE(FEVariable_), INTENT(IN) :: c1 + TYPE(FEVariable_), INTENT(IN) :: c2 + TYPE(FEVariableScalar_), INTENT(IN) :: c1rank + TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank + REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :) + INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4 + + !! Internal variables + REAL(DFP) :: realval, c1bar, c2bar(3, 3) + INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4 + + nipt = SIZE(test) + dim1 = FEVariableSize(obj=c2, dim=1) + dim2 = FEVariableSize(obj=c2, dim=2) + dim3 = test(1)%nns + dim4 = test(1)%nnt + ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero + + DO ipt = 1, nipt + DO ips = 1, test(ipt)%nips + + CALL FEVariableGetInterpolation_( & + obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c1bar) + + CALL FEVariableGetInterpolation_( & + obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, & + spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, & + scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2) + + realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) & + * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt + + CALL OuterProd_( & + a=c2bar(1:dim1, 1:dim2), & + b=test(ipt)%dNTdXt(1:dim3, 1:dim4, term1, ips), anscoeff=math%one, & + scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4) + + END DO + END DO +END SUBROUTINE STFV_14c + +!---------------------------------------------------------------------------- +! Include error +!---------------------------------------------------------------------------- + +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/STMassMatrix/src/STMM_10.inc b/src/submodules/STMassMatrix/src/STMM_10.inc index 5fcce6471..8d8be54b6 100644 --- a/src/submodules/STMassMatrix/src/STMM_10.inc +++ b/src/submodules/STMassMatrix/src/STMM_10.inc @@ -40,7 +40,7 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_11.inc b/src/submodules/STMassMatrix/src/STMM_11.inc index dd37d0b9d..af80820ac 100644 --- a/src/submodules/STMassMatrix/src/STMM_11.inc +++ b/src/submodules/STMassMatrix/src/STMM_11.inc @@ -43,7 +43,7 @@ !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_12.inc b/src/submodules/STMassMatrix/src/STMM_12.inc index fae4e434d..50d93c589 100644 --- a/src/submodules/STMassMatrix/src/STMM_12.inc +++ b/src/submodules/STMassMatrix/src/STMM_12.inc @@ -38,7 +38,7 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & diff --git a/src/submodules/STMassMatrix/src/STMM_13.inc b/src/submodules/STMassMatrix/src/STMM_13.inc index f5b9512b2..23c0dc44b 100644 --- a/src/submodules/STMassMatrix/src/STMM_13.inc +++ b/src/submodules/STMassMatrix/src/STMM_13.inc @@ -38,7 +38,7 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_14.inc b/src/submodules/STMassMatrix/src/STMM_14.inc index 93e435df6..1bef25201 100644 --- a/src/submodules/STMassMatrix/src/STMM_14.inc +++ b/src/submodules/STMassMatrix/src/STMM_14.inc @@ -39,7 +39,7 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_15.inc b/src/submodules/STMassMatrix/src/STMM_15.inc index a3cca6c48..3d9137198 100644 --- a/src/submodules/STMassMatrix/src/STMM_15.inc +++ b/src/submodules/STMassMatrix/src/STMM_15.inc @@ -37,7 +37,7 @@ PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_16.inc b/src/submodules/STMassMatrix/src/STMM_16.inc index f2f7934f4..26f80009e 100644 --- a/src/submodules/STMassMatrix/src/STMM_16.inc +++ b/src/submodules/STMassMatrix/src/STMM_16.inc @@ -37,7 +37,7 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=kbar, val=rho) +CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & diff --git a/src/submodules/STMassMatrix/src/STMM_17_20.inc b/src/submodules/STMassMatrix/src/STMM_17_20.inc index 79fa78f10..15cdbd362 100644 --- a/src/submodules/STMassMatrix/src/STMM_17_20.inc +++ b/src/submodules/STMassMatrix/src/STMM_17_20.inc @@ -43,8 +43,8 @@ CALL Reallocate(IaJb, & & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! -CALL GetInterpolation(obj=trial, interpol=m2, val=c1) -CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) +CALL GetInterpolation(obj=trial, ans=m2, val=c1) +CALL GetInterpolation(obj=trial, ans=m2b, val=c2) !! DO ipt = 1, SIZE(trial) !! diff --git a/src/submodules/STMassMatrix/src/STMM_21.inc b/src/submodules/STMassMatrix/src/STMM_21.inc index 7d80f5c6f..06ba0feab 100644 --- a/src/submodules/STMassMatrix/src/STMM_21.inc +++ b/src/submodules/STMassMatrix/src/STMM_21.inc @@ -40,8 +40,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +CALL getInterpolation(obj=trial, ans=c1bar, val=c1) +CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_22.inc b/src/submodules/STMassMatrix/src/STMM_22.inc index 8b90d56fd..2afef3b37 100644 --- a/src/submodules/STMassMatrix/src/STMM_22.inc +++ b/src/submodules/STMassMatrix/src/STMM_22.inc @@ -42,8 +42,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +CALL getInterpolation(obj=trial, ans=c1bar, val=c1) +CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_23.inc b/src/submodules/STMassMatrix/src/STMM_23.inc index 392086dc1..4d1254421 100644 --- a/src/submodules/STMassMatrix/src/STMM_23.inc +++ b/src/submodules/STMassMatrix/src/STMM_23.inc @@ -45,8 +45,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +CALL getInterpolation(obj=trial, ans=c1bar, val=c1) +CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -77,4 +77,4 @@ END DO !! CALL Convert(from=m6, to=ans) !! -DEALLOCATE (m6, ij, c1bar, vbar, realval) \ No newline at end of file +DEALLOCATE (m6, ij, c1bar, vbar, realval) diff --git a/src/submodules/STMassMatrix/src/STMM_24.inc b/src/submodules/STMassMatrix/src/STMM_24.inc index 864486652..fb27dcf23 100644 --- a/src/submodules/STMassMatrix/src/STMM_24.inc +++ b/src/submodules/STMassMatrix/src/STMM_24.inc @@ -40,8 +40,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=vbar, val=c2) +CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) +CALL GetInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_25.inc b/src/submodules/STMassMatrix/src/STMM_25.inc index 5c3c7a257..d5e65e3aa 100644 --- a/src/submodules/STMassMatrix/src/STMM_25.inc +++ b/src/submodules/STMassMatrix/src/STMM_25.inc @@ -41,8 +41,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +CALL getInterpolation(obj=trial, ans=c1bar, val=c1) +CALL getInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_26.inc b/src/submodules/STMassMatrix/src/STMM_26.inc index cfff28b2b..a7e46f2d2 100644 --- a/src/submodules/STMassMatrix/src/STMM_26.inc +++ b/src/submodules/STMassMatrix/src/STMM_26.inc @@ -43,8 +43,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +CALL getInterpolation(obj=trial, ans=c1bar, val=c1) +CALL getInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_27.inc b/src/submodules/STMassMatrix/src/STMM_27.inc index 5e54e6983..9be467218 100644 --- a/src/submodules/STMassMatrix/src/STMM_27.inc +++ b/src/submodules/STMassMatrix/src/STMM_27.inc @@ -40,8 +40,8 @@ PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_28.inc b/src/submodules/STMassMatrix/src/STMM_28.inc index 6bd0c9393..970c6b97d 100644 --- a/src/submodules/STMassMatrix/src/STMM_28.inc +++ b/src/submodules/STMassMatrix/src/STMM_28.inc @@ -40,8 +40,8 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) -CALL getInterpolation(obj=trial, interpol=kbar, val=c2) +CALL getInterpolation(obj=trial, ans=c1bar, val=c1) +CALL getInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMM_5.inc b/src/submodules/STMassMatrix/src/STMM_5.inc index b536a0c53..ec5057b7d 100644 --- a/src/submodules/STMassMatrix/src/STMM_5.inc +++ b/src/submodules/STMassMatrix/src/STMM_5.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL getInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & diff --git a/src/submodules/STMassMatrix/src/STMM_6.inc b/src/submodules/STMassMatrix/src/STMM_6.inc index 9424215c7..738cd9102 100644 --- a/src/submodules/STMassMatrix/src/STMM_6.inc +++ b/src/submodules/STMassMatrix/src/STMM_6.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL getInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & diff --git a/src/submodules/STMassMatrix/src/STMM_7.inc b/src/submodules/STMassMatrix/src/STMM_7.inc index 8474fde1e..fa33dc83f 100644 --- a/src/submodules/STMassMatrix/src/STMM_7.inc +++ b/src/submodules/STMassMatrix/src/STMM_7.inc @@ -45,7 +45,7 @@ PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt) & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL getInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & diff --git a/src/submodules/STMassMatrix/src/STMM_8.inc b/src/submodules/STMassMatrix/src/STMM_8.inc index 326e32b62..9a70ec6da 100644 --- a/src/submodules/STMassMatrix/src/STMM_8.inc +++ b/src/submodules/STMassMatrix/src/STMM_8.inc @@ -40,7 +40,7 @@ PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL getInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & diff --git a/src/submodules/STMassMatrix/src/STMM_9.inc b/src/submodules/STMassMatrix/src/STMM_9.inc index 9d6980288..e0c430927 100644 --- a/src/submodules/STMassMatrix/src/STMM_9.inc +++ b/src/submodules/STMassMatrix/src/STMM_9.inc @@ -37,7 +37,7 @@ INTEGER(I4B) :: ipt, ips, a, b !! !! main !! -CALL getInterpolation(obj=trial, interpol=vbar, val=rho) +CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 index 78aa30ae6..6ddfc9355 100644 --- a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 +++ b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 @@ -206,7 +206,7 @@ PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL getInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & @@ -255,7 +255,7 @@ PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & @@ -309,7 +309,7 @@ PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt) & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & @@ -358,7 +358,7 @@ PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt) !! CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), & & SIZE(trial(1)%N, 1), SIZE(trial(1)%T)) - CALL getInterpolation(obj=trial, interpol=rhobar, val=rho) + CALL GetInterpolation(obj=trial, ans=rhobar, val=rho) !! DO ipt = 1, SIZE(trial) realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * & @@ -405,7 +405,7 @@ PURE SUBROUTINE STMM_9a(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -466,7 +466,7 @@ PURE SUBROUTINE STMM_9b(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -527,7 +527,7 @@ PURE SUBROUTINE STMM_9c(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -588,7 +588,7 @@ PURE SUBROUTINE STMM_9d(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -651,7 +651,7 @@ PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -724,7 +724,7 @@ PURE SUBROUTINE STMM_10b(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -797,7 +797,7 @@ PURE SUBROUTINE STMM_10c(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -871,7 +871,7 @@ PURE SUBROUTINE STMM_10d(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -943,7 +943,7 @@ PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1010,7 +1010,7 @@ PURE SUBROUTINE STMM_11b(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1076,7 +1076,7 @@ PURE SUBROUTINE STMM_11c(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1144,7 +1144,7 @@ PURE SUBROUTINE STMM_11d(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1215,7 +1215,7 @@ PURE SUBROUTINE STMM_12a(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & @@ -1284,7 +1284,7 @@ PURE SUBROUTINE STMM_12b(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & @@ -1353,7 +1353,7 @@ PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & @@ -1422,7 +1422,7 @@ PURE SUBROUTINE STMM_12d(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=vbar, val=rho) + CALL getInterpolation(obj=trial, ans=vbar, val=rho) !! CALL Reallocate(m6, & @@ -1486,7 +1486,7 @@ PURE SUBROUTINE STMM_13(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1540,7 +1540,7 @@ PURE SUBROUTINE STMM_14(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1602,7 +1602,7 @@ PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -1658,7 +1658,7 @@ PURE SUBROUTINE STMM_16(ans, test, trial, term1, term2, rho) !! !! main !! - CALL getInterpolation(obj=trial, interpol=kbar, val=rho) + CALL getInterpolation(obj=trial, ans=kbar, val=rho) !! CALL Reallocate(m6, & @@ -1730,8 +1730,8 @@ PURE SUBROUTINE STMM_17(ans, test, trial, term1, term2, c1, c2, opt) & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, interpol=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) + CALL GetInterpolation(obj=trial, ans=m2, val=c1) + CALL GetInterpolation(obj=trial, ans=m2b, val=c2) !! DO ipt = 1, SIZE(trial) !! @@ -1790,8 +1790,8 @@ PURE SUBROUTINE STMM_18(ans, test, trial, term1, term2, c1, c2, opt) & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, interpol=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) + CALL GetInterpolation(obj=trial, ans=m2, val=c1) + CALL GetInterpolation(obj=trial, ans=m2b, val=c2) !! DO ipt = 1, SIZE(trial) !! @@ -1850,8 +1850,8 @@ PURE SUBROUTINE STMM_19(ans, test, trial, term1, term2, c1, c2, opt) & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, interpol=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) + CALL GetInterpolation(obj=trial, ans=m2, val=c1) + CALL GetInterpolation(obj=trial, ans=m2b, val=c2) !! DO ipt = 1, SIZE(trial) !! @@ -1910,8 +1910,8 @@ PURE SUBROUTINE STMM_20(ans, test, trial, term1, term2, c1, c2, opt) & SIZE(trial(1)%N, 1), & & SIZE(trial(1)%T)) !! - CALL GetInterpolation(obj=trial, interpol=m2, val=c1) - CALL GetInterpolation(obj=trial, interpol=m2b, val=c2) + CALL GetInterpolation(obj=trial, ans=m2, val=c1) + CALL GetInterpolation(obj=trial, ans=m2b, val=c2) !! DO ipt = 1, SIZE(trial) !! @@ -1964,8 +1964,8 @@ PURE SUBROUTINE STMM_21a(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2028,8 +2028,8 @@ PURE SUBROUTINE STMM_21b(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2092,8 +2092,8 @@ PURE SUBROUTINE STMM_21c(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2156,8 +2156,8 @@ PURE SUBROUTINE STMM_21d(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2222,8 +2222,8 @@ PURE SUBROUTINE STMM_22a(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2297,8 +2297,8 @@ PURE SUBROUTINE STMM_22b(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2372,8 +2372,8 @@ PURE SUBROUTINE STMM_22c(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2447,8 +2447,8 @@ PURE SUBROUTINE STMM_22d(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2521,8 +2521,8 @@ PURE SUBROUTINE STMM_23a(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2591,8 +2591,8 @@ PURE SUBROUTINE STMM_23b(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2661,8 +2661,8 @@ PURE SUBROUTINE STMM_23c(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2731,8 +2731,8 @@ PURE SUBROUTINE STMM_23d(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=vbar, val=c2) + CALL getInterpolation(obj=trial, ans=c1bar, val=c1) + CALL getInterpolation(obj=trial, ans=vbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2864,8 +2864,8 @@ PURE SUBROUTINE STMM_25(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) + CALL GetInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2923,8 +2923,8 @@ PURE SUBROUTINE STMM_26(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) + CALL GetInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -2989,8 +2989,8 @@ PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) + CALL GetInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & @@ -3049,8 +3049,8 @@ PURE SUBROUTINE STMM_28(ans, test, trial, term1, term2, c1, c2) !! !! main !! - CALL getInterpolation(obj=trial, interpol=c1bar, val=c1) - CALL getInterpolation(obj=trial, interpol=kbar, val=c2) + CALL GetInterpolation(obj=trial, ans=c1bar, val=c1) + CALL GetInterpolation(obj=trial, ans=kbar, val=c2) !! CALL Reallocate(m6, & & SIZE(test(1)%N, 1), & diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 index 65c2c2283..8e675cde2 100644 --- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 +++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 @@ -36,7 +36,7 @@ nsd = SIZE(trial%dNdXt, 2) CALL Reallocate(ans, nns1 * nsd, nns2 * nsd) -CALL GetInterpolation(obj=test, interpol=CBar, val=Cijkl) +CALL GetInterpolation(obj=test, ans=CBar, val=Cijkl) SELECT CASE (nsd) CASE (1) @@ -106,7 +106,7 @@ ncol = nns2 * nsd ans(1:nrow, 1:ncol) = 0.0 -CALL GetInterpolation_(obj=test, interpol=CBar, val=Cijkl, & +CALL GetInterpolation_(obj=test, ans=CBar, val=Cijkl, & dim1=ii, dim2=jj, dim3=kk) SELECT CASE (nsd) @@ -179,8 +179,8 @@ ALLOCATE (ans(nns1 * nsd, nns2 * nsd)) ans = 0.0_DFP -CALL GetInterpolation(obj=test, interpol=lambdaBar, val=lambda0) -CALL GetInterpolation(obj=test, interpol=muBar, val=mu) +CALL GetInterpolation(obj=test, ans=lambdaBar, val=lambda0) +CALL GetInterpolation(obj=test, ans=muBar, val=mu) CALL Reallocate(realval, nips) realval = trial%ws * trial%js * trial%thickness @@ -256,8 +256,8 @@ ncol = nns2 * nsd ans(1:nrow, 1:ncol) = zero -CALL GetInterpolation_(obj=test, interpol=lambdaBar, val=lambda0, tsize=ii) -CALL GetInterpolation_(obj=test, interpol=muBar, val=mu, tsize=ii) +CALL GetInterpolation_(obj=test, ans=lambdaBar, val=lambda0, tsize=ii) +CALL GetInterpolation_(obj=test, ans=muBar, val=mu, tsize=ii) DO ips = 1, nips @@ -473,7 +473,7 @@ BMat1(test%nsd * test%nns, test%nsd * test%nsd), & BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd) INTEGER(I4B) :: nips, nns1, nns2, ii, jj, ips, nsd -INTEGER(I4B), ALLOCATABLE :: indx(:, :) +INTEGER(I4B) :: indx(3, 3) nns1 = SIZE(test%N, 1) nns2 = SIZE(trial%N, 1) diff --git a/src/submodules/Tetrahedron/CMakeLists.txt b/src/submodules/Tetrahedron/CMakeLists.txt new file mode 100644 index 000000000..d17c7ce56 --- /dev/null +++ b/src/submodules/Tetrahedron/CMakeLists.txt @@ -0,0 +1,23 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferenceTetrahedron_Method@Methods.F90 + ${src_path}/TetrahedronInterpolationUtility@Methods.F90 + ${src_path}/Tetrahedron_QuadraturePoint_Solin.F90) diff --git a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Tetrahedron/src/ReferenceTetrahedron_Method@Methods.F90 similarity index 95% rename from src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 rename to src/submodules/Tetrahedron/src/ReferenceTetrahedron_Method@Methods.F90 index 9073009d2..b2c9a0b47 100644 --- a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 +++ b/src/submodules/Tetrahedron/src/ReferenceTetrahedron_Method@Methods.F90 @@ -570,7 +570,7 @@ ! GetFaceElemType !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Tetrahedron +MODULE PROCEDURE GetFaceElemType_Tetrahedron1 INTEGER(I4B) :: elemType0 elemType0 = Input(default=Tetrahedron4, option=elemType) @@ -606,6 +606,35 @@ IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 21_I4B END SELECT -END PROCEDURE GetFaceElemType_Tetrahedron +END PROCEDURE GetFaceElemType_Tetrahedron1 + +!---------------------------------------------------------------------------- +! GetFaceElemType +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Tetrahedron2 +SELECT CASE (elemType) +CASE (Tetrahedron4) + faceElemType = Triangle3 + tFaceNodes = 3_I4B + +CASE (Tetrahedron10) + faceElemType = Triangle6 + tFaceNodes = 6_I4B + +CASE (Tetrahedron20) + faceElemType = Triangle10 + tFaceNodes = 10_I4B + +CASE (Tetrahedron35) + faceElemType = Triangle15 + tFaceNodes = 15_I4B + +CASE (Tetrahedron56) + faceElemType = Triangle21 + tFaceNodes = 21_I4B + +END SELECT +END PROCEDURE GetFaceElemType_Tetrahedron2 END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90 similarity index 99% rename from src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 rename to src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90 index fc5d4241e..1367badc1 100644 --- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 +++ b/src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90 @@ -16,7 +16,7 @@ SUBMODULE(TetrahedronInterpolationUtility) Methods USE BaseMethod -USE QuadraturePoint_Tetrahedron_Solin, ONLY: & +USE Tetrahedron_QuadraturePoint_Solin, ONLY: & QuadratureNumberTetrahedronSolin, & QuadratureOrderTetrahedronSolin, & QuadraturePointTetrahedronSolin, & diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 similarity index 98% rename from src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 rename to src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 index b1fe4e11e..750732c01 100644 --- a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 +++ b/src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 @@ -15,7 +15,7 @@ ! along with this program. If not, see ! -MODULE QuadraturePoint_Tetrahedron_Solin +MODULE Tetrahedron_QuadraturePoint_Solin USE GlobalData, ONLY: DFP, I4B, LGT IMPLICIT NONE @@ -210,4 +210,4 @@ END SUBROUTINE QuadraturePointTetrahedronSolin ! !---------------------------------------------------------------------------- -END MODULE QuadraturePoint_Tetrahedron_Solin +END MODULE Tetrahedron_QuadraturePoint_Solin diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order1.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order1.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order10.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order10.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order11.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order11.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order12.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order12.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order13.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order13.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order14.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order14.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order15.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order15.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order16.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order16.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order17.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order17.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order18.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order18.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order19.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order19.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order2.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order2.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order20.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order20.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order21.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order21.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order3.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order3.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order4.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order4.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order5.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order5.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order6.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order6.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order7.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order7.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order8.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order8.F90 diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order9.F90 similarity index 100% rename from src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 rename to src/submodules/Tetrahedron/src/include/Tetrahedron/order9.F90 diff --git a/src/submodules/Triangle/CMakeLists.txt b/src/submodules/Triangle/CMakeLists.txt new file mode 100644 index 000000000..d1dabf4fd --- /dev/null +++ b/src/submodules/Triangle/CMakeLists.txt @@ -0,0 +1,28 @@ +# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas +# Sharma, Ph.D +# +# This program is free software: you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, either version 3 of the License, or (at your option) any later +# version. +# +# This program is distributed in the hope that it will be useful, but WITHOUT +# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License along with +# this program. If not, see +# + +set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/") +target_sources( + ${PROJECT_NAME} + PRIVATE ${src_path}/ReferenceTriangle_Method@Methods.F90 + ${src_path}/Triangle_Method@Methods.F90 + ${src_path}/Triangle_QuadraturePoint_Solin.F90 + ${src_path}/TriangleInterpolationUtility@Methods.F90 + ${src_path}/TriangleInterpolationUtility@QuadratureMethods.F90 + ${src_path}/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 + ${src_path}/TriangleInterpolationUtility@LagrangeBasisMethods.F90 + ${src_path}/TriangleInterpolationUtility@OrthogonalBasisMethods.F90) diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90 similarity index 96% rename from src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 rename to src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90 index 11712ee97..e1fd50232 100644 --- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 +++ b/src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90 @@ -25,12 +25,12 @@ USE StringUtility USE ApproxUtility USE ArangeUtility -USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle, & - & LagrangeDOF_Triangle +USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle, & + LagrangeDOF_Triangle USE Triangle_Method USE InputUtility -USE ReferenceLine_Method, ONLY: ElementType_Line, & - & ElementOrder_Line +USE ReferenceLine_Method, ONLY: ElementType_Line, & + ElementOrder_Line USE LineInterpolationUtility, ONLY: InterpolationPoint_Line USE MiscUtility, ONLY: Int2Str USE Display_Method @@ -808,10 +808,10 @@ ! GetFaceElemType_Triangle !---------------------------------------------------------------------------- -MODULE PROCEDURE GetFaceElemType_Triangle +MODULE PROCEDURE GetFaceElemType_Triangle1 INTEGER(I4B) :: elemType0 -elemType0 = input(default=Triangle, option=elemType) +elemType0 = Input(default=Triangle, option=elemType) SELECT CASE (elemType0) @@ -842,7 +842,41 @@ END SELECT -END PROCEDURE GetFaceElemType_Triangle +END PROCEDURE GetFaceElemType_Triangle1 + +!---------------------------------------------------------------------------- +! GetFaceElemType_Triangle2 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetFaceElemType_Triangle2 +SELECT CASE (elemType) + +CASE (Triangle3) + faceElemType = Line2 + tFaceNodes = 2_I4B + +CASE (Triangle6) + faceElemType = Line3 + tFaceNodes = 3_I4B + +CASE (Triangle9, Triangle10) + faceElemType = Line4 + tFaceNodes = 4_I4B + +CASE (Triangle15) + faceElemType = Line5 + tFaceNodes = 5_I4B + +CASE (Triangle21a, Triangle21b) + faceElemType = Line6 + tFaceNodes = 6_I4B + +CASE (Triangle18) + faceElemType = Line7 + tFaceNodes = 7_I4B + +END SELECT +END PROCEDURE GetFaceElemType_Triangle2 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 similarity index 98% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 index b516b00d9..331c293f6 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 @@ -22,6 +22,30 @@ IMPLICIT NONE CONTAINS +!---------------------------------------------------------------------------- +! GetHierarchicalDOF_Triangle +!---------------------------------------------------------------------------- + +MODULE PROCEDURE GetHierarchicalDOF_Triangle +ans = 0 + +SELECT CASE (opt) + +CASE ("v", "V") + ans = 3 + +CASE ("e", "E") + ans = pe1 + pe2 + pe3 - 3 + +CASE ("c", "C") + ans = (order - 1) * (order - 2) / 2_I4B + +CASE DEFAULT + ans = pe1 + pe2 + pe3 + (order - 1) * (order - 2) / 2_I4B + +END SELECT +END PROCEDURE GetHierarchicalDOF_Triangle + !---------------------------------------------------------------------------- ! BarycentricVertexBasis_Triangle !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 similarity index 74% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 index ff0ef79d0..8fb1b6a62 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 @@ -16,13 +16,10 @@ SUBMODULE(TriangleInterpolationUtility) LagrangeBasisMethods USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_ -USE ErrorHandling, ONLY: Errormsg USE InputUtility, ONLY: Input USE GE_CompRoutineMethods, ONLY: GetInvMat USE GE_LUMethods, ONLY: LUSolve, GetLU - USE F95_BLAS, ONLY: GEMM - USE BaseType, ONLY: polyopt => TypePolynomialOpt, elemopt => TypeElemNameOpt IMPLICIT NONE @@ -173,7 +170,6 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeCoeff_Triangle4_ - SELECT CASE (basisType) CASE (polyopt%Monomial) @@ -188,25 +184,65 @@ CASE (polyopt%Hierarchical) - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=xij, refTriangle=refTriangle, & - ans=ans, nrow=nrow, ncol=ncol) + CALL HeirarchicalBasis_Triangle_( & + order=order, pe1=order, pe2=order, pe3=order, xij=xij, & + refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) END SELECT CALL GetInvMat(ans(1:nrow, 1:ncol)) - END PROCEDURE LagrangeCoeff_Triangle4_ +!---------------------------------------------------------------------------- +! LagrangeCoeff_Triangle4 +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeCoeff_Triangle5_ +SELECT CASE (basisType) + +CASE (polyopt%Monomial) + CALL LagrangeVandermonde_Triangle_(xij=xij, degree=degree, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, & + polyopt%Lobatto, polyopt%Ultraspherical) + + CALL Dubiner_Triangle_(order=order, xij=xij, refTriangle=refTriangle, & + ans=ans, nrow=nrow, ncol=ncol) + +CASE (polyopt%Hierarchical) + + CALL HeirarchicalBasis_Triangle_( & + order=order, pe1=order, pe2=order, pe3=order, xij=xij, & + refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol) +END SELECT + +CALL GetInvMat(ans(1:nrow, 1:ncol)) +END PROCEDURE LagrangeCoeff_Triangle5_ + +!---------------------------------------------------------------------------- +! LagrangeVandermonde +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeVandermonde_Triangle1_ +INTEGER(I4B) :: jj, ii + +nrow = SIZE(xij, 2) +ncol = SIZE(degree, 1) + +DO CONCURRENT(ii=1:nrow, jj=1:ncol) + ans(ii, jj) = xij(1, ii)**degree(jj, 1) * xij(2, ii)**degree(jj, 2) +END DO +END PROCEDURE LagrangeVandermonde_Triangle1_ + !---------------------------------------------------------------------------- ! LagrangeEvalAll_Triangle !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Triangle1 INTEGER(I4B) :: tsize - -CALL LagrangeEvalAll_Triangle1_(order=order, x=x, xij=xij, ans=ans, & - tsize=tsize, refTriangle=refTriangle, coeff=coeff, & - firstCall=firstCall, basisType=basisType) +CALL LagrangeEvalAll_Triangle1_( & + order=order, x=x, xij=xij, ans=ans, tsize=tsize, refTriangle=refTriangle, & + coeff=coeff, firstCall=firstCall, basisType=basisType) END PROCEDURE LagrangeEvalAll_Triangle1 !---------------------------------------------------------------------------- @@ -285,13 +321,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE LagrangeEvalAll_Triangle2 - INTEGER(I4B) :: nrow, ncol -CALL LagrangeEvalAll_Triangle2_(order=order, x=x, xij=xij, & - reftriangle=reftriangle, & - coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, & - beta=beta, lambda=lambda, nrow=nrow, ncol=ncol, ans=ans) +CALL LagrangeEvalAll_Triangle2_( & + order=order, x=x, xij=xij, reftriangle=reftriangle, coeff=coeff, & + firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & + lambda=lambda, nrow=nrow, ncol=ncol, ans=ans) END PROCEDURE LagrangeEvalAll_Triangle2 !---------------------------------------------------------------------------- @@ -313,8 +348,9 @@ IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff, nrow=aint, ncol=bint) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff, nrow=aint, ncol=bint) END IF @@ -322,8 +358,9 @@ ELSE - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff0, nrow=aint, ncol=bint) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff0, nrow=aint, ncol=bint) END IF @@ -340,8 +377,9 @@ CASE (polyopt%Hierarchical) - CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=x, refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint) + CALL HeirarchicalBasis_Triangle_( & + order=order, pe1=order, pe2=order, pe3=order, xij=x, & + refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint) CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, & polyopt%Ultraspherical) @@ -360,12 +398,10 @@ MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1 INTEGER(I4B) :: dim1, dim2, dim3 - -CALL LagrangeGradientEvalAll_Triangle1_(order=order, x=x, xij=xij, ans=ans, & - dim1=dim1, dim2=dim2, dim3=dim3, refTriangle=refTriangle, coeff=coeff, & - firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, & - lambda=lambda) - +CALL LagrangeGradientEvalAll_Triangle1_( & + order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + refTriangle=refTriangle, coeff=coeff, firstCall=firstCall, & + basisType=basisType, alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE LagrangeGradientEvalAll_Triangle1 !---------------------------------------------------------------------------- @@ -388,15 +424,17 @@ IF (PRESENT(coeff)) THEN IF (firstCall0) THEN - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff, nrow=s(1), ncol=s(2)) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff, nrow=s(1), ncol=s(2)) END IF coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2) ELSE - CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, & - refTriangle=refTriangle, ans=coeff0, nrow=s(1), ncol=s(2)) + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, & + ans=coeff0, nrow=s(1), ncol=s(2)) END IF SELECT CASE (basisType0) @@ -418,15 +456,16 @@ CASE (polyopt%Hierarchical) - CALL HeirarchicalBasisGradient_Triangle_(order=order, pe1=order, pe2=order, & - pe3=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), & - tsize2=s(2), tsize3=s(3)) + CALL HeirarchicalBasisGradient_Triangle_( & + order=order, pe1=order, pe2=order, pe3=order, xij=x, & + refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3)) CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, & polyopt%Ultraspherical) - CALL OrthogonalBasisGradient_Triangle_(order=order, xij=x, & - refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3)) + CALL OrthogonalBasisGradient_Triangle_( & + order=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), & + tsize2=s(2), tsize3=s(3)) END SELECT @@ -437,6 +476,51 @@ END PROCEDURE LagrangeGradientEvalAll_Triangle1_ +!---------------------------------------------------------------------------- +! LagrangeEvalAll_Triangle_ +!---------------------------------------------------------------------------- + +MODULE PROCEDURE LagrangeEvalAll_Triangle3_ +INTEGER(I4B) :: ii, tdof, aint, bint + +nrow = SIZE(x, 2) +ncol = SIZE(xij, 2) + +IF (firstCall) THEN + CALL LagrangeCoeff_Triangle_( & + order=order, xij=xij, basisType=basisType, refTriangle=refTriangle, & + ans=coeff, nrow=aint, ncol=bint) +END IF + +SELECT CASE (basisType) + +CASE (polyopt%Monomial) + + CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=aint, & + ncol=bint) + tdof = SIZE(xij, 2) + + DO ii = 1, tdof + xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2) + END DO + +CASE (polyopt%Hierarchical) + + CALL HeirarchicalBasis_Triangle_( & + order=order, pe1=order, pe2=order, pe3=order, xij=x, & + refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint) + +CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, & + polyopt%Lobatto, polyopt%Ultraspherical) + + CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, & + ans=xx, nrow=aint, ncol=bint) + +END SELECT + +CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff) +END PROCEDURE LagrangeEvalAll_Triangle3_ + !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 similarity index 76% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 index 1589a40e1..e5119a32b 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 @@ -16,27 +16,18 @@ SUBMODULE(TriangleInterpolationUtility) Methods USE BaseType, ONLY: ipopt => TypeInterpolationOpt - USE StringUtility, ONLY: UpperCase - -USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line, & - EquidistanceInPoint_Line_, & - LagrangeInDOF_Line, & - InterpolationPoint_Line_ - USE MappingUtility, ONLY: FromUnitTriangle2Triangle_ - -USE ErrorHandling, ONLY: Errormsg - USE RecursiveNodesUtility, ONLY: RecursiveNode2D_ - -USE IntegerUtility, ONLY: Size - USE Display_Method, ONLY: ToString - -USE GlobalData, ONLY: stderr +USE IntegerUtility, ONLY: NumberOfTuples => SIZE +USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line_, & + InterpolationPoint_Line_ IMPLICIT NONE + +CHARACTER(*), PARAMETER :: modName = "TriangleInterpolationUtility%Methods" + CONTAINS !---------------------------------------------------------------------------- @@ -60,11 +51,15 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE RefElemDomain_Triangle +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "RefElemDomain_Triangle()" +#endif + CHARACTER(2) :: bc -CHARACTER(3) :: bi +CHARACTER(1) :: bi bc = UpperCase(baseContinuity(1:2)) -bi = UpperCase(baseInterpol(1:3)) +bi = UpperCase(baseInterpol(1:1)) SELECT CASE (bc) @@ -72,31 +67,31 @@ SELECT CASE (bi) - !! Lagrange - CASE ("LAG", "SER", "HER") + !! Lagrange ! Serendipity + CASE ("L", "S") ans = "UNIT" - CASE ("HIE", "HEI") + !! Hierarchical + CASE ("H") ans = "BIUNIT" - CASE ("ORT") + !! Orthognal + CASE ("O") ans = "BIUNIT" +#ifdef DEBUG_VER CASE DEFAULT - - CALL Errormsg( & - msg="No case found for given baseInterpol="//TRIM(baseInterpol), & - routine="RefElemDomain_Triangle()", file=__FILE__, line=__LINE__, & - unitno=stderr) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "No case found for given baseInterpol="//TRIM(baseInterpol)) +#endif END SELECT +#ifdef DEBUG_VER CASE DEFAULT - - CALL Errormsg( & - msg="No case found for given baseContinuity="//TRIM(baseContinuity), & - file=__FILE__, line=__LINE__, routine="RefElemDomain_Triangle()", & - unitno=stderr) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "No case found for given baseContinuity="//TRIM(baseContinuity)) +#endif END SELECT @@ -107,22 +102,29 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE FacetConnectivity_Triangle -CHARACTER(3) :: bi - -bi = UpperCase(baseInterpol(1:3)) +! CHARACTER(1) :: bi +! LOGICAL(LGT) :: isok -SELECT CASE (bi) -CASE ("HIE", "HEI", "ORT") - ans(:, 1) = [1, 2] - ans(:, 2) = [1, 3] - ans(:, 3) = [2, 3] +ans(1:2, 1) = [1, 2] +ans(1:2, 2) = [2, 3] +ans(1:2, 3) = [3, 1] -CASE DEFAULT - ans(:, 1) = [1, 2] - ans(:, 2) = [2, 3] - ans(:, 3) = [3, 1] - -END SELECT +! isok = PRESENT(baseInterpol) +! bi = "L" +! IF (isok) bi = UpperCase(baseInterpol(1:1)) +! +! SELECT CASE (bi) +! CASE ("H", "O") +! ans(1:2, 1) = [1, 2] +! ans(1:2, 2) = [1, 3] +! ans(1:2, 3) = [2, 3] +! +! CASE DEFAULT +! ans(1:2, 1) = [1, 2] +! ans(1:2, 2) = [2, 3] +! ans(1:2, 3) = [3, 1] +! +! END SELECT END PROCEDURE FacetConnectivity_Triangle !---------------------------------------------------------------------------- @@ -131,19 +133,17 @@ MODULE PROCEDURE EquidistancePoint_Triangle INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2_I4B -END IF +nrow = 2 +isok = PRESENT(xij) +IF (isok) nrow = SIZE(xij, 1) ncol = LagrangeDOF_Triangle(order=order) ALLOCATE (ans(nrow, ncol)) CALL EquidistancePoint_Triangle_(order=order, xij=xij, ans=ans, nrow=nrow, & ncol=ncol) - END PROCEDURE EquidistancePoint_Triangle !---------------------------------------------------------------------------- @@ -153,10 +153,13 @@ MODULE PROCEDURE EquidistancePoint_Triangle_ INTEGER(I4B) :: i1, i2, aint, bint REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu +LOGICAL(LGT) :: isok x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) + +IF (isok) THEN nrow = SIZE(xij, 1) x(1:nrow, 1:3) = xij(1:nrow, 1:3) ELSE @@ -167,47 +170,35 @@ END IF ncol = LagrangeDOF_Triangle(order=order) -! ALLOCATE (ans(nrow, n)) -! ans = 0.0_DFP !! points on vertex ans(1:nrow, 1:3) = x(1:nrow, 1:3) !! points on edge -! ne = LagrangeInDOF_Line(order=order) i2 = 3 -IF (order .GT. 1_I4B) THEN +isok = order .GT. 1_I4B +IF (isok) THEN i1 = i2 + 1 ! i1 = i2 + 1; i2 = i1 + ne - 1 - ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & - ! order=order, & - ! xij=x(1:nrow, [1, 2])) CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [1, 2]), & ans=ans(:, i1:), nrow=aint, ncol=bint) i1 = i1 + bint - ! i1 = i2 + 1; i2 = i1 + ne - 1 - ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & - ! order=order, & - ! xij=x(1:nrow, [2, 3])) CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [2, 3]), & ans=ans(:, i1:), nrow=aint, ncol=bint) i1 = i1 + bint - ! i1 = i2 + 1; i2 = i1 + ne - 1 - ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( & - ! order=order, & - ! xij=x(1:nrow, [3, 1])) CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [3, 1]), & ans=ans(:, i1:), nrow=aint, ncol=bint) i2 = i1 + bint - 1 - END IF -IF (order .LE. 2_I4B) RETURN +isok = order .LE. 2_I4B +IF (isok) RETURN !! points on face -IF (order .EQ. 3_I4B) THEN +isok = order .EQ. 3_I4B +IF (isok) THEN i1 = i2 + 1 ans(1:nrow, i1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP RETURN @@ -244,11 +235,8 @@ xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow) i1 = i2 + 1 -! ans(1:nrow, i1:) = EquidistancePoint_Triangle(order=order - 3, & -! xij=xin(1:nrow, 1:3)) CALL EquidistancePoint_Triangle_(order=order - 3, xij=xin(1:nrow, 1:3), & ans=ans(1:nrow, i1:), nrow=aint, ncol=bint) - END PROCEDURE EquidistancePoint_Triangle_ !---------------------------------------------------------------------------- @@ -257,23 +245,20 @@ MODULE PROCEDURE EquidistanceInPoint_Triangle INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (order .LT. 3_I4B) THEN +isok = order .LT. 3_I4B +IF (isok) THEN ALLOCATE (ans(0, 0)) RETURN END IF -IF (PRESENT(xij)) THEN - nrow = SIZE(xij, 1) -ELSE - nrow = 2_I4B -END IF - +isok = PRESENT(xij) +nrow = 2_I4B; IF (isok) nrow = SIZE(xij, 1) ncol = LagrangeInDOF_Triangle(order=order) CALL EquidistanceInPoint_Triangle_(order=order, ans=ans, nrow=nrow, & ncol=ncol) - END PROCEDURE EquidistanceInPoint_Triangle !---------------------------------------------------------------------------- @@ -283,28 +268,30 @@ MODULE PROCEDURE EquidistanceInPoint_Triangle_ REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu INTEGER(I4B) :: aint, bint +LOGICAL(LGT) :: isok nrow = 0; ncol = 0 -IF (order .LT. 3_I4B) RETURN + +isok = order .LT. 3_I4B +IF (isok) RETURN x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP -IF (PRESENT(xij)) THEN +isok = PRESENT(xij) +nrow = 2_I4B +x(1:nrow, 1) = [0.0, 0.0] +x(1:nrow, 2) = [1.0, 0.0] +x(1:nrow, 3) = [0.0, 1.0] +IF (isok) THEN nrow = SIZE(xij, 1) x(1:nrow, 1:3) = xij(1:nrow, 1:3) -ELSE - nrow = 2_I4B - x(1:nrow, 1) = [0.0, 0.0] - x(1:nrow, 2) = [1.0, 0.0] - x(1:nrow, 3) = [0.0, 1.0] END IF ncol = LagrangeInDOF_Triangle(order=order) -! ALLOCATE (ans(nrow, n)) -! ans = 0.0_DFP !! points on face -IF (order .EQ. 3_I4B) THEN +isok = order .EQ. 3_I4B +IF (isok) THEN ans(1:nrow, 1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP RETURN END IF @@ -350,11 +337,15 @@ MODULE PROCEDURE BlythPozrikidis_Triangle INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok + +isok = PRESENT(xij) ncol = LagrangeDOF_Triangle(order=order) -nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) +nrow = 2; IF (isok) nrow = SIZE(xij, 1) ALLOCATE (ans(nrow, ncol)) -CALL BlythPozrikidis_Triangle_(order=order, ipType=ipType, ans=ans,nrow=nrow,& - ncol=ncol, layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda) +CALL BlythPozrikidis_Triangle_( & + order=order, ipType=ipType, ans=ans, nrow=nrow, ncol=ncol, layout=layout, & + xij=xij, alpha=alpha, beta=beta, lambda=lambda) END PROCEDURE BlythPozrikidis_Triangle !---------------------------------------------------------------------------- @@ -362,8 +353,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE BlythPozrikidis_Triangle_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle_()" +#endif + INTEGER(I4B), PARAMETER :: max_order = 30 -CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle()" REAL(DFP), PARAMETER :: x(2) = [0.0_DFP, 1.0_DFP] REAL(DFP) :: v(max_order + 1), xi(max_order + 1, max_order + 1), & @@ -401,17 +395,19 @@ CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol) IF (isx) THEN - CALL FromUnitTriangle2Triangle_(xin=temp(1:2, 1:ncol), x1=xij(:, 1), & - x2=xij(:, 2), x3=xij(:, 3), ans=ans, nrow=nrow, ncol=ncol) + CALL FromUnitTriangle2Triangle_( & + xin=temp(1:2, 1:ncol), x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), & + ans=ans, nrow=nrow, ncol=ncol) RETURN END IF ans(1:2, 1:ncol) = temp(1:2, 1:ncol) +#ifdef DEBUG_VER CASE DEFAULT - - CALL ErrorMsg(msg="layout=VEFC is allowed, found layout is "//TRIM(layout), & - file=__FILE__, routine=myname, line=__LINE__, unitno=stderr) + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "layout=VEFC is allowed, found layout is "//TRIM(layout)) +#endif END SELECT @@ -424,7 +420,7 @@ MODULE PROCEDURE Isaac_Triangle INTEGER(I4B) :: nrow, ncol -ncol = SIZE(n=order, d=2) +ncol = NumberOfTuples(n=order, d=2) nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1) ALLOCATE (ans(nrow, ncol)) @@ -440,8 +436,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE Isaac_Triangle_ +#ifdef DEBUG_VER CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle()" +#endif + INTEGER(I4B), PARAMETER :: max_order = 30 +LOGICAL(LGT) :: isok REAL(DFP) :: xi(max_order + 1, max_order + 1), & eta(max_order + 1, max_order + 1), & temp(2, 512) @@ -456,7 +456,8 @@ alpha=alpha, beta=beta, lambda=lambda, ans=temp, & nrow=nrow, ncol=ncol) -IF (PRESENT(xij)) nrow = SIZE(xij, 1) +isok = PRESENT(xij) +IF (isok) nrow = SIZE(xij, 1) !! convert from rPoints to xi and eta cnt = 0 @@ -471,13 +472,14 @@ END DO END DO -IF (layout .EQ. "VEFC") THEN - ! CALL Reallocate(temp, 2, N) +isok = layout .EQ. "VEFC" +IF (isok) THEN CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol) IF (PRESENT(xij)) THEN - CALL FromUnitTriangle2Triangle_(xin=temp(:, 1:ncol), ans=ans, & - nrow=nrow, ncol=ncol, x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3)) + CALL FromUnitTriangle2Triangle_( & + xin=temp(:, 1:ncol), ans=ans, nrow=nrow, ncol=ncol, x1=xij(:, 1), & + x2=xij(:, 2), x3=xij(:, 3)) RETURN END IF @@ -485,9 +487,10 @@ RETURN END IF -CALL ErrorMsg(file=__FILE__, routine=myname, line=__LINE__, unitno=stderr, & - msg="Only layout=VEFC is allowed, found layout is "//layout) - +#ifdef DEBUG_VER +CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "Only layout=VEFC is allowed, found layout is "//layout) +#endif END PROCEDURE Isaac_Triangle_ !---------------------------------------------------------------------------- @@ -495,6 +498,11 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE IJ2VEFC_Triangle +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "IJ2VEFC_Triangle()" +#endif + +LOGICAL(LGT) :: isok INTEGER(I4B) :: cnt, m, ii, jj, ll, llt, llr cnt = 0 @@ -541,7 +549,8 @@ !! internal nodes END DO -IF (llr .EQ. 2_I4B) THEN +isok = llr .EQ. 2_I4B +IF (isok) THEN !! a internal point cnt = cnt + 1 ll = llt + 1 @@ -550,13 +559,12 @@ temp(2, cnt) = eta(ii, jj) END IF -IF (cnt .NE. N) THEN - CALL ErrorMsg(file=__FILE__, routine="IJ2VEFC_Triangle()", & - line=__LINE__, unitno=stderr, & - msg="cnt="//ToString(cnt)//" not equal to total DOF, N=" & - //ToString(N)) - RETURN -END IF +#ifdef DEBUG_VER +isok = cnt .EQ. N +CALL AssertError1(isok, myName, modName, __LINE__, & + "cnt="//ToString(cnt)//" not equal to total DOF, N="// & + ToString(N)) +#endif END PROCEDURE IJ2VEFC_Triangle @@ -579,7 +587,7 @@ CASE (ipopt%IsaacLegendre, ipopt%IsaacChebyshev, & ipopt%GaussLegendreLobatto, ipopt%GaussChebyshevLobatto) - ncol = SIZE(n=order, d=2) + ncol = NumberOfTuples(n=order, d=2) END SELECT @@ -596,7 +604,9 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE InterpolationPoint_Triangle_ +#ifdef DEBUG_VER CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle_()" +#endif SELECT CASE (ipType) CASE (ipopt%Equidistance) @@ -604,30 +614,35 @@ nrow=nrow, ncol=ncol) CASE (ipopt%BlythPozLegendre) - CALL BlythPozrikidis_Triangle_(order=order, ans=ans, nrow=nrow, ncol=ncol, & - ipType=ipopt%GaussLegendreLobatto, layout="VEFC", xij=xij, & - alpha=alpha, beta=beta, lambda=lambda) + CALL BlythPozrikidis_Triangle_( & + order=order, ans=ans, nrow=nrow, ncol=ncol, & + ipType=ipopt%GaussLegendreLobatto, layout="VEFC", xij=xij, & + alpha=alpha, beta=beta, lambda=lambda) CASE (ipopt%BlythPozChebyshev) - CALL BlythPozrikidis_Triangle_(order=order, & - ipType=ipopt%GaussChebyshevLobatto, & - layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & - ans=ans, nrow=nrow, ncol=ncol) + CALL BlythPozrikidis_Triangle_( & + order=order, ipType=ipopt%GaussChebyshevLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) CASE (ipopt%IsaacLegendre, ipopt%GaussLegendreLobatto) - CALL Isaac_Triangle_(order=order, & - ipType=ipopt%GaussLegendreLobatto, & - layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & - ans=ans, nrow=nrow, ncol=ncol) + CALL Isaac_Triangle_( & + order=order, ipType=ipopt%GaussLegendreLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) CASE (ipopt%IsaacChebyshev, ipopt%GaussChebyshevLobatto) - CALL Isaac_Triangle_(order=order, ipType=ipopt%GaussChebyshevLobatto, & - layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & - ans=ans, nrow=nrow, ncol=ncol) + CALL Isaac_Triangle_( & + order=order, ipType=ipopt%GaussChebyshevLobatto, & + layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, & + ans=ans, nrow=nrow, ncol=ncol) CASE (ipopt%Feket, ipopt%Hesthaven, ipopt%ChenBabuska) - CALL ErrorMsg(msg="Feket, Hesthaven, ChenBabuska nodes not available", & - file=__FILE__, routine=myname, line=__LINE__, unitno=stderr) + +#ifdef DEBUG_VER + CALL AssertError1(.FALSE., myName, modName, __LINE__, & + "Feket, Hesthaven, ChenBabuska nodes not available") +#endif CASE DEFAULT CALL Isaac_Triangle_(order=order, ipType=ipType, layout="VEFC", & @@ -641,4 +656,6 @@ ! !---------------------------------------------------------------------------- +#include "../../include/errors.F90" + END SUBMODULE Methods diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 similarity index 100% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 similarity index 69% rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 rename to src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 index 0badc8787..42816de22 100644 --- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 +++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 @@ -15,11 +15,24 @@ ! along with this program. If not, see SUBMODULE(TriangleInterpolationUtility) QuadratureMethods -USE BaseMethod -USE QuadraturePoint_Triangle_Solin, ONLY: QuadraturePointTriangleSolin, & +USE Triangle_QuadraturePoint_Solin, ONLY: QuadraturePointTriangleSolin, & QuadraturePointTriangleSolin_, & QuadratureNumberTriangleSolin +USE BaseType, ONLY: TypeQuadratureOpt +USE StringUtility, ONLY: UpperCase +USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_ +USE MappingUtility, ONLY: FromSquare2Triangle_, & + FromUnitTriangle2Triangle_, & + JacobianTriangle, & + FromTriangle2Triangle_ + IMPLICIT NONE + +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: modName = & + "TriangleInterpolationUtility@QuadratureMethods" +#endif + CONTAINS !---------------------------------------------------------------------------- @@ -27,9 +40,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadratureNumber_Triangle +LOGICAL(LGT) :: isok + ans = QuadratureNumberTriangleSolin(order=order) -IF (ans .LE. 0) THEN +isok = ans .LE. 0 +IF (isok) THEN ans = 1_I4B + INT(order / 2, kind=I4B) ans = ans * (ans + 1) END IF @@ -41,25 +57,24 @@ MODULE PROCEDURE TensorQuadraturePoint_Triangle1 INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol +LOGICAL(LGT) :: isok nrow = 1_I4B + INT(order / 2, kind=I4B) nipsx(1) = nrow + 1 nipsy(1) = nrow -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2_I4B) -ELSE - nrow = 2_I4B -END IF +nrow = 2_I4B +isok = PRESENT(xij) +IF (isok) nrow = MAX(SIZE(xij, 1), 2_I4B) nrow = nrow + 1_I4B ncol = nipsx(1) * nipsy(1) ALLOCATE (ans(nrow, ncol)) -CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, & - quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) +CALL TensorQuadraturePoint_Triangle2_( & + nipsx=nipsx, nipsy=nipsy, quadType=quadType, refTriangle=refTriangle, & + xij=xij, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle1 !---------------------------------------------------------------------------- @@ -73,9 +88,9 @@ nipsx(1) = n + 1 nipsy(1) = n -CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, & - quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, & - nrow=nrow, ncol=ncol) +CALL TensorQuadraturePoint_Triangle2_( & + nipsx=nipsx, nipsy=nipsy, quadType=quadType, refTriangle=refTriangle, & + xij=xij, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle1_ !---------------------------------------------------------------------------- @@ -84,21 +99,20 @@ MODULE PROCEDURE TensorQuadraturePoint_Triangle2 INTEGER(I4B) :: nrow, ncol +LOGICAL(LGT) :: isok -IF (PRESENT(xij)) THEN - nrow = MAX(SIZE(xij, 1), 2_I4B) -ELSE - nrow = 2_I4B -END IF +nrow = 2_I4B +isok = PRESENT(xij) +IF (isok) nrow = MAX(SIZE(xij, 1), 2_I4B) nrow = nrow + 1_I4B ncol = nipsx(1) * nipsy(1) ALLOCATE (ans(nrow, ncol)) -CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, & - quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, & - ncol=ncol) +CALL TensorQuadraturePoint_Triangle2_( & + nipsx=nipsx, nipsy=nipsy, quadType=quadType, refTriangle=refTriangle, & + xij=xij, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE TensorQuadraturePoint_Triangle2 !---------------------------------------------------------------------------- @@ -110,24 +124,22 @@ REAL(DFP), ALLOCATABLE :: temp(:, :) REAL(DFP) :: areal REAL(DFP), PARAMETER :: oneby8 = 1.0_DFP / 8.0_DFP - +LOGICAL(LGT) :: isok CHARACTER(1) :: astr -IF (PRESENT(xij)) THEN - nsd = MAX(SIZE(xij, 1), 2_I4B) -ELSE - nsd = 2_I4B -END IF +nsd = 2_I4B +isok = PRESENT(xij) +IF (isok) nsd = MAX(SIZE(xij, 1), 2_I4B) nrow = nsd + 1_I4B ncol = nipsx(1) * nipsy(1) -! ALLOCATE (temp(nrow, ncol)) - -CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, & - quadType1=GaussLegendreLobatto, quadType2=GaussJacobiRadauLeft, & - refQuadrangle="BIUNIT", alpha2=1.0_DFP, beta2=0.0_DFP, ans=ans, & - nrow=ii, ncol=jj) +CALL QuadraturePoint_Quadrangle_( & + nipsx=nipsx, nipsy=nipsy, & + quadType1=TypeQuadratureOpt%GaussLegendreLobatto, & + quadType2=TypeQuadratureOpt%GaussJacobiRadauLeft, & + refQuadrangle="BIUNIT", alpha2=1.0_DFP, beta2=0.0_DFP, & + ans=ans, nrow=ii, ncol=jj) ! temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :)) CALL FromSquare2Triangle_(xin=ans(1:2, :), ans=ans, nrow=ii, ncol=jj, & @@ -138,8 +150,9 @@ END DO IF (PRESENT(xij)) THEN - CALL FromUnitTriangle2Triangle_(xin=ans(1:2, :), x1=xij(:, 1), & - x2=xij(:, 2), x3=xij(:, 3), ans=ans, nrow=ii, ncol=jj) + CALL FromUnitTriangle2Triangle_( & + xin=ans(1:2, :), x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), ans=ans, & + nrow=ii, ncol=jj) areal = JacobianTriangle(from="UNIT", to="TRIANGLE", xij=xij) @@ -163,9 +176,7 @@ END DO RETURN - END IF - END PROCEDURE TensorQuadraturePoint_Triangle2_ !---------------------------------------------------------------------------- @@ -185,8 +196,9 @@ ALLOCATE (ans(nrow, ncol)) -CALL QuadraturePoint_Triangle1_(order=order, quadType=quadType, & - refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) +CALL QuadraturePoint_Triangle1_( & + order=order, quadType=quadType, refTriangle=refTriangle, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Triangle1 !---------------------------------------------------------------------------- @@ -199,19 +211,19 @@ nips(1) = QuadratureNumberTriangleSolin(order=order) IF (nips(1) .LE. 0) THEN - CALL TensorQuadraturepoint_Triangle_(order=order, quadtype=quadtype, & - reftriangle=reftriangle, xij=xij, & - ans=ans, nrow=nrow, ncol=ncol) + CALL TensorQuadraturepoint_Triangle_( & + order=order, quadtype=quadtype, reftriangle=reftriangle, xij=xij, & + ans=ans, nrow=nrow, ncol=ncol) RETURN END IF -CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, & - refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) - +CALL QuadraturePoint_Triangle2_( & + nips=nips, quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Triangle1_ !---------------------------------------------------------------------------- -! QuadraturePoint_Triangle2 +! QuadraturePoint_Triangle2 !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Triangle2 @@ -227,9 +239,9 @@ ALLOCATE (ans(nrow, ncol)) -CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, & - refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol) - +CALL QuadraturePoint_Triangle2_( & + nips=nips, quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, & + nrow=nrow, ncol=ncol) END PROCEDURE QuadraturePoint_Triangle2 !---------------------------------------------------------------------------- @@ -237,8 +249,12 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE QuadraturePoint_Triangle2_ +#ifdef DEBUG_VER +CHARACTER(*), PARAMETER :: myName = "QuadraturePoint_Triangle2_()" +#endif + INTEGER(I4B) :: nsd, ii, jj -LOGICAL(LGT) :: abool +LOGICAL(LGT) :: isok REAL(DFP) :: areal CHARACTER(1) :: astr @@ -246,25 +262,24 @@ ncol = 0 ii = QuadratureNumberTriangleSolin(order=20) -abool = nips(1) .GT. ii -IF (abool) THEN - CALL Errormsg(msg="This routine should be called for economical & - & quadrature points only, otherwise call QuadraturePoint_Triangle1()", & - routine="QuadraturePoint_Triangle2()", & - file=__FILE__, line=__LINE__, unitNo=stdout) - RETURN -END IF + +#ifdef DEBUG_VER +isok = nips(1) .LE. ii +CALL AssertError1(isok, myName, modName, __LINE__, & + "This routine should be called for economical quadrature points only,& + &otherwise call QuadraturePoint_Triangle1()") +#endif nsd = 2_I4B -abool = PRESENT(xij) -IF (abool) nsd = SIZE(xij, 1) +isok = PRESENT(xij) +IF (isok) nsd = SIZE(xij, 1) nrow = nsd + 1 ncol = nips(1) CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=ii, ncol=jj) -IF (abool) THEN +IF (isok) THEN CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), x1=xij(1:nsd, 1), & x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans, & from="U", to="T", nrow=ii, ncol=jj) @@ -280,9 +295,9 @@ END IF astr = UpperCase(reftriangle(1:1)) -abool = astr == "B" +isok = astr == "B" -IF (abool) THEN +IF (isok) THEN CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), ans=ans, & from="U", to="B", nrow=ii, ncol=jj) @@ -294,11 +309,12 @@ RETURN END IF - END PROCEDURE QuadraturePoint_Triangle2_ !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- +#include "../../include/errors.F90" + END SUBMODULE QuadratureMethods diff --git a/src/submodules/Geometry/src/Triangle_Method@Methods.F90 b/src/submodules/Triangle/src/Triangle_Method@Methods.F90 similarity index 86% rename from src/submodules/Geometry/src/Triangle_Method@Methods.F90 rename to src/submodules/Triangle/src/Triangle_Method@Methods.F90 index 70337ee7d..33140c4e0 100644 --- a/src/submodules/Geometry/src/Triangle_Method@Methods.F90 +++ b/src/submodules/Triangle/src/Triangle_Method@Methods.F90 @@ -16,7 +16,22 @@ ! SUBMODULE(Triangle_Method) Methods -USE BaseMethod +! USE BaseMethod +USE SwapUtility, ONLY: Swap +USE MiscUtility, ONLY: safe_ACOS +USE Line_Method, ONLY: line_exp_is_degenerate_nd, & + line_exp2imp_2d, & + lines_imp_int_2d, & + line_exp_perp_2d, & + lines_exp_int_2d, & + segment_point_dist_2d, & + segment_point_dist_3d, & + line_exp_point_dist_signed_2d, & + segment_point_near_2d + +USE Plane_Method, ONLY: plane_normal_line_exp_int_3d + +USE Random_Method, ONLY: rvec_uniform_01 IMPLICIT NONE CONTAINS @@ -524,7 +539,7 @@ ! Find the intersection of the plane and the line. ! CALL plane_normal_line_exp_int_3d(t(1:dim_num, 1), normal, p1, p2, & - & ival, pint) + ival, pint) ! IF (ival == 0) THEN inside = .FALSE. @@ -1303,7 +1318,7 @@ DO j = 1, side_num jp1 = i4_wrap(j + 1, 1, side_num) CALL segment_point_near_2d(t(1:dim_num, j), t(1:dim_num, jp1), p, & - & pn2, dist2, tval) + pn2, dist2, tval) IF (dist2 < dist) THEN dist = dist2 pn(1:dim_num) = pn2(1:dim_num) @@ -1426,7 +1441,224 @@ ! !---------------------------------------------------------------------------- -#include "./inc/aux.inc" +!> author: Vikas Sharma, Ph. D. +! date: 28 Aug 2022 +! summary: r8mat solve +! +!# Introduction +! +! Input, integer ( kind = 4 ) N, the order of the matrix. +! +! Input, integer ( kind = 4 ) RHS_NUM, the number of right hand sides. +! RHS_NUM must be at least 0. +! +! Input/output, real ( kind = 8 ) A(N,N+rhs_num), contains in rows and +! columns 1 to N the coefficient matrix, and in columns N+1 through +! N+rhs_num, the right hand sides. On output, the coefficient matrix +! area has been destroyed, while the right hand sides have +! been overwritten with the corresponding solutions. +! +! Output, integer ( kind = 4 ) INFO, singularity flag. +! 0, the matrix was not singular, the solutions were computed; +! J, factorization failed on step J, and the solutions could not +! be computed. + +PURE SUBROUTINE r8mat_solve(n, rhs_num, a, info) + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(IN) :: rhs_num + REAL(DFP), INTENT(INOUT) :: a(n, n + rhs_num) + INTEGER(I4B), INTENT(OUT) :: info + !! + REAL(DFP) :: apivot + REAL(DFP) :: factor + INTEGER(I4B) :: i + INTEGER(I4B) :: ipivot + INTEGER(I4B) :: j + !! + info = 0 + !! + DO j = 1, n + ! + ! Choose a pivot row. + ! + ipivot = j + apivot = a(j, j) + ! + DO i = j + 1, n + IF (ABS(apivot) < ABS(a(i, j))) THEN + apivot = a(i, j) + ipivot = i + END IF + END DO + ! + IF (apivot == 0.0D+00) THEN + info = j + RETURN + END IF + ! + ! Interchange. + ! + DO i = 1, n + rhs_num + CALL swap(a(ipivot, i), a(j, i)) + END DO + ! + ! A(J,J) becomes 1. + ! + a(j, j) = 1.0D+00 + a(j, j + 1:n + rhs_num) = a(j, j + 1:n + rhs_num) / apivot + ! + ! A(I,J) becomes 0. + ! + DO i = 1, n + IF (i /= j) THEN + factor = a(i, j) + a(i, j) = 0.0D+00 + a(i,j+1:n+rhs_num) = a(i,j+1:n+rhs_num) - factor * a(j,j+1:n+rhs_num) + END IF + END DO + END DO +END SUBROUTINE r8mat_solve + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION r8vec_normsq_affine(n, v0, v1) RESULT(ans) + INTEGER(i4b), INTENT(in) :: n + REAL(dfp), INTENT(in) :: v0(n) + REAL(dfp), INTENT(in) :: v1(n) + REAL(dfp) :: ans + ans = SUM((v0(1:n) - v1(1:n))**2) +END FUNCTION r8vec_normsq_affine + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_wrap(ival, ilo, ihi) RESULT(ans) + INTEGER(i4b), INTENT(in) :: ival + INTEGER(i4b), INTENT(in) :: ilo + INTEGER(i4b), INTENT(in) :: ihi + INTEGER(i4b) :: ans + !! + INTEGER(i4b) :: jhi + INTEGER(i4b) :: jlo + INTEGER(i4b) :: wide + !! + jlo = MIN(ilo, ihi) + jhi = MAX(ilo, ihi) + !! + wide = jhi - jlo + 1 + !! + IF (wide == 1) THEN + ans = jlo + ELSE + ans = jlo + i4_modp(ival - jlo, wide) + END IF + !! +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_modp(i, j) RESULT(ans) + INTEGER(i4b), INTENT(IN) :: i + INTEGER(i4b), INTENT(IN) :: j + INTEGER(i4b) :: ans + IF (j == 0) THEN + RETURN + END IF + ans = MOD(i, j) + IF (ans < 0) THEN + ans = ans + ABS(j) + END IF +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4vec_lcm(n, v) + INTEGER(i4b), INTENT(in) :: n + INTEGER(i4b), INTENT(in) :: v(n) + INTEGER(i4b) :: i4vec_lcm + INTEGER(i4b) :: i + INTEGER(i4b) :: lcm + ! + lcm = 1 + DO i = 1, n + IF (v(i) == 0) THEN + lcm = 0 + i4vec_lcm = lcm + RETURN + END IF + lcm = i4_lcm(lcm, v(i)) + END DO + i4vec_lcm = lcm +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_lcm(i, j) + INTEGER(i4b), INTENT(in) :: i, j + INTEGER(I4B) :: i4_lcm + i4_lcm = ABS(i * (j / i4_gcd(i, j))) +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION i4_gcd(i, j) + INTEGER(I4B), INTENT(IN) :: i, j + INTEGER(I4B) :: i4_gcd + !! + INTEGER(kind=4) p + INTEGER(kind=4) q + INTEGER(kind=4) r + ! + i4_gcd = 1 + ! + ! Return immediately if either I or J is zero. + ! + IF (i == 0) THEN + i4_gcd = MAX(1, ABS(j)) + RETURN + ELSE IF (j == 0) THEN + i4_gcd = MAX(1, ABS(i)) + RETURN + END IF + ! + ! Set P to the larger of I and J, Q to the smaller. + ! This way, we can alter P and Q as we go. + ! + p = MAX(ABS(i), ABS(j)) + q = MIN(ABS(i), ABS(j)) + ! + ! Carry out the Euclidean algorithm. + ! + DO + r = MOD(p, q) + IF (r == 0) THEN + EXIT + END IF + p = q + q = r + END DO + i4_gcd = q +END FUNCTION + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +PURE FUNCTION r8_huge() + REAL(dfp) :: r8_huge + r8_huge = 1.0D+30 +END FUNCTION !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 b/src/submodules/Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90 similarity index 99% rename from src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 rename to src/submodules/Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90 index 58f5d1310..554e2550c 100644 --- a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 +++ b/src/submodules/Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90 @@ -71,7 +71,7 @@ ! ISBN: 0750663200, ! LC: TA640.2.Z54 -module QuadraturePoint_Triangle_InternalUseOnly +module Triangle_QuadraturePoint_InternalUseOnly USE GlobalData, only: DFP implicit none private @@ -472,6 +472,4 @@ module QuadraturePoint_Triangle_InternalUseOnly !!TOMS706_37, order 37, degree of precision 13, a rule from ACM TOMS algorithm 706. - - -end module QuadraturePoint_Triangle_InternalUseOnly +end module Triangle_QuadraturePoint_InternalUseOnly diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 b/src/submodules/Triangle/src/Triangle_QuadraturePoint_Solin.F90 similarity index 99% rename from src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 rename to src/submodules/Triangle/src/Triangle_QuadraturePoint_Solin.F90 index 9e154630b..b865dd970 100644 --- a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 +++ b/src/submodules/Triangle/src/Triangle_QuadraturePoint_Solin.F90 @@ -19,9 +19,10 @@ ! https://gitlab.onelab.info/gmsh/gmsh/-/blame/master/src/numeric/GaussQuadratureTri.cpp#L28 ! 'Higher-order Finite Elements', P.Solin, K.Segeth and I. Dolezel */ -module QuadraturePoint_Triangle_Solin +module Triangle_QuadraturePoint_Solin USE GlobalData, only: DFP, I4B -implicit none +implicit none + private public :: QuadratureNumberTriangleSolin public :: QuadraturePointTriangleSolin @@ -2167,4 +2168,4 @@ pure subroutine QuadraturePointTriangleSolin_(nips, ans, nrow, ncol) end select end subroutine QuadraturePointTriangleSolin_ -END MODULE QuadraturePoint_Triangle_Solin +END MODULE Triangle_QuadraturePoint_Solin diff --git a/src/submodules/Utility/CMakeLists.txt b/src/submodules/Utility/CMakeLists.txt index c67eb1a0d..0140713b6 100644 --- a/src/submodules/Utility/CMakeLists.txt +++ b/src/submodules/Utility/CMakeLists.txt @@ -52,4 +52,5 @@ target_sources( ${src_path}/SymUtility@Methods.F90 ${src_path}/TriagUtility@Methods.F90 ${src_path}/LinearAlgebraUtility@Methods.F90 - ${src_path}/SafeSizeUtility@Methods.F90) + ${src_path}/SafeSizeUtility@Methods.F90 + ${src_path}/ReverseUtility@Methods.F90) diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90 index 20e817b35..92e4596ee 100644 --- a/src/submodules/Utility/src/ConvertUtility@Methods.F90 +++ b/src/submodules/Utility/src/ConvertUtility@Methods.F90 @@ -20,8 +20,8 @@ ! summary: This submodule contains method for swaping SUBMODULE(ConvertUtility) Methods -USE ReallocateUtility -USE EyeUtility +USE ReallocateUtility, ONLY: Reallocate +USE EyeUtility, ONLY: eye IMPLICIT NONE CONTAINS @@ -29,24 +29,35 @@ ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE convert_1 +MODULE PROCEDURE obj_Convert1 CALL Reallocate(to, nns * tdof, nns * tdof) -CALL ConvertSafe(from=from, to=to, Conversion=conversion, & - & nns=nns, tdof=tdof) -END PROCEDURE convert_1 +CALL ConvertSafe(from=from, to=to, conversion=conversion, & + nns=nns, tdof=tdof) +END PROCEDURE obj_Convert1 !---------------------------------------------------------------------------- ! ConvertSafe !---------------------------------------------------------------------------- -MODULE PROCEDURE convert_1_safe +MODULE PROCEDURE obj_Convert_1 +nrow = nns * tdof +ncol = nns * tdof +CALL ConvertSafe(from=from, to=to(1:nrow, 1:ncol), conversion=conversion, & + nns=nns, tdof=tdof) +END PROCEDURE obj_Convert_1 + +!---------------------------------------------------------------------------- +! ConvertSafe +!---------------------------------------------------------------------------- + +MODULE PROCEDURE obj_ConvertSafe1 INTEGER(I4B) :: m, inode, idof, i, j INTEGER(I4B) :: T(nns * tdof, nns * tdof) !> main m = nns * tdof T = eye(m, TypeInt) -SELECT CASE (Conversion) +SELECT CASE (conversion) CASE (DofToNodes) DO inode = 1, nns @@ -72,13 +83,13 @@ END SELECT to = MATMUL(TRANSPOSE(T), MATMUL(from, T)) -END PROCEDURE convert_1_safe +END PROCEDURE obj_ConvertSafe1 !---------------------------------------------------------------------------- ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE convert_2 +MODULE PROCEDURE obj_Convert2 ! Define internal variables INTEGER(I4B) :: a, b, I(4), r1, r2, c1, c2 I = SHAPE(From) @@ -94,13 +105,13 @@ To(r1:r2, c1:c2) = From(:, :, a, b) END DO END DO -END PROCEDURE convert_2 +END PROCEDURE obj_Convert2 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE convert2_ +MODULE PROCEDURE obj_Convert_2 INTEGER(I4B) :: a, b, r1, r2, c1, c2 INTEGER(I4B) :: dim1, dim2, dim3, dim4 @@ -123,13 +134,13 @@ END DO END DO -END PROCEDURE convert2_ +END PROCEDURE obj_Convert_2 !---------------------------------------------------------------------------- ! Convert !---------------------------------------------------------------------------- -MODULE PROCEDURE convert_3 +MODULE PROCEDURE obj_Convert3 INTEGER(I4B) :: a, b, s(6) REAL(DFP), ALLOCATABLE :: m2(:, :) !! @@ -143,13 +154,13 @@ END DO END DO DEALLOCATE (m2) -END PROCEDURE convert_3 +END PROCEDURE obj_Convert3 !---------------------------------------------------------------------------- ! !---------------------------------------------------------------------------- -MODULE PROCEDURE convert3_ +MODULE PROCEDURE obj_Convert_3 INTEGER(I4B) :: a, b INTEGER(I4B) :: n1, n2, n3, n4, n5, n6 @@ -171,7 +182,7 @@ END DO END DO -END PROCEDURE convert3_ +END PROCEDURE obj_Convert_3 !---------------------------------------------------------------------------- ! diff --git a/src/submodules/Utility/src/MatmulUtility@Methods.F90 b/src/submodules/Utility/src/MatmulUtility@Methods.F90 index 1cc31c999..600bcca39 100644 --- a/src/submodules/Utility/src/MatmulUtility@Methods.F90 +++ b/src/submodules/Utility/src/MatmulUtility@Methods.F90 @@ -28,140 +28,313 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE matmul_r4_r1 -INTEGER(I4B) :: ii -ans = a2(1) * a1(:, :, :, 1) -DO ii = 2, SIZE(a2) - ans = ans + a2(ii) * a1(:, :, :, ii) -END DO +INTEGER(I4B) :: dim1, dim2, dim3 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) END PROCEDURE matmul_r4_r1 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- -MODULE PROCEDURE matmul_r4_r2 -INTEGER(I4B) :: ii -!! -DO ii = 1, SIZE(a2, 2) - ans(:,:,:,ii) = matmul(a1, a2(:,ii)) +MODULE PROCEDURE matmul_r4_r1_ +INTEGER(I4B) :: ii, jj, kk, ll + +dim1 = SIZE(a1, 1) +dim2 = SIZE(a1, 2) +dim3 = SIZE(a1, 3) + +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +DO ll = 2, SIZE(a2) + DO kk = 1, dim3 + DO jj = 1, dim2 + DO ii = 1, dim1 + ans(ii, jj, kk) = ans(ii, jj, kk) + a2(ll) * a1(ii, jj, kk, ll) + END DO + END DO + END DO END DO +END PROCEDURE matmul_r4_r1_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r4_r2 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) END PROCEDURE matmul_r4_r2 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- -MODULE PROCEDURE matmul_r4_r3 +MODULE PROCEDURE matmul_r4_r2_ INTEGER(I4B) :: ii -!! -DO ii = 1, SIZE(a2, 3) - ans(:,:,:,:,ii) = matmul(a1, a2(:,:,ii)) + +dim4 = SIZE(a2, 2) + +DO ii = 1, dim4 + call Matmul_(a1=a1, a2=a2(:, ii), ans=ans(:,:,:,ii), dim1=dim1, dim2=dim2, & + dim3=dim3) END DO +END PROCEDURE matmul_r4_r2_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r4_r3 +INTEGER(I4B) :: dim1, dim2, dim3, dim4, dim5 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4, dim5=dim5) END PROCEDURE matmul_r4_r3 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- -MODULE PROCEDURE matmul_r4_r4 +MODULE PROCEDURE matmul_r4_r3_ INTEGER(I4B) :: ii -!! -DO ii = 1, SIZE(a2, 4) - ans(:,:,:,:,:,ii) = matmul(a1, a2(:,:,:,ii)) + +dim5 = SIZE(a2, 3) + +DO ii = 1, dim5 + CALL Matmul_(a1=a1, a2=a2(:, :, ii), ans=ans(:, :, :, :, ii), dim1=dim1, & + dim2=dim2, dim3=dim3, dim4=dim4) END DO +END PROCEDURE matmul_r4_r3_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r4_r4 +INTEGER(I4B) :: dim1, dim2, dim3, dim4, dim5, dim6 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4, dim5=dim5, dim6=dim6) END PROCEDURE matmul_r4_r4 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- -MODULE PROCEDURE matmul_r3_r1 +MODULE PROCEDURE matmul_r4_r4_ INTEGER(I4B) :: ii -ans = a2(1) * a1(:, :, 1) -DO ii = 2, SIZE(a2) - ans = ans + a2(ii) * a1(:, :, ii) + +dim6 = SIZE(a2, 4) + +DO ii = 1, dim6 + CALL Matmul_(a1=a1, a2=a2(:, :, :, ii), ans=ans(:, :, :, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4, dim5=dim5) END DO +END PROCEDURE matmul_r4_r4_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r1 +INTEGER(I4B) :: nrow, ncol +CALL Matmul_(a1=a1, a2=a2, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE matmul_r3_r1 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- +MODULE PROCEDURE matmul_r3_r1_ +INTEGER(I4B) :: ii, jj, kk, tsize + +nrow = SIZE(a1, 1) +ncol = SIZE(a1, 2) +tsize = MIN(SIZE(a2), SIZE(a1, 3)) + +ans(1:nrow, 1:ncol) = 0.0_DFP + +DO kk = 1, tsize + DO jj = 1, ncol + DO ii = 1, nrow + ans(ii, jj) = ans(ii, jj) + a2(kk) * a1(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE matmul_r3_r1_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + MODULE PROCEDURE matmul_r3_r2 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE matmul_r3_r2 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r2_ INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 2) - ans(:, :, ii) = MATMUL(a1, a2(:, ii)) + +dim3 = SIZE(a2, 2) + +DO ii = 1, dim3 + CALL Matmul_(a1=a1, a2=a2(:, ii), ans=ans(:, :, ii), nrow=dim1, ncol=dim2) END DO -END PROCEDURE matmul_r3_r2 +END PROCEDURE matmul_r3_r2_ !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- MODULE PROCEDURE matmul_r3_r3 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) +END PROCEDURE matmul_r3_r3 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r3_ INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 3) - ans(:,:,:,ii) = matmul(a1, a2(:, :, ii)) + +dim4 = SIZE(a2, 3) + +DO ii = 1, dim4 + CALL Matmul_(a1=a1, a2=a2(:, :, ii), ans=ans(:, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3) END DO -END PROCEDURE matmul_r3_r3 +END PROCEDURE matmul_r3_r3_ !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- MODULE PROCEDURE matmul_r3_r4 +INTEGER(I4B) :: dim1, dim2, dim3, dim4, dim5 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4, dim5=dim5) +END PROCEDURE matmul_r3_r4 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r3_r4_ INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 4) - ans(:,:,:,:,ii) = matmul(a1, a2(:, :, :,ii)) + +dim5 = SIZE(a2, 4) + +DO ii = 1, dim5 + CALL Matmul_(a1=a1, a2=a2(:, :, :, ii), ans=ans(:, :, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4) END DO -END PROCEDURE matmul_r3_r4 +END PROCEDURE matmul_r3_r4_ !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- MODULE PROCEDURE matmul_r2_r3 +INTEGER(I4B) :: dim1, dim2, dim3 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3) +END PROCEDURE matmul_r2_r3 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r2_r3_ INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 3) - ans(:, :, ii) = MATMUL(a1, a2(:, :, ii)) + +dim1 = SIZE(a1, 1) +dim2 = SIZE(a2, 2) +dim3 = SIZE(a2, 3) + +DO ii = 1, dim3 + ans(1:dim1, 1:dim2, ii) = MATMUL(a1, a2(:, :, ii)) END DO -END PROCEDURE matmul_r2_r3 +END PROCEDURE matmul_r2_r3_ !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- MODULE PROCEDURE matmul_r2_r4 +INTEGER(I4B) :: dim1, dim2, dim3, dim4 +CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, & + dim4=dim4) +END PROCEDURE matmul_r2_r4 + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r2_r4_ INTEGER(I4B) :: ii -DO ii = 1, SIZE(a2, 4) - ans(:, :, :, ii) = MATMUL(a1, a2(:, :, :, ii)) + +dim4 = SIZE(a2, 4) +DO ii = 1, dim4 + CALL Matmul_(a1=a1, a2=a2(:, :, :, ii), ans=ans(:, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3) END DO -END PROCEDURE matmul_r2_r4 +END PROCEDURE matmul_r2_r4_ !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- MODULE PROCEDURE matmul_r1_r1 - ans = DOT_PRODUCT(a1, a2) +ans = DOT_PRODUCT(a1, a2) END PROCEDURE matmul_r1_r1 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- +MODULE PROCEDURE matmul_r1_r1_ +ans = DOT_PRODUCT(a1, a2) +END PROCEDURE matmul_r1_r1_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + MODULE PROCEDURE matmul_r1_r3 -INTEGER(I4B) :: ii -ans = a1(1) * a2(1, :, :) -DO ii = 2, SIZE(a1) - ans = ans + a1(ii) * a2(ii, :, :) -END DO +INTEGER(I4B) :: nrow, ncol +CALL Matmul_(a1=a1, a2=a2, ans=ans, nrow=nrow, ncol=ncol) END PROCEDURE matmul_r1_r3 !---------------------------------------------------------------------------- ! MATMUL !---------------------------------------------------------------------------- +MODULE PROCEDURE matmul_r1_r3_ +INTEGER(I4B) :: ii, jj, kk, tsize + +nrow = SIZE(a2, 2) +ncol = SIZE(a2, 3) +tsize = SIZE(a1) + +ans(1:nrow, 1:ncol) = 0.0_DFP + +DO kk = 1, ncol + DO jj = 1, nrow + DO ii = 1, tsize + ans(jj, kk) = ans(jj, kk) + a1(ii) * a2(ii, jj, kk) + END DO + END DO +END DO +END PROCEDURE matmul_r1_r3_ + +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + MODULE PROCEDURE matmul_r1_r4 INTEGER(I4B) :: ii ans = a1(1) * a2(1, :, :, :) @@ -170,4 +343,30 @@ END DO END PROCEDURE matmul_r1_r4 +!---------------------------------------------------------------------------- +! MATMUL +!---------------------------------------------------------------------------- + +MODULE PROCEDURE matmul_r1_r4_ +INTEGER(I4B) :: ii, jj, kk, ll, tsize + +dim1 = SIZE(a2, 2) +dim2 = SIZE(a2, 3) +dim3 = SIZE(a2, 4) +tsize = SIZE(a1) + +ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP + +DO ll = 1, dim3 + DO kk = 1, dim2 + DO jj = 1, dim1 + DO ii = 1, tsize + ans(jj, kk, ll) = ans(jj, kk, ll) + a1(ii) * a2(ii, jj, kk, ll) + END DO + END DO + END DO +END DO + +END PROCEDURE matmul_r1_r4_ + END SUBMODULE Methods diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90 index 2ec17697f..5c332dd4e 100644 --- a/src/submodules/Utility/src/ProductUtility@Methods.F90 +++ b/src/submodules/Utility/src/ProductUtility@Methods.F90 @@ -45,6 +45,30 @@ END PROCEDURE OTimesTilda1 +!---------------------------------------------------------------------------- +! OTimesTilda +!---------------------------------------------------------------------------- + +MODULE PROCEDURE OTimesTilda3 +INTEGER(I4B) :: sa(2), sb(2) +INTEGER(I4B) :: ii, jj, pp, qq + +sa(1) = SIZE(a) +sa(2) = SIZE(b) +sb(1) = SIZE(c) +sb(2) = SIZE(d) + +nrow = sa(1) * sb(1) +ncol = sa(2) * sb(2) + +DO CONCURRENT(ii=1:sa(1), jj=1:sa(2), pp=1:sb(1), qq=1:sb(2)) + ans((ii - 1) * sb(1) + pp, (jj - 1) * sb(2) + qq) = & + anscoeff * ans((ii - 1) * sb(1) + pp, (jj - 1) * sb(2) + qq) + & + scale * a(ii) * b(jj) * c(pp) * d(qq) +END DO + +END PROCEDURE OTimesTilda3 + !---------------------------------------------------------------------------- ! OTimesTilda !---------------------------------------------------------------------------- @@ -227,6 +251,22 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE OuterProd_r2r1_ +INTEGER(I4B) :: ii +dim1 = SIZE(a, 1) +dim2 = SIZE(a, 2) +dim3 = SIZE(b) + +DO ii = 1, dim3 + ans(1:dim1, 1:dim2, ii) = anscoeff * ans(1:dim1, 1:dim2, ii) + & + scale * a(1:dim1, 1:dim2) * b(ii) +END DO +END PROCEDURE OuterProd_r2r1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r2r2 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 2) @@ -238,6 +278,22 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE OuterProd_r2r2_ +INTEGER(I4B) :: ii + +dim4 = SIZE(b, 2) + +DO ii = 1, dim4 + CALL OuterProd_( & + a=a, b=b(:, ii), ans=ans(:, :, :, ii), anscoeff=anscoeff, & + scale=scale, dim1=dim1, dim2=dim2, dim3=dim3) +END DO +END PROCEDURE OuterProd_r2r2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r2r3 INTEGER(I4B) :: ii DO ii = 1, SIZE(b, 3) @@ -334,6 +390,26 @@ ! !---------------------------------------------------------------------------- +! ans(i, j, k) = anscoeff * ans + scale * (a(i) * b(j)) * c(k)) +MODULE PROCEDURE OuterProd_r1r1r1_ +REAL(DFP) :: scale0 +INTEGER(I4B) :: kk + +dim1 = SIZE(a) +dim2 = SIZE(b) +dim3 = SIZE(c) + +DO kk = 1, dim3 + scale0 = scale * c(kk) + CALL OuterProd_(a=a, b=b, ans=ans(:, :, kk), nrow=dim1, ncol=dim2, & + anscoeff=anscoeff, scale=scale0) +END DO +END PROCEDURE OuterProd_r1r1r1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r1r1r2 ans = OuterProd(OuterProd(a, b), c) END PROCEDURE OuterProd_r1r1r2 @@ -342,6 +418,22 @@ ! !---------------------------------------------------------------------------- +MODULE PROCEDURE OuterProd_r1r1r2_ +INTEGER(I4B) :: ii + +dim4 = SIZE(c, 2) + +DO ii = 1, dim4 + CALL OuterProd_(a=a, b=b, c=c(:, ii), ans=ans(:, :, :, ii), & + dim1=dim1, dim2=dim2, dim3=dim3, anscoeff=anscoeff, & + scale=scale) +END DO +END PROCEDURE OuterProd_r1r1r2_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r1r1r3 ans = OuterProd(OuterProd(a, b), c) END PROCEDURE OuterProd_r1r1r3 @@ -414,6 +506,27 @@ ! !---------------------------------------------------------------------------- +! ans = OuterProd(OuterProd(a, b), c) +MODULE PROCEDURE OuterProd_r2r1r1_ +REAL(DFP) :: scale0 +INTEGER(I4B) :: kk + +dim1 = SIZE(a, 1) +dim2 = SIZE(a, 2) +dim3 = SIZE(b) +dim4 = SIZE(c) + +DO kk = 1, dim4 + scale0 = scale * c(kk) + CALL OuterProd_(a=a, b=b, ans=ans(:, :, :, kk), dim1=dim1, dim2=dim2, & + dim3=dim3, anscoeff=anscoeff, scale=scale0) +END DO +END PROCEDURE OuterProd_r2r1r1_ + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + MODULE PROCEDURE OuterProd_r2r1r2 ans = OuterProd(OuterProd(a, b), c) END PROCEDURE OuterProd_r2r1r2 diff --git a/src/submodules/Utility/src/Reallocate/reallocate2.F90 b/src/submodules/Utility/src/Reallocate/reallocate2.F90 index 570150ba5..857e28cd8 100644 --- a/src/submodules/Utility/src/Reallocate/reallocate2.F90 +++ b/src/submodules/Utility/src/Reallocate/reallocate2.F90 @@ -1,23 +1,28 @@ -LOGICAL :: isok, abool, ex, acase +LOGICAL :: isalloc, abool(3), ex, acase INTEGER(I4B) :: s(2), ii, jj, fac -ex = .FALSE. -IF (PRESENT(isExpand)) ex = isExpand +isalloc = ALLOCATED(mat) -fac = 1 -IF (PRESENT(expandFactor)) fac = expandFactor - -isok = ALLOCATED(mat) +! If not allocated, then allocate and return +IF (.NOT. isalloc) THEN + ALLOCATE (mat(row, col)) + DO CONCURRENT(ii=1:row, jj=1:col) + mat(ii, jj) = ZEROVALUE + END DO + RETURN +END IF -acase = isok .AND. (.NOT. ex) +ex = .FALSE. +IF (PRESENT(isExpand)) ex = isExpand +! If allocated and isExpand is false, the deallocat and allocate +acase = .NOT. ex IF (acase) THEN - s = SHAPE(mat) - abool = s(1) .NE. row .OR. s(2) .NE. col + abool(1) = s(1) .NE. row .OR. s(2) .NE. col - IF (abool) THEN + IF (abool(1)) THEN DEALLOCATE (mat) ALLOCATE (mat(row, col)) END IF @@ -25,42 +30,28 @@ DO CONCURRENT(ii=1:row, jj=1:col) mat(ii, jj) = ZEROVALUE END DO - RETURN + RETURN END IF -acase = isok .AND. ex - -IF (acase) THEN - - s = SHAPE(mat) +! If allocated and isExpand is true +fac = 1 +IF (PRESENT(expandFactor)) fac = expandFactor - abool = (s(1) .LT. row) .OR. & - (s(2) .LT. col) +s = SHAPE(mat) - IF (abool) THEN - DEALLOCATE (mat) - ALLOCATE (mat(row * fac, col * fac)) - END IF +abool(1) = s(1) .LT. row +abool(2) = s(2) .LT. col - DO CONCURRENT(ii=1:row, jj=1:col) - mat(ii, jj) = ZEROVALUE - END DO - RETURN +IF (abool(1)) s(1) = row * fac +IF (abool(2)) s(2) = col * fac +IF (ANY(abool)) THEN + DEALLOCATE (mat) + ALLOCATE (mat(s(1), s(2))) END IF -ALLOCATE (mat(row * fac, col * fac)) - DO CONCURRENT(ii=1:row, jj=1:col) mat(ii, jj) = ZEROVALUE END DO -! IF (ALLOCATED(mat)) THEN -! IF ((SIZE(mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN -! DEALLOCATE (mat) -! ALLOCATE (mat(row, col)) -! END IF -! ELSE -! ALLOCATE (mat(row, col)) -! END IF diff --git a/src/submodules/Utility/src/Reallocate/reallocate3.F90 b/src/submodules/Utility/src/Reallocate/reallocate3.F90 index cf5b6380e..7521165d0 100644 --- a/src/submodules/Utility/src/Reallocate/reallocate3.F90 +++ b/src/submodules/Utility/src/Reallocate/reallocate3.F90 @@ -1,25 +1,60 @@ -LOGICAL :: isok, abool -INTEGER(I4B) :: s(3), ii, jj, kk +LOGICAL :: isalloc, abool(3), ex, acase +INTEGER(I4B) :: s(3), ii, jj, kk, fac -isok = ALLOCATED(mat) +isalloc = ALLOCATED(mat) -IF (isok) THEN +! If not allocated, then allocate and return +IF (.NOT. isalloc) THEN + ALLOCATE (mat(i1, i2, i3)) + DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3) + mat(ii, jj, kk) = ZEROVALUE + END DO + RETURN +END IF + +ex = .FALSE. +IF (PRESENT(isExpand)) ex = isExpand +! If allocated and isExpand is false, the deallocat and allocate +acase = .NOT. ex +IF (acase) THEN s = SHAPE(mat) - abool = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 + abool(1) = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 - IF (abool) THEN + IF (abool(1)) THEN DEALLOCATE (mat) ALLOCATE (mat(i1, i2, i3)) END IF -ELSE + DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3) + mat(ii, jj, kk) = ZEROVALUE + END DO - ALLOCATE (mat(i1, i2, i3)) + RETURN +END IF +! If allocated and isExpand is true +fac = 1 +IF (PRESENT(expandFactor)) fac = expandFactor + +s = SHAPE(mat) + +! abool = (s(1) .LT. i1) .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 +abool(1) = s(1) .LT. i1 +abool(2) = s(2) .LT. i2 +abool(3) = s(3) .LT. i3 + +IF (abool(1)) s(1) = i1 * fac +IF (abool(2)) s(2) = i2 * fac +IF (abool(3)) s(3) = i3 * fac + +IF (ANY(abool)) THEN + DEALLOCATE (mat) + ALLOCATE (mat(s(1), s(2), s(3))) END IF DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3) mat(ii, jj, kk) = ZEROVALUE END DO + diff --git a/src/submodules/Utility/src/Reverse/ReverseMatrix.F90 b/src/submodules/Utility/src/Reverse/ReverseMatrix.F90 new file mode 100644 index 000000000..aae4c629b --- /dev/null +++ b/src/submodules/Utility/src/Reverse/ReverseMatrix.F90 @@ -0,0 +1,51 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +INTEGER(I4B) :: tsize, halfSize, indx, indx1, indx2, ii + +SELECT CASE (dim) +CASE (1) + ! dim = 1 + tsize = r2 - r1 + 1 + halfSize = tsize / 2 + + DO ii = c1, c2 + DO indx = 1, halfSize + indx1 = r1 + indx - 1 + indx2 = r2 - indx + 1 + temp = ans(indx2, ii) + ans(indx2, ii) = ans(indx1, ii) + ans(indx1, ii) = temp + END DO + END DO + +CASE (2) + ! dim = 2 + tsize = c2 - c1 + 1 + halfSize = tsize / 2 + + DO indx = 1, halfSize + indx1 = c1 + indx - 1 + indx2 = c2 - indx + 1 + DO ii = r1, r2 + temp = ans(ii, indx2) + ans(ii, indx2) = ans(ii, indx1) + ans(ii, indx1) = temp + END DO + END DO +END SELECT + diff --git a/src/submodules/Utility/src/Reverse/ReverseVector.F90 b/src/submodules/Utility/src/Reverse/ReverseVector.F90 new file mode 100644 index 000000000..2d9be812f --- /dev/null +++ b/src/submodules/Utility/src/Reverse/ReverseVector.F90 @@ -0,0 +1,30 @@ +! This program is a part of EASIFEM library +! Expandable And Scalable Infrastructure for Finite Element Methods +! htttps://www.easifem.com +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see + +! INTEGER(INT8) :: temp +INTEGER(I4B) :: ii, jj, tsize, halfSize, indx + +tsize = n2 - n1 + 1 +halfSize = tsize / 2 + +DO indx = 1, halfSize + ii = n1 + indx - 1 + jj = n2 - indx + 1 + temp = ans(jj) + ans(jj) = ans(ii) + ans(ii) = temp +END DO diff --git a/src/submodules/Utility/src/ReverseUtility@Methods.F90 b/src/submodules/Utility/src/ReverseUtility@Methods.F90 new file mode 100644 index 000000000..4cafa9d01 --- /dev/null +++ b/src/submodules/Utility/src/ReverseUtility@Methods.F90 @@ -0,0 +1,196 @@ +! This program is a part of EASIFEM library +! Copyright (C) 2020-2021 Vikas Sharma, Ph.D +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see +! + +SUBMODULE(ReverseUtility) Methods +IMPLICIT NONE +CONTAINS + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int8_R1 +INTEGER(INT8) :: temp +#include "./Reverse/ReverseVector.F90" +END PROCEDURE Reverse_Int8_R1 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int16_R1 +INTEGER(INT16) :: temp +#include "./Reverse/ReverseVector.F90" +END PROCEDURE Reverse_Int16_R1 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int32_R1 +INTEGER(INT32) :: temp +#include "./Reverse/ReverseVector.F90" +END PROCEDURE Reverse_Int32_R1 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int64_R1 +INTEGER(INT64) :: temp +#include "./Reverse/ReverseVector.F90" +END PROCEDURE Reverse_Int64_R1 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Real32_R1 +REAL(REAL32) :: temp +#include "./Reverse/ReverseVector.F90" +END PROCEDURE Reverse_Real32_R1 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Real64_R1 +REAL(REAL64) :: temp +#include "./Reverse/ReverseVector.F90" +END PROCEDURE Reverse_Real64_R1 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int8_R2 +INTEGER(INT8) :: temp +#include "./Reverse/ReverseMatrix.F90" +END PROCEDURE Reverse_Int8_R2 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int16_R2 +INTEGER(INT16) :: temp +#include "./Reverse/ReverseMatrix.F90" +END PROCEDURE Reverse_Int16_R2 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int32_R2 +INTEGER(INT32) :: temp +#include "./Reverse/ReverseMatrix.F90" +END PROCEDURE Reverse_Int32_R2 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Int64_R2 +INTEGER(INT64) :: temp +#include "./Reverse/ReverseMatrix.F90" +END PROCEDURE Reverse_Int64_R2 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Real32_R2 +REAL(REAL32) :: temp +#include "./Reverse/ReverseMatrix.F90" +END PROCEDURE Reverse_Real32_R2 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Real64_R2 +REAL(REAL64) :: temp +#include "./Reverse/ReverseMatrix.F90" +END PROCEDURE Reverse_Real64_R2 + +!---------------------------------------------------------------------------- +! Reverse +!---------------------------------------------------------------------------- + +MODULE PROCEDURE Reverse_Real64_R3 +REAL(REAL64) :: temp +INTEGER(I4B) :: tsize, halfSize, indx, indx1, indx2, ii, jj + +SELECT CASE (dim) +CASE (1) + !! dim = 1 + tsize = r2 - r1 + 1 + halfSize = tsize / 2 + + DO jj = d1, d2 + DO ii = c1, c2 + DO indx = 1, halfSize + indx1 = r1 + indx - 1 + indx2 = r2 - indx + 1 + temp = ans(indx2, ii, jj) + ans(indx2, ii, jj) = ans(indx1, ii, jj) + ans(indx1, ii, jj) = temp + END DO + END DO + END DO + +CASE (2) + !! dim = 2 + tsize = c2 - c1 + 1 + halfSize = tsize / 2 + + DO jj = d1, d2 + DO indx = 1, halfSize + indx1 = c1 + indx - 1 + indx2 = c2 - indx + 1 + DO ii = r1, r2 + temp = ans(ii, indx2, jj) + ans(ii, indx2, jj) = ans(ii, indx1, jj) + ans(ii, indx1, jj) = temp + END DO + END DO + END DO + +CASE (3) + !! dim = 3 + tsize = d2 - d1 + 1 + halfSize = tsize / 2 + + DO indx = 1, halfSize + indx1 = d1 + indx - 1 + indx2 = d2 - indx + 1 + DO jj = c1, c2 + DO ii = r1, r2 + temp = ans(ii, jj, indx2) + ans(ii, jj, indx2) = ans(ii, jj, indx1) + ans(ii, jj, indx1) = temp + END DO + END DO + END DO +END SELECT +END PROCEDURE Reverse_Real64_R3 + +!---------------------------------------------------------------------------- +! +!---------------------------------------------------------------------------- + +END SUBMODULE Methods diff --git a/src/submodules/Utility/src/SwapUtility@Methods.F90 b/src/submodules/Utility/src/SwapUtility@Methods.F90 index c891eb817..f1641d7cd 100644 --- a/src/submodules/Utility/src/SwapUtility@Methods.F90 +++ b/src/submodules/Utility/src/SwapUtility@Methods.F90 @@ -20,7 +20,7 @@ ! summary: This submodule contains method for swaping SUBMODULE(SwapUtility) Methods -USE BaseMethod +USE ReallocateUtility, ONLY: Reallocate IMPLICIT NONE CONTAINS @@ -101,11 +101,13 @@ a = b b = dum END PROCEDURE swap_r32v +#endif !---------------------------------------------------------------------------- ! SWAP !---------------------------------------------------------------------------- +#ifndef USE_BLAS95 MODULE PROCEDURE swap_r64v REAL(REAL64), DIMENSION(SIZE(a)) :: dum dum = a @@ -119,10 +121,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int8v -INTEGER(INT8), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum +INTEGER(INT8) :: dum +INTEGER(I4B) :: ii, n + +n = SIZE(a) + +DO ii = 1, n + dum = a(ii) + a(ii) = b(ii) + b(ii) = dum +END DO END PROCEDURE swap_Int8v !---------------------------------------------------------------------------- @@ -130,10 +138,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int16v -INTEGER(INT16), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum +INTEGER(INT16) :: dum +INTEGER(I4B) :: ii, n + +n = SIZE(a) + +DO ii = 1, n + dum = a(ii) + a(ii) = b(ii) + b(ii) = dum +END DO END PROCEDURE swap_Int16v !---------------------------------------------------------------------------- @@ -141,10 +155,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int32v -INTEGER(INT32), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum +INTEGER(INT32) :: dum +INTEGER(I4B) :: ii, n + +n = SIZE(a) + +DO ii = 1, n + dum = a(ii) + a(ii) = b(ii) + b(ii) = dum +END DO END PROCEDURE swap_Int32v !---------------------------------------------------------------------------- @@ -152,10 +172,16 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int64v -INTEGER(INT64), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum +INTEGER(INT64) :: dum +INTEGER(I4B) :: ii, n + +n = SIZE(a) + +DO ii = 1, n + dum = a(ii) + a(ii) = b(ii) + b(ii) = dum +END DO END PROCEDURE swap_Int64v !---------------------------------------------------------------------------- @@ -164,10 +190,16 @@ #ifdef USE_Int128 MODULE PROCEDURE swap_Int128v -INTEGER(Int128), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum +INTEGER(Int128) :: dum +INTEGER(I4B) :: ii, n + +n = SIZE(a) + +DO ii = 1, n + dum = a(ii) + a(ii) = b(ii) + b(ii) = dum +END DO END PROCEDURE swap_Int128v #endif @@ -188,10 +220,16 @@ #ifndef USE_BLAS95 MODULE PROCEDURE swap_cv -COMPLEX(DFPC), DIMENSION(SIZE(a)) :: dum -dum = a -a = b -b = dum +COMPLEX(DFPC) :: dum +INTEGER(I4B) :: ii, n + +n = SIZE(a) + +DO ii = 1, n + dum = a(ii) + a(ii) = b(ii) + b(ii) = dum +END DO END PROCEDURE swap_cv #endif @@ -200,10 +238,20 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_cm -COMPLEX(DFPC), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +COMPLEX(DFPC) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO + END PROCEDURE swap_cm !---------------------------------------------------------------------------- @@ -211,10 +259,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_r32m -REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +REAL(REAL32) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_r32m !---------------------------------------------------------------------------- @@ -222,10 +279,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_r64m -REAL(REAL64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +REAL(REAL64) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_r64m !---------------------------------------------------------------------------- @@ -233,10 +299,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int8m -INTEGER(INT8), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +INTEGER(INT8) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_Int8m !---------------------------------------------------------------------------- @@ -244,10 +319,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int16m -INTEGER(INT16), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +INTEGER(INT16) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_Int16m !---------------------------------------------------------------------------- @@ -255,10 +339,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int32m -INTEGER(INT32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +INTEGER(INT32) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_Int32m !---------------------------------------------------------------------------- @@ -266,10 +359,19 @@ !---------------------------------------------------------------------------- MODULE PROCEDURE swap_Int64m -INTEGER(INT64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +INTEGER(INT64) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_Int64m !---------------------------------------------------------------------------- @@ -278,10 +380,19 @@ #ifdef USE_Int128 MODULE PROCEDURE swap_Int128m -INTEGER(Int128), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum -dum = a -a = b -b = dum +INTEGER(INT128) :: dum +INTEGER(I4B) :: ii, jj, nrow, ncol + +nrow = SIZE(a, 1) +ncol = SIZE(a, 2) + +DO jj = 1, ncol + DO ii = 1, nrow + dum = a(ii, jj) + a(ii, jj) = b(ii, jj) + b(ii, jj) = dum + END DO +END DO END PROCEDURE swap_Int128m #endif diff --git a/src/submodules/include/errors.F90 b/src/submodules/include/errors.F90 new file mode 100644 index 000000000..97548e3d2 --- /dev/null +++ b/src/submodules/include/errors.F90 @@ -0,0 +1,19 @@ +!---------------------------------------------------------------------------- +! AssertError1 +!---------------------------------------------------------------------------- + +SUBROUTINE AssertError1(a, myName, modName, lineNo, msg) + USE GlobalData, ONLY: I4B, stderr + USE ErrorHandling, ONLY: Errormsg + LOGICAL, INTENT(IN) :: a + CHARACTER(*), INTENT(IN) :: myName, modName, msg + INTEGER(I4B), INTENT(IN) :: lineNo + + IF (.NOT. a) THEN + CALL Errormsg(msg=msg, file=modName, routine=myName, & + line=lineNo, unitno=stderr) + STOP + END IF + +END SUBROUTINE AssertError1 +