#include "../config.h"
MODULE Lists
USE GeneralUtils
IMPLICIT NONE
INTEGER, PARAMETER :: LIST_TYPE_LOGICAL = 1
INTEGER, PARAMETER :: LIST_TYPE_STRING = 2
INTEGER, PARAMETER :: LIST_TYPE_INTEGER = 3
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR = 4
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_SCALAR = 5
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR_STR = 6
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_SCALAR_STR = 7
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR_PROC = 8
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_TENSOR = 9
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_TENSOR = 10
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_TENSOR_STR = 11
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_TENSOR_STR = 12
INTEGER, PARAMETER :: SECTION_TYPE_BODY = 1
INTEGER, PARAMETER :: SECTION_TYPE_MATERIAL = 2
INTEGER, PARAMETER :: SECTION_TYPE_BF = 3
INTEGER, PARAMETER :: SECTION_TYPE_IC = 4
INTEGER, PARAMETER :: SECTION_TYPE_BC = 5
INTEGER, PARAMETER :: SECTION_TYPE_COMPONENT = 6
INTEGER, PARAMETER :: SECTION_TYPE_SIMULATION = 7
INTEGER, PARAMETER :: SECTION_TYPE_CONSTANTS = 8
INTEGER, PARAMETER :: SECTION_TYPE_EQUATION = 9
INTEGER, PARAMETER :: MAX_FNC = 32
interface ElmerEvalLua
module procedure ElmerEvalLuaS, ElmerEvalLuaT, ElmerEvalLuaV
end INTERFACE
TYPE String_stack_t
CHARACTER(:), ALLOCATABLE :: Name
TYPE(String_stack_t), POINTER :: Next => Null()
END TYPE String_stack_t
CHARACTER(:), ALLOCATABLE, SAVE, PRIVATE :: Namespace
TYPE(String_stack_t), SAVE, PRIVATE, POINTER :: Namespace_stack => Null()
CHARACTER(:), ALLOCATABLE, SAVE, PRIVATE :: ActiveListName
TYPE(String_stack_t), SAVE, PRIVATE, POINTER :: Activename_stack => Null()
TYPE(ValueList_t), POINTER, SAVE, PRIVATE :: TimerList => NULL()
LOGICAL, SAVE, PRIVATE :: TimerPassive, TimerCumulative, TimerRealTime, TimerCPUTime
CHARACTER(LEN=MAX_NAME_LEN), SAVE, PRIVATE :: TimerPrefix
LOGICAL, PRIVATE :: DoNamespaceCheck = .FALSE.
CONTAINS
SUBROUTINE SetGetMatcParams(nparams,params,resul)
INTEGER :: nparams
REAL(KIND=dp) :: params(:)
CHARACTER(*), OPTIONAL :: resul
INTEGER :: i,j,l
CHARACTER(LEN=1024) :: pcmd,res
IF(nparams==0) THEN
pcmd = "tx=0"
ELSE
#if 0
WRITE(pcmd,*) [(params(i),i=1,nparams)]
#else
j = 1
DO i=1,nparams
WRITE(pcmd(j:), *) params(i)
DO WHILE(pcmd(j:j) == ' '); j=j+1; END DO
DO WHILE(pcmd(j:j) /= ' '); j=j+1; END DO
IF(pcmd(j-1:j-1)=='.') pcmd(j-1:j-1) = ' '
j = j + 1
END DO
#endif
IF(PRESENT(resul)) THEN
pcmd = TRIM(resul)//'='//TRIM(pcmd)
ELSE
pcmd = "tx="//TRIM(pcmd)
END IF
END IF
l = Matc(pcmd,res)
END SUBROUTINE SetGetMatcParams
FUNCTION GetMatcRealArray(cmd,n,m,nparams,params,resul) RESULT(g)
REAL(KIND=dp), ALLOCATABLE :: g(:,:)
CHARACTER(*) :: cmd
INTEGER :: n,m
INTEGER, OPTIONAL :: nparams
CHARACTER(*), OPTIONAL :: resul
REAL(KIND=dp), OPTIONAL :: params(:)
INTEGER :: i,j,l
CHARACTER(LEN=MAX_NAME_LEN) :: res
IF (PRESENT(nparams).AND.PRESENT(params))THEN
CALL SetGetMatcParams(nparams,params,resul)
END IF
l = Matc(cmd,res)
ALLOCATE(g(n,m))
READ(res(1:l),*) ((g(i,j),j=1,m),i=1,n)
END FUNCTION GetMatcRealArray
FUNCTION GetMatcRealVector(cmd,n,nparams,params,resul) RESULT(g)
REAL(KIND=dp), ALLOCATABLE :: g(:)
CHARACTER(*) :: cmd
INTEGER :: n,m
INTEGER, OPTIONAL :: nparams
CHARACTER(*), OPTIONAL :: resul
REAL(KIND=dp), OPTIONAL :: params(:)
INTEGER :: i,j,l
CHARACTER(LEN=MAX_NAME_LEN) :: res
IF (PRESENT(nparams).AND.PRESENT(params))THEN
CALL SetGetMatcParams(nparams,params,resul)
END IF
l = Matc(cmd,res)
ALLOCATE(g(n))
READ(res(1:l),*) (g(i),i=1,n)
END FUNCTION GetMatcRealVector
FUNCTION GetMatcReal(cmd,nparams,params,resul) RESULT(g)
CHARACTER(*) :: cmd
REAL(KIND=dp) :: g
INTEGER, OPTIONAL :: nparams
CHARACTER(*), OPTIONAL :: resul
REAL(KIND=dp), OPTIONAL :: params(:)
CHARACTER(LEN=MAX_NAME_LEN) :: pcmd, res
INTEGER :: i,l
IF (PRESENT(nparams).AND.PRESENT(params))THEN
CALL SetGetMatcParams(nparams,params,resul)
END IF
l = Matc(cmd,res)
READ(res(1:l), *) g
END FUNCTION GetMatcReal
FUNCTION InitialPermutation( Perm,Model,Solver,Mesh, &
Equation,DGSolver,GlobalBubbles ) RESULT(k)
USE PElementMaps
USE SParIterGlobals
TYPE(Model_t) :: Model
TYPE(Mesh_t) :: Mesh
TYPE(Solver_t), TARGET :: Solver
INTEGER :: Perm(:)
CHARACTER(LEN=*) :: Equation
LOGICAL, OPTIONAL :: DGSolver, GlobalBubbles
INTEGER i,j,l,t,n,m,e,k,k1, MaxNDOFs, MaxEDOFs, MaxFDOFs, BDOFs, ndofs, el_id
INTEGER :: NodalIndexOffset, EdgeIndexOffset, FaceIndexOffset, Indexes(128)
INTEGER, POINTER :: Def_Dofs(:)
INTEGER, ALLOCATABLE :: EdgeDOFs(:), FaceDOFs(:)
LOGICAL :: FoundDG, DG, DB, GB, Bubbles, Found, Radiation, Parallel
TYPE(Element_t),POINTER :: Element, Edge, Face
CHARACTER(*), PARAMETER :: Caller = 'InitialPermutation'
Perm = 0
k = 0
MaxEDOFs = Mesh % MaxEdgeDOFs
MaxFDOFs = Mesh % MaxFaceDOFs
MaxNDOFs = Mesh % MaxNDOFs
NodalIndexOffset = MaxNDOFs * Mesh % NumberOfNodes
EdgeIndexOffset = MaxEDOFs * Mesh % NumberOfEdges
FaceIndexOffset = MaxFDOFs * Mesh % NumberOfFaces
GB = .FALSE.
IF ( PRESENT(GlobalBubbles) ) GB=GlobalBubbles
DG = .FALSE.
IF ( PRESENT(DGSolver) ) DG=DGSolver
FoundDG = .FALSE.
IF( DG ) THEN
DB = ListGetLogical( Solver % Values,'DG Reduced Basis',Found )
ELSE
DB = .FALSE.
END IF
IF ( DB ) THEN
BLOCK
INTEGER, ALLOCATABLE :: NodeIndex(:)
INTEGER :: body_id, MaxGroup, group0, group
INTEGER, POINTER :: DgMap(:), DgMaster(:), DgSlave(:)
LOGICAL :: GotDgMap, GotMaster, GotSlave
DgMap => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Mapping',GotDgMap )
DgMaster => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Master Bodies',GotMaster )
DgSlave => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Slave Bodies',GotSlave )
IF( GotDgMap ) THEN
IF( SIZE( DgMap ) /= Model % NumberOfBodies ) THEN
CALL Fatal(Caller,'Invalid size of > Dg Reduced Basis Mapping <')
END IF
MaxGroup = MAXVAL( DgMap )
ELSE IF( GotMaster ) THEN
MaxGroup = 2
ELSE
MaxGroup = Model % NumberOfBodies
END IF
ALLOCATE( NodeIndex( Mesh % NumberOfNodes ) )
DO group0 = 1, MaxGroup
IF( GotSlave .AND. group0 == 2 ) THEN
DO t=1,Mesh % NumberOfBulkElements
Element => Mesh % Elements(t)
group = Element % BodyId
IF( ANY( DgSlave == group ) ) THEN
NodeIndex( Element % NodeIndexes ) = 0
END IF
END DO
ELSE
NodeIndex = 0
END IF
k1 = k
CALL Info(Caller,&
'Group '//I2S(group0)//' starts from index '//I2S(k1),Level=10)
DO t=1,Mesh % NumberOfBulkElements
Element => Mesh % Elements(t)
group = Element % BodyId
IF( GotMaster ) THEN
IF( group0 == 1 ) THEN
IF( .NOT. ANY( DgMaster == group ) ) CYCLE
ELSE
IF( ANY( DgMaster == group ) ) CYCLE
END IF
ELSE IF( GotDgMap ) THEN
group = DgMap( group )
IF( group0 /= group ) CYCLE
ELSE
IF( group0 /= group ) CYCLE
END IF
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
FoundDG = FoundDG .OR. Element % DGDOFs > 0
DO i=1,Element % DGDOFs
j = Element % NodeIndexes(i)
IF( NodeIndex(j) == 0 ) THEN
k = k + 1
NodeIndex(j) = k
END IF
Perm( Element % DGIndexes(i) ) = NodeIndex(j)
END DO
END IF
END DO
IF( k > k1 ) THEN
CALL Info( Caller,'Group '//I2S(group0)//&
' has '//I2S(k-k1)//' db dofs',Level=15)
END IF
END DO
CALL Info(Caller,'Numbered '//I2S(k)//&
' db nodes from bulk hits',Level=15)
IF ( FoundDG ) THEN
GOTO 10
END IF
END BLOCK
END IF
IF ( DG ) THEN
DO t=1,Mesh % NumberOfEdges
n = 0
Element => Mesh % Edges(t) % BoundaryInfo % Left
IF ( ASSOCIATED( Element ) ) THEN
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
FoundDG = FoundDG .OR. Element % DGDOFs > 0
DO j=1,Element % DGDOFs
n = n + 1
Indexes(n) = Element % DGIndexes(j)
END DO
END IF
END IF
Element => Mesh % Edges(t) % BoundaryInfo % Right
IF ( ASSOCIATED( Element ) ) THEN
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
FoundDG = FoundDG .OR. Element % DGDOFs > 0
DO j=1,Element % DGDOFs
n = n + 1
Indexes(n) = Element % DGIndexes(j)
END DO
END IF
END IF
DO i=1,n
j = Indexes(i)
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END DO
CALL Info(Caller,'Numbered '//I2S(k)//&
' nodes from face hits',Level=15)
k1 = k
DO t=1,Mesh % NumberOfFaces
n = 0
Element => Mesh % Faces(t) % BoundaryInfo % Left
IF ( ASSOCIATED( Element ) ) THEN
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
FoundDG = FoundDG .OR. Element % DGDOFs > 0
DO j=1,Element % DGDOFs
n = n + 1
Indexes(n) = Element % DGIndexes(j)
END DO
END IF
END IF
Element => Mesh % Faces(t) % BoundaryInfo % Right
IF ( ASSOCIATED( Element ) ) THEN
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
FoundDG = FoundDG .OR. Element % DGDOFs > 0
DO j=1,Element % DGDOFs
n = n + 1
Indexes(n) = Element % DGIndexes(j)
END DO
END IF
END IF
DO i=1,n
j = Indexes(i)
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END DO
CALL Info(Caller,'Numbered '//I2S(k-k1)//&
' nodes from bulk hits',Level=15)
IF ( FoundDG ) THEN
GOTO 10
END IF
END IF
IF ( ANY(Solver % Def_Dofs(:,:,6)>=1) ) THEN
IF ( Mesh % NumberOFEdges>0 ) THEN
ALLOCATE(EdgeDOFs(Mesh % NumberOfEdges))
EdgeDOFs=0;
END IF
IF ( Mesh % NumberOFFaces>0 ) THEN
ALLOCATE(FaceDOFs(Mesh % NumberOfFaces))
FaceDOFs=0;
END IF
n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements
t = 1
DO WHILE( t <= n )
DO WHILE( t<=n )
Element => Mesh % Elements(t)
IF ( CheckElementEquation( Model, Element, Equation ) ) EXIT
t = t + 1
END DO
IF ( t>n ) EXIT
el_id = Element % TYPE % ElementCode / 100
Def_Dofs => Solver % Def_Dofs(el_id,Element % BodyId,:)
IF ( ASSOCIATED(Element % EdgeIndexes) ) THEN
IF(Element % Type % ElementCode >= 300) THEN
DO i=1,Element % TYPE % NumberOfEdges
j = Element % EdgeIndexes(i)
EdgeDOFs(j)=MAX(EdgeDOFs(j),getEdgeDOFs(Element,Def_Dofs(6)))
END DO
END IF
END IF
IF ( ASSOCIATED(Element % FaceIndexes) ) THEN
IF(Element % Type % ElementCode >= 500) THEN
DO i=1,Element % TYPE % NumberOfFaces
j = Element % FaceIndexes(i)
FaceDOFs(j)=MAX(FaceDOFs(j),getFaceDOFs(Element,Def_Dofs(6),i, &
Mesh % Faces(j)) )
END DO
END IF
END IF
t=t+1
END DO
END IF
n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements
t = 1
DO WHILE( t <= n )
DO WHILE( t<=n )
Element => Mesh % Elements(t)
IF ( CheckElementEquation( Model, Element, Equation ) ) EXIT
t = t + 1
END DO
IF ( t > n ) EXIT
el_id = Element % TYPE % ElementCode / 100
Def_Dofs => Solver % Def_Dofs(el_id,Element % BodyId,:)
ndofs = Def_Dofs(1)
IF (ndofs > 0) THEN
DO i=1,Element % TYPE % NumberOfNodes
DO j=1,ndofs
l = MaxNDOFs * (Element % NodeIndexes(i)-1) + j
IF ( Perm(l) == 0 ) THEN
k = k + 1
Perm(l) = k
END IF
END DO
END DO
END IF
IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN
DO i=1,Element % TYPE % NumberOfEdges
Edge => Mesh % Edges( Element % EdgeIndexes(i) )
IF(Element % Type % ElementCode==Edge % Type % ElementCode.AND..NOT.GB) CYCLE
ndofs = 0
IF ( Def_Dofs(2) >= 0) THEN
ndofs = Def_Dofs(2)
ELSE IF (Def_Dofs(6)>1) THEN
ndofs = EdgeDOFs(Element % EdgeIndexes(i))
END IF
DO e=1,ndofs
j = NodalIndexOffset + MaxEDOFs*(Element % EdgeIndexes(i)-1) + e
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END DO
END IF
IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN
DO i=1,Element % TYPE % NumberOfFaces
Face => Mesh % Faces( Element % FaceIndexes(i) )
IF(Element % Type % ElementCode==Face % Type % ElementCode.AND..NOT.GB) CYCLE
l = MAX(0,Def_Dofs(3))
j = Face % TYPE % ElementCode/100
IF(l==0) THEN
IF (ASSOCIATED(Face % BoundaryInfo % Left)) THEN
e = Face % BoundaryInfo % Left % BodyId
l = MAX(0,Solver % Def_Dofs(j+6,e,5))
END IF
IF (ASSOCIATED(Face % BoundaryInfo % Right)) THEN
e = Face % BoundaryInfo % Right % BodyId
l = MAX(l,Solver % Def_Dofs(j+6,e,5))
END IF
END IF
ndofs = 0
IF (l > 0) THEN
ndofs = l
ELSE IF (Def_Dofs(6)>1) THEN
ndofs = FaceDOFs(Element % FaceIndexes(i))
END IF
DO e=1,ndofs
j = NodalIndexOffset + EdgeIndexOffset + &
MaxFDOFs*(Element % FaceIndexes(i)-1) + e
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END DO
END IF
IF ( GB .AND. ASSOCIATED(Element % BubbleIndexes) ) THEN
ndofs = 0
BDOFs = Def_Dofs(5)
j = Def_Dofs(6)
IF (BDOFs >= 0 .OR. j >= 1) THEN
IF (j > 1) ndofs = GetBubbleDOFs(Element, j)
ndofs = MAX(BDOFs, ndofs)
ELSE
Bubbles = ListGetLogical(Solver % Values, 'Bubbles', Found )
IF (Bubbles) ndofs = SIZE(Element % BubbleIndexes)
END IF
DO i=1,ndofs
j = NodalIndexOffset + EdgeIndexOffset + &
FaceIndexOffset + Element % BubbleIndexes(i)
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END IF
t = t + 1
END DO
Radiation = ListGetLogical( Solver % Values, 'Radiation Solver', Found )
IF ( Radiation ) THEN
Parallel = ParEnv % PEs>1
t = Mesh % NumberOfBulkElements + 1
n = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements
DO WHILE( t<= n )
Element => Mesh % Elements(t)
IF ( RadiationCheck(Element) ) THEN
DO i=1,Element % TYPE % NumberOfNodes
j = Element % NodeIndexes(i)
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END IF
t = t + 1
END DO
END IF
t = Mesh % NumberOfBulkElements + 1
n = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements
DO WHILE( t<= n )
Element => Mesh % Elements(t)
IF ( Element % TYPE % ElementCode == 102 ) THEN
DO i=1,Element % TYPE % NumberOfNodes
j = Element % NodeIndexes(i)
IF ( Perm(j) == 0 ) THEN
k = k + 1
Perm(j) = k
END IF
END DO
END IF
t = t + 1
END DO
IF( ListGetLogical( Solver % Values,'Apply Conforming BCs',Found ) ) THEN
BLOCK
INTEGER, POINTER :: TmpPerm(:)
LOGICAL, POINTER :: TmpFlip(:)
IF(.NOT. ASSOCIATED( Mesh % PeriodicPerm ) ) THEN
CALL Warn(Caller,'Conforming BC is requested but not generated!')
ELSE
Solver % PeriodicFlipActive = .FALSE.
n = SIZE( Mesh % PeriodicPerm )
m = SIZE( Perm )
IF( n < m ) THEN
CALL Info(Caller,'Increasing size of periodic tables from '&
//I2S(n)//' to '//I2S(SIZE(Perm))//'!',Level=7)
ALLOCATE( TmpPerm(SIZE(Perm)) )
TmpPerm = 0
TmpPerm(1:n) = Mesh % PeriodicPerm(1:n)
DEALLOCATE(Mesh % PeriodicPerm)
Mesh % PeriodicPerm => TmpPerm
IF(ASSOCIATED(Mesh % PeriodicFlip ) ) THEN
ALLOCATE( TmpFlip(SIZE(Perm)) )
TmpFlip = .FALSE.
TmpFlip(1:n) = Mesh % PeriodicFlip(1:n)
DEALLOCATE(Mesh % PeriodicFlip)
Mesh % PeriodicFlip => TmpFlip
END IF
END IF
n = 0
IF( ASSOCIATED( Mesh % PeriodicPerm ) ) THEN
WHERE( Mesh % PeriodicPerm(1:m) > 0 ) Perm = -Perm
k = 0
DO i=1,m
IF( Perm(i) > 0 ) THEN
k = k + 1
Perm(i) = k
END IF
END DO
DO i=1,m
j = Mesh % PeriodicPerm(i)
IF( j > 0 ) THEN
IF( Perm(i) /= 0 ) THEN
Perm(i) = Perm(j)
IF(Mesh % PeriodicFlip(i)) n = n + 1
END IF
END IF
END DO
Solver % PeriodicFlipActive = ( n > 0 )
CALL Info(Caller,'Number of periodic flips in the field: '//I2S(n),Level=8)
END IF
END IF
END BLOCK
END IF
IF ( ALLOCATED(EdgeDOFs) ) DEALLOCATE(EdgeDOFs)
IF ( ALLOCATED(FaceDOFs) ) DEALLOCATE(FaceDOFs)
10 CONTINUE
END FUNCTION InitialPermutation
FUNCTION RadiationCheck(Element) RESULT(L)
LOGICAL :: L, Found
INTEGER :: t
TYPE(Element_t), POINTER :: Element
TYPE(ValueList_t), POINTER :: BC
CHARACTER(:), ALLOCATABLE :: RadiationFlag
L = .FALSE.
IF ( Element % Type % ElementCode<=1 ) RETURN
t = Element % BoundaryInfo % Constraint
IF(t<=0 .OR. t>SIZE(CurrentModel % BCs)) RETURN
BC => CurrentModel % BCs(t) % Values
RadiationFlag = ListGetString( BC, 'Radiation', Found )
IF (RadiationFlag=='diffuse gray' .OR. ListGetLogical(BC,'Radiator BC',Found)) L=.TRUE.
END FUNCTION RadiationCheck
FUNCTION CheckElementEquation( Model,Element,Equation ) RESULT(Flag)
TYPE(Element_t), POINTER :: Element
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Equation
CHARACTER(:), ALLOCATABLE :: PrevEquation
LOGICAL :: Flag,Found,PrevFlag
INTEGER :: k,body_id,prev_body_id = -1
SAVE Prev_body_id, PrevEquation, PrevFlag
body_id = Element % BodyId
IF( body_id == prev_body_id) THEN
IF (Equation == PrevEquation) THEN
Flag = PrevFlag
RETURN
END IF
END IF
prev_body_id = body_id
PrevEquation = Equation
Flag = .FALSE.
IF ( body_id > 0 .AND. body_id <= Model % NumberOfBodies ) THEN
k = ListGetInteger( Model % Bodies(body_id) % Values, 'Equation', Found, &
minv=1, maxv=Model % NumberOFEquations )
IF ( k > 0 ) THEN
Flag = ListGetLogical(Model % Equations(k) % Values,Equation,Found)
END IF
END IF
PrevFlag = Flag
END FUNCTION CheckElementEquation
FUNCTION StringToLowerCase( to,from,same_len ) RESULT(n)
CHARACTER(LEN=*), INTENT(in) :: from
CHARACTER(LEN=*), INTENT(out) :: to
LOGICAL, OPTIONAL, INTENT(in) :: same_len
INTEGER :: n
INTEGER :: i,j,nlen
INTEGER, PARAMETER :: A=ICHAR('A'),Z=ICHAR('Z'),U2L=ICHAR('a')-ICHAR('A')
n = LEN(to)
IF (.NOT.PRESENT(same_len)) THEN
DO i=LEN(from),1,-1
IF ( from(i:i) /= ' ' ) EXIT
END DO
IF ( n>i ) THEN
to(i+1:n) = ' '
n=i
END IF
END IF
nlen = n
DO i=1,nlen
j = ICHAR( from(i:i) )
IF ( j >= A .AND. j <= Z ) THEN
to(i:i) = CHAR(j+U2L)
ELSE
to(i:i) = from(i:i)
IF ( to(i:i)=='[') n=i-1
END IF
END DO
END FUNCTION StringToLowerCase
SUBROUTINE VariableAppend( Variables,NewVar)
TYPE(Variable_t), POINTER :: Variables
TYPE(Variable_t), POINTER :: NewVar
LOGICAL :: stat
TYPE(Variable_t), POINTER :: ptr,ptr1
LOGICAL :: Hit
INTEGER :: n,n1
CHARACTER(*), PARAMETER :: Caller = 'VariableAppend'
CALL Info(Caller,'Inserting variable > '//TRIM(NewVar % Name)//&
' < of size '//I2S(SIZE(NewVar % Values)),Level=15)
IF ( .NOT.ASSOCIATED(NewVar) ) THEN
CALL Warn(Caller,'Cannot insert null variable to list!')
RETURN
END IF
IF ( .NOT.ASSOCIATED(Variables) ) THEN
CALL Warn(Caller,'Cannot insert variable to empty list!')
RETURN
END IF
n1 = LEN_TRIM( NewVar % Name )
Hit = .FALSE.
ptr => Variables
DO WHILE( ASSOCIATED( ptr ) )
n = LEN_TRIM( ptr % Name )
IF ( n == n1 ) THEN
IF ( ptr % Name(1:n) == NewVar % Name(1:n) ) THEN
Hit = .TRUE.
EXIT
END IF
END IF
ptr1 => ptr
ptr => ptr % Next
END DO
IF( Hit ) THEN
CALL Info(Caller,'Found variable in list: '//TRIM(NewVar % Name))
ELSE
CALL Info(Caller,'Append existing variable to end of list: '//TRIM(NewVar % Name))
ptr1 % Next => NewVar
NewVar % Next => NULL()
END IF
END SUBROUTINE VariableAppend
SUBROUTINE VariableAdd( Variables,Mesh,Solver,Name,DOFs,Values,&
Perm,Output,Secondary,TYPE )
TYPE(Variable_t), POINTER :: Variables
TYPE(Mesh_t), TARGET :: Mesh
TYPE(Solver_t), TARGET, OPTIONAL :: Solver
CHARACTER(LEN=*) :: Name
INTEGER :: DOFs
REAL(KIND=dp), POINTER :: Values(:)
INTEGER, OPTIONAL, POINTER :: Perm(:)
LOGICAL, OPTIONAL :: Output
LOGICAL, OPTIONAL :: Secondary
INTEGER, OPTIONAL :: TYPE
LOGICAL :: stat
TYPE(Variable_t), POINTER :: ptr,ptr1,ptr2
TYPE(Solver_t), POINTER :: VSolver
IF(ASSOCIATED(Values)) THEN
CALL Info('VariableAdd','Adding variable > '//TRIM(Name)//&
' < of size '//I2S(SIZE(Values)),Level=15)
ELSE
CALL Info('VariableAdd','Adding variable > '//TRIM(Name), Level=15)
END IF
NULLIFY(VSolver)
IF (PRESENT(Solver)) VSolver => Solver
IF ( .NOT.ASSOCIATED(Variables) ) THEN
ALLOCATE(Variables)
ptr => Variables
ELSE
ALLOCATE( ptr )
END IF
ALLOCATE(CHARACTER(LEN_TRIM(Name))::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
IF ( .NOT. ASSOCIATED(ptr, Variables) ) THEN
ptr1 => Variables
ptr2 => Variables
DO WHILE( ASSOCIATED( ptr1 ) )
IF ( ptr % Name == ptr1 % Name ) THEN
DEALLOCATE( ptr )
RETURN
END IF
ptr2 => ptr1
ptr1 => ptr1 % Next
END DO
ptr2 % Next => ptr
END IF
ptr % Next => NULL()
ptr % DOFs = DOFs
IF ( PRESENT( Perm ) ) THEN
ptr % Perm => Perm
ELSE
ptr % Perm => NULL()
END IF
ptr % Norm = 0.0d0
ptr % PrevNorm = 0.0d0
ptr % Values => Values
NULLIFY( ptr % PrevValues )
NULLIFY( ptr % EigenValues, ptr % EigenVectors )
ptr % NonlinChange = 0.0_dp
ptr % SteadyChange = 0.0_dp
ptr % NonlinValues => NULL()
ptr % SteadyValues => NULL()
ptr % NonlinIter = 0
ptr % Solver => VSolver
ptr % PrimaryMesh => Mesh
ptr % Valid = .TRUE.
ptr % Output = .TRUE.
ptr % Secondary = .FALSE.
ptr % ValuesChanged = .TRUE.
ptr % NonlinConverged = -1
ptr % SteadyConverged = -1
IF ( PRESENT( Secondary ) ) THEN
ptr % Secondary = Secondary
END IF
IF ( PRESENT( TYPE ) ) THEN
ptr % TYPE = TYPE
ELSE
IF(.NOT. PRESENT(Perm) .AND. ASSOCIATED(Values)) THEN
IF(SIZE(Values) == DOFs) ptr % Type = Variable_global
END IF
END IF
IF ( PRESENT( Output ) ) ptr % Output = Output
END SUBROUTINE VariableAdd
SUBROUTINE ReleaseVariableList( VariableList )
USE SpariterGlobals
TYPE(Variable_t), POINTER :: VariableList
REAL(KIND=dp), POINTER :: Ptr(:)
LOGICAL :: GotValues
INTEGER :: i, n, m
TYPE(Variable_t), POINTER :: Var, Var1
Var => VariableList
DO WHILE( ASSOCIATED( Var ) )
IF (ASSOCIATED(Var % Values) ) THEN
IF( SIZE( Var % Values ) == Var % DOFs ) THEN
Var => Var % Next
CYCLE
END IF
END IF
SELECT CASE( Var % Name )
CASE( 'coordinate 1', 'coordinate 2', 'coordinate 3' )
Var => Var % Next
CYCLE
END SELECT
IF( InfoActive(30) ) THEN
CALL Info('ReleaseVariableList','Trying to release variable: '//TRIM(Var % Name))
END IF
IF( Var % Secondary ) THEN
Var => Var % Next
CYCLE
END IF
IF (Var % DOFs > 1) THEN
Var => Var % Next
CYCLE
END IF
GotValues = .TRUE.
Var1 => VariableList
DO WHILE( ASSOCIATED( Var1 ) )
IF (.NOT.ASSOCIATED(Var,Var1)) THEN
IF ( ASSOCIATED(Var1 % Values) ) THEN
DO i=1,Var1 % DOFs
ptr => Var1 % Values(i::Var1 % DOFs)
IF ( ASSOCIATED(Var % Values,ptr) ) THEN
GotValues = .FALSE.
EXIT
END IF
END DO
END IF
END IF
IF (.NOT. GotValues) EXIT
Var1 => Var1 % Next
END DO
IF (ASSOCIATED(Var % Values)) THEN
IF(SIZE(Var % Values)<=0) GotValues = .FALSE.
END IF
IF (ASSOCIATED(Var % Perm)) THEN
Var1 => VariableList
DO WHILE(ASSOCIATED(Var1))
IF (.NOT.ASSOCIATED(Var,Var1)) THEN
IF (ASSOCIATED(Var % Perm,Var1 % Perm)) &
Var1 % Perm => NULL()
END IF
Var1 => Var1 % Next
END DO
IF(SIZE(Var % Perm)>0) THEN
DEALLOCATE( Var % Perm)
ELSE
GotValues = .FALSE.
END IF
END IF
IF ( GotValues ) THEN
CALL DeallocateVariableEntries()
END IF
NULLIFY( Var % EigenVectors, Var % EigenValues )
NULLIFY( Var % Values, Var % PrevValues, Var % Perm )
NULLIFY( Var % SteadyValues, Var % NonlinValues )
Var => Var % Next
END DO
Var => VariableList
DO WHILE( ASSOCIATED( Var ) )
IF ( Var % Secondary ) THEN
Var => Var % Next
CYCLE
END IF
IF ( ASSOCIATED( Var % Perm ) ) THEN
Var1 => VariableList
DO WHILE(ASSOCIATED(Var1))
IF (.NOT.ASSOCIATED(Var,Var1)) THEN
IF (ASSOCIATED(Var % Perm,Var1 % Perm)) THEN
Var1 % Perm => NULL()
END IF
END IF
Var1 => Var1 % Next
END DO
IF (SIZE(Var % Perm)>0) THEN
DEALLOCATE( Var % Perm )
END IF
END IF
IF ( Var % DOFs > 1 ) THEN
CALL DeallocateVariableEntries()
END IF
NULLIFY( Var % EigenVectors, Var % EigenValues )
NULLIFY( Var % Values, Var % PrevValues, Var % Perm )
NULLIFY( Var % SteadyValues, Var % NonlinValues )
Var => Var % Next
END DO
Var => VariableList
DO WHILE( ASSOCIATED( Var ) )
Var1 => Var % Next
DEALLOCATE( Var )
Var => Var1
END DO
CONTAINS
SUBROUTINE DeallocateVariableEntries()
IF ( ASSOCIATED( Var % Values ) ) &
DEALLOCATE( Var % Values )
IF ( ASSOCIATED( Var % PrevValues ) ) &
DEALLOCATE( Var % PrevValues )
IF ( ASSOCIATED( Var % EigenValues ) ) &
DEALLOCATE( Var % EigenValues )
IF ( ASSOCIATED( Var % EigenVectors ) ) &
DEALLOCATE( Var % EigenVectors )
IF ( ASSOCIATED( Var % SteadyValues ) ) &
DEALLOCATE( Var % SteadyValues )
IF ( ASSOCIATED( Var % NonlinValues ) ) &
DEALLOCATE( Var % NonlinValues )
IF( ASSOCIATED( Var % ConstraintModesIndeces ) ) &
DEALLOCATE( Var % ConstraintModesIndeces )
IF( ASSOCIATED( Var % ConstraintModes ) ) &
DEALLOCATE( Var % ConstraintModes )
IF( ASSOCIATED( Var % UpperLimitActive ) ) &
DEALLOCATE( Var % UpperLimitActive )
IF( ASSOCIATED( Var % LowerLimitActive ) ) &
DEALLOCATE( Var % LowerLimitActive )
IF( ASSOCIATED( Var % IpTable ) ) &
DEALLOCATE( Var % IpTable )
IF( ASSOCIATED( Var % CValues ) ) &
DEALLOCATE( Var % CValues )
IF( ASSOCIATED( Var % PValues ) ) &
DEALLOCATE( Var % PValues )
END SUBROUTINE DeallocateVariableEntries
END SUBROUTINE ReleaseVariableList
SUBROUTINE VariableRemove(Variables, NameIn, WarnMiss)
IMPLICIT NONE
TYPE(Variable_t), POINTER :: Variables
CHARACTER(LEN=*) :: NameIn
LOGICAL, OPTIONAL :: WarnMiss
TYPE(Variable_t), POINTER :: Var, Prev, RmVar
CHARACTER(LEN=LEN_TRIM(NameIn)) :: Name
LOGICAL :: GotIt, WarnMissing
INTEGER :: k
GotIt = .FALSE.
IF(PRESENT(WarnMiss)) THEN
WarnMissing = WarnMiss
ELSE
WarnMissing = .TRUE.
END IF
Var => Variables
Prev => NULL()
k = StringToLowerCase(Name, NameIn,.TRUE.)
WRITE(Message,'(a,a)') "Removing variable: ",Name(1:k)
CALL Info("VariableRemove",Message, Level=10)
DO WHILE(ASSOCIATED(Var))
IF( Var % NameLen == k ) THEN
IF(Var % Name(1:k) == Name(1:k)) THEN
GotIt = .TRUE.
RmVar => Var
IF(ASSOCIATED(Prev)) THEN
Prev % Next => Var % Next
ELSE
Variables => Var % Next
END IF
EXIT
END IF
END IF
Prev => Var
Var => Prev % Next
END DO
IF(.NOT. GotIt) THEN
IF(WarnMissing) CALL Warn("VariableRemove","Couldn't find the variable, returning...")
RETURN
END IF
RmVar % Next => NULL()
IF (ASSOCIATED(RmVar % Perm)) THEN
Var => Variables
DO WHILE(ASSOCIATED(Var))
IF(ASSOCIATED(RmVar, Var)) &
CALL Fatal("VariableRemove", "Programming Error - Variable appears twice in list?")
IF (ASSOCIATED(Var % Perm,RmVar % Perm)) THEN
RmVar % Perm => NULL()
EXIT
END IF
Var => Var % Next
END DO
IF(SIZE(RmVar % Perm) == 0) RmVar % Perm => NULL()
END IF
CALL ReleaseVariableList( RmVar )
END SUBROUTINE VariableRemove
SUBROUTINE VariableAddVector( Variables,Mesh,Solver,Name,DOFs,Values,&
Perm,Output,Secondary,VarType,Global,InitValue,IpPoints,varsuffix)
TYPE(Variable_t), POINTER :: Variables
TYPE(Mesh_t), TARGET :: Mesh
TYPE(Solver_t), TARGET, OPTIONAL :: Solver
CHARACTER(LEN=*) :: Name
INTEGER, OPTIONAL :: DOFs
REAL(KIND=dp), OPTIONAL, POINTER :: Values(:)
LOGICAL, OPTIONAL :: Output
INTEGER, OPTIONAL, POINTER :: Perm(:)
LOGICAL, OPTIONAL :: Secondary
INTEGER, OPTIONAL :: VarType
LOGICAL, OPTIONAL :: Global
REAL(KIND=dp), OPTIONAL :: InitValue
LOGICAL, OPTIONAL :: IpPoints
CHARACTER(LEN=*), OPTIONAL :: VarSuffix
CHARACTER(:), ALLOCATABLE :: tmpname
REAL(KIND=dp), POINTER :: Component(:), TmpValues(:)
INTEGER :: i,nsize, ndofs, FieldType
LOGICAL :: IsPerm, IsGlobal, IsIPPoints
IF( PRESENT( DOFs ) ) THEN
ndofs = Dofs
ELSE
ndofs = 1
END IF
IsPerm = .FALSE.
IsGlobal = .FALSE.
IsIPPoints = .FALSE.
IsPerm = PRESENT( Perm )
IF( PRESENT( Global ) ) IsGlobal = Global
IF( PRESENT( IPPoints ) ) IsIPPoints = IPPoints
IF( PRESENT( VarType ) ) THEN
FieldType = VarType
ELSE
FieldType = variable_on_nodes
END IF
CALL Info('VariableAddVector','Adding variable > '//TRIM(Name)//' < with '&
//I2S(ndofs)//' components',Level=15)
IF(PRESENT(Values)) THEN
TmpValues => Values
ELSE
IF( IsPerm ) THEN
nsize = MAXVAL( Perm )
ELSE IF( IsGlobal ) THEN
nsize = 1
ELSE IF( IsIpPoints ) THEN
IF( .NOT. PRESENT( Solver ) ) THEN
CALL Fatal('VariableAddVector','Integration point variable needs a Solver!')
END IF
IF( .NOT. ASSOCIATED( Solver % IPTable ) ) THEN
CALL Fatal('VariableAddVector','Integration point variable needs an IpTable')
END IF
nsize = Solver % IPTable % IPCount
ELSE
nsize = Mesh % NumberOfNodes
END IF
CALL Info('VariableAddVector','Allocating field of size: '//I2S(nsize),Level=12)
NULLIFY(TmpValues)
ALLOCATE(TmpValues(ndofs*nsize))
IF(.NOT. PRESENT(InitValue) ) THEN
TmpValues = 0.0_dp
END IF
END IF
IF( PRESENT( InitValue ) ) THEN
TmpValues = InitValue
END IF
IF( nDOFs > 1 ) THEN
DO i=1,nDOFs
tmpname = ComponentName(Name,i)
IF(PRESENT(VarSuffix)) tmpname = TRIM(tmpname)//' '//TRIM(VarSuffix)
Component => TmpValues(i::nDOFs)
CALL VariableAdd( Variables,Mesh,Solver,TmpName,1,Component,&
Perm,Output,.TRUE.,VarType)
END DO
END IF
tmpname = TRIM(Name)
IF(PRESENT(VarSuffix)) THEN
tmpname = TRIM(tmpname)//' '//TRIM(VarSuffix)
END IF
CALL VariableAdd( Variables,Mesh,Solver,tmpname,nDOFs,TmpValues,&
Perm,Output,Secondary,VarType)
END SUBROUTINE VariableAddVector
FUNCTION MeshProjector( Mesh1, Mesh2, &
UseQuadrantTree, Trans ) RESULT( ProjectorMatrix )
TYPE(Mesh_t) :: Mesh1, Mesh2
LOGICAL, OPTIONAL :: UseQuadrantTree,Trans
TYPE(Matrix_t), POINTER :: ProjectorMatrix
TYPE(Projector_t), POINTER :: Projector
INTERFACE
SUBROUTINE InterpolateMeshToMeshQ( OldMesh, NewMesh, OldVariables, NewVariables, &
UseQuadrantTree, Projector, MaskName, FoundNodes, NewMaskPerm, KeepUnfoundNodes )
USE Types
TYPE(Variable_t), POINTER, OPTIONAL :: OldVariables, NewVariables
TYPE(Mesh_t), TARGET :: OldMesh, NewMesh
LOGICAL, OPTIONAL :: UseQuadrantTree,FoundNodes(:)
CHARACTER(LEN=*),OPTIONAL :: MaskName
TYPE(Projector_t), POINTER, OPTIONAL :: Projector
INTEGER, OPTIONAL, POINTER :: NewMaskPerm(:)
LOGICAL, OPTIONAL :: KeepUnfoundNodes
END SUBROUTINE InterpolateMeshToMeshQ
END INTERFACE
IF ( PRESENT(UseQuadrantTree) ) THEN
CALL InterpolateMeshToMeshQ( Mesh1, Mesh2, &
UseQuadrantTree=UseQuadrantTree, Projector=Projector )
ELSE
CALL InterpolateMeshToMeshQ( Mesh1, Mesh2, Projector=Projector )
END IF
ProjectorMatrix => Projector % Matrix
IF ( PRESENT(Trans) ) THEN
IF ( Trans ) THEN
ProjectorMatrix => Projector % TMatrix
END IF
END IF
END FUNCTION MeshProjector
RECURSIVE FUNCTION VariableGet( Variables, Name, ThisOnly, MaskName, UnfoundFatal, &
DoInterp ) RESULT(Var)
TYPE(Variable_t), POINTER :: Variables
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: ThisOnly
CHARACTER(LEN=*),OPTIONAL :: MaskName
LOGICAL, OPTIONAL :: UnfoundFatal, DoInterp
TYPE(Mesh_t), POINTER :: Mesh
TYPE(Projector_t), POINTER :: Projector
TYPE(Variable_t), POINTER :: Var,PVar,Tmp,AidVar
REAL(KIND=dp), POINTER :: Vals(:)
INTEGER :: i,k,n, DOFs, MAXNDOFs
LOGICAL :: Found, GlobalBubbles, UseProjector, HackMesh, ExecInterpolation
CHARACTER(LEN=LEN_TRIM(Name)) :: str
DOUBLE PRECISION :: t1
CHARACTER(:), ALLOCATABLE :: tmpname
INTERFACE
SUBROUTINE InterpolateMeshToMesh( OldMesh, NewMesh, OldVariables, &
NewVariables, UseQuadrantTree, Projector, MaskName, UnfoundNodes )
USE Types
TYPE(Variable_t), POINTER, OPTIONAL :: OldVariables, NewVariables
TYPE(Mesh_t), TARGET :: OldMesh, NewMesh
LOGICAL, OPTIONAL :: UseQuadrantTree
LOGICAL, POINTER, OPTIONAL :: UnfoundNodes(:)
CHARACTER(LEN=*),OPTIONAL :: MaskName
TYPE(Projector_t), POINTER, OPTIONAL :: Projector
END SUBROUTINE InterpolateMeshToMesh
END INTERFACE
ExecInterpolation = .TRUE.
IF(PRESENT(DoInterp)) ExecInterpolation = DoInterp
k = StringToLowerCase( str,Name,.TRUE. )
Tmp => Variables
DO WHILE( ASSOCIATED(tmp) )
IF ( tmp % NameLen == k ) THEN
IF ( tmp % Name(1:k) == str(1:k) ) THEN
IF ( Tmp % Valid ) THEN
Var => Tmp
RETURN
END IF
EXIT
END IF
END IF
tmp => tmp % Next
END DO
Var => Tmp
IF ( PRESENT(ThisOnly) ) THEN
IF ( ThisOnly ) THEN
IF ( PRESENT(UnfoundFatal) ) THEN
IF ( UnfoundFatal ) THEN
CALL Fatal("VariableGet","Failed to find variable "//TRIM(Name))
END IF
END IF
RETURN
END IF
END IF
NULLIFY( PVar )
Mesh => CurrentModel % Meshes
DO WHILE( ASSOCIATED( Mesh ) )
IF ( .NOT.ASSOCIATED( Variables, Mesh % Variables ) ) THEN
PVar => VariableGet( Mesh % Variables, Name, ThisOnly=.TRUE. )
IF ( ASSOCIATED( PVar ) ) THEN
IF ( ASSOCIATED( Mesh, PVar % PrimaryMesh ) ) THEN
EXIT
END IF
END IF
END IF
Mesh => Mesh % Next
END DO
IF (.NOT.ASSOCIATED( PVar ) ) THEN
IF ( PRESENT(UnfoundFatal) ) THEN
IF ( UnfoundFatal ) THEN
CALL Fatal("VariableGet","Failed to find or interpolate variable: "//TRIM(Name))
END IF
END IF
RETURN
END IF
IF( pVar % TYPE == Variable_global ) THEN
IF(.NOT. ASSOCIATED(Var)) THEN
ALLOCATE(Var)
END IF
IF(.NOT. ASSOCIATED(Var % Values)) THEN
ALLOCATE(Var % Values(SIZE(pVar % Values)))
Var % Values = pVar % Values
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
PVar % Name, PVar % DOFs, Var % Values, &
Output = PVar % Output, TYPE = pVar % TYPE )
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
END IF
Var % Values = pVar % Values
RETURN
END IF
IF ( .NOT.ASSOCIATED( Tmp ) ) THEN
GlobalBubbles = .FALSE.
IF(ASSOCIATED(Pvar % Solver)) GlobalBubbles = Pvar % Solver % GlobalBubbles
Mesh => CurrentModel % Mesh
IF (PVar % PrimaryMesh % MaxNDOFs /= Mesh % MaxNDOFs) THEN
MaxNDOFs = Mesh % MaxNDOFs
IF (PVar % PrimaryMesh % MaxNDOFs == 1) THEN
HackMesh = .TRUE.
Mesh % MaxNDOFs = 1
ELSE
CALL Fatal('VariableGet', 'non-matching permutation occurs due to an element definition n:'//I2S(MaxNDOFs))
END IF
ELSE
HackMesh = .FALSE.
END IF
DOFs = Mesh % NumberOfNodes
DOFs = DOFs + Mesh % NumberOfEdges * Mesh % MaxEdgeDOFs
DOFs = DOFs + Mesh % NumberOfFaces * Mesh % MaxFaceDOFs
IF ( GlobalBubbles ) THEN
DOFs = DOFs + CurrentModel % Mesh % MaxBDOFs * &
CurrentModel % Mesh % NumberOfBulkElements
END IF
ALLOCATE( Var )
ALLOCATE( Var % Values(DOFs*Pvar % DOFs) )
Var % Values = 0
NULLIFY( Var % Perm )
IF (ASSOCIATED(PVar % Perm)) THEN
ALLOCATE( Var % Perm(DOFs) )
n = InitialPermutation( Var % Perm, CurrentModel, PVar % Solver, &
CurrentModel % Mesh, ListGetString(PVar % Solver % Values,'Equation'), &
GlobalBubbles=GlobalBubbles )
IF ( n==0 ) n=CurrentModel % Mesh % NumberOfNodes
IF ( n == CurrentModel % Mesh % NumberOfNodes ) THEN
DO i=1,n
Var % Perm(i) = i
END DO
END IF
END IF
IF (HackMesh) CurrentModel % Mesh % MaxNDOFs = MaxNDOFs
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
PVar % Name, PVar % DOFs, Var % Values, Var % Perm, PVar % Output )
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
NULLIFY( Var % PrevValues )
IF ( ASSOCIATED( PVar % PrevValues ) ) THEN
ALLOCATE( Var % PrevValues( DOFs, SIZE(PVar % PrevValues,2) ) )
Var % PrevValues = 0._dp
END IF
IF ( PVar % Name(1:PVar % NameLen) == 'flow solution' ) THEN
Vals => Var % Values( 1: SIZE(Var % Values) : PVar % DOFs )
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
'Velocity 1', 1, Vals, Var % Perm, PVar % Output )
Tmp => VariableGet( Variables, 'Velocity 1', .TRUE. )
NULLIFY( Tmp % PrevValues )
IF ( ASSOCIATED( Var % PrevValues ) ) &
Tmp % PrevValues => Var % PrevValues(1::PVar % DOFs,:)
Vals => Var % Values( 2: SIZE(Var % Values) : PVar % DOFs )
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
'Velocity 2', 1, Vals, Var % Perm, PVar % Output )
Tmp => VariableGet( Variables, 'Velocity 2', .TRUE. )
NULLIFY( Tmp % PrevValues )
IF ( ASSOCIATED( Var % PrevValues ) ) &
Tmp % PrevValues => Var % PrevValues(2::PVar % DOFs,:)
IF ( PVar % DOFs == 3 ) THEN
Vals => Var % Values( 3 : SIZE(Var % Values) : PVar % DOFs )
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
'Pressure', 1, Vals, Var % Perm, PVar % Output )
ELSE
Vals => Var % Values( 3: SIZE(Var % Values) : PVar % DOFs )
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
'Velocity 3', 1, Vals, Var % Perm, PVar % Output )
Tmp => VariableGet( Variables, 'Velocity 3', .TRUE. )
NULLIFY( Tmp % PrevValues )
IF ( ASSOCIATED( Var % PrevValues ) ) &
Tmp % PrevValues => Var % PrevValues(3::PVar % DOFs,:)
Vals => Var % Values( 4: SIZE(Var % Values) : PVar % DOFs )
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
'Pressure', 1, Vals, Var % Perm, PVar % Output )
END IF
Tmp => VariableGet( Variables, 'Pressure', .TRUE. )
NULLIFY( Tmp % PrevValues )
IF ( ASSOCIATED( Var % PrevValues ) ) &
Tmp % PrevValues => Var % PrevValues(PVar % DOFs::PVar % DOFs,:)
ELSE
IF ( PVar % DOFs > 1 ) THEN
DO i=1,PVar % DOFs
Vals => Var % Values( i: SIZE(Var % Values) : PVar % DOFs )
tmpname = ComponentName( PVar % Name, i )
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
tmpname, 1, Vals, Var % Perm, PVar % Output )
Tmp => VariableGet( Variables, tmpname, .TRUE. )
NULLIFY( Tmp % PrevValues )
IF ( ASSOCIATED( Var % PrevValues ) ) &
Tmp % PrevValues => Var % PrevValues(i::PVar % DOFs,:)
END DO
END IF
END IF
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
END IF
IF(.NOT.ExecInterpolation) RETURN
ALLOCATE( Tmp )
Tmp = PVar
Var => Tmp
NULLIFY( Var % Next )
IF ( PVar % Name(1:PVar % NameLen) == 'flow solution' ) THEN
ALLOCATE( Var % Next )
Var => Var % Next
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 1' )
ALLOCATE( Var % Next )
Var => Var % Next
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 2' )
IF ( PVar % DOFs == 4 ) THEN
ALLOCATE( Var % Next )
Var => Var % Next
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 3' )
END IF
ALLOCATE( Var % Next )
Var => Var % Next
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Pressure' )
NULLIFY( Var % Next )
Var => Tmp
ELSE IF ( PVar % DOFs > 1 ) THEN
DO i=1,PVar % DOFs
ALLOCATE( Var % Next )
tmpname = ComponentName( PVar % Name, i )
Var % Next = VariableGet( PVar % PrimaryMesh % Variables, tmpname )
Var => Var % Next
END DO
NULLIFY( Var % Next )
Var => Tmp
END IF
t1 = CPUTime()
UseProjector = ListGetLogical(CurrentModel % Simulation,'Use Mesh Projector',Found)
IF( .NOT. Found ) UseProjector = .TRUE.
IF( PRESENT( MaskName ) ) THEN
CALL Info('VariableGet','Performing masked on-the-fly interpolation',Level=15)
CALL InterpolateMeshToMesh( PVar % PrimaryMesh, &
CurrentModel % Mesh, Var, Variables, MaskName=MaskName )
ELSE IF( UseProjector ) THEN
CALL Info('VariableGet','Performing interpolation with projector',Level=15)
CALL InterpolateMeshToMesh( PVar % PrimaryMesh, &
CurrentModel % Mesh, Var, Variables, Projector=Projector )
ELSE
CALL Info('VariableGet','Performing on-the-fly interpolation',Level=15)
AidVar => VariableGet( CurrentModel % Mesh % Variables, Name, ThisOnly = .TRUE. )
IF( ASSOCIATED( AidVar ) ) THEN
AidVar % Values = 0.0_dp
END IF
CALL InterpolateMeshToMesh( PVar % PrimaryMesh, &
CurrentModel % Mesh, Var, Variables )
END IF
IF( InfoActive( 20 ) ) THEN
AidVar => VariableGet( CurrentModel % Mesh % Variables, Name, ThisOnly = .TRUE. )
PRINT *,'Interpolation range:',TRIM(AidVar % Name),MINVAL(AidVar % Values),MAXVAL( AidVar % Values)
END IF
WRITE( Message,'(A,ES12.3)' ) 'Interpolation time for > '//TRIM(Name)//' < :', CPUTime()-t1
CALL Info( 'VariableGet', Message, Level=7 )
DO WHILE( ASSOCIATED( Tmp ) )
Var => Tmp % Next
DEALLOCATE( Tmp )
Tmp => Var
END DO
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
Var % Valid = .TRUE.
Var % ValuesChanged = .TRUE.
IF ( Var % Name(1:Var % NameLen) == 'flow solution' ) THEN
Tmp => VariableGet( Variables, 'Velocity 1', ThisOnly=.TRUE. )
IF ( ASSOCIATED(Tmp) ) THEN
Tmp % Valid = .TRUE.
Tmp % ValuesChanged = .TRUE.
END IF
Tmp => VariableGet( Variables, 'Velocity 2', ThisOnly=.TRUE. )
IF ( ASSOCIATED(Tmp) ) THEN
Tmp % Valid = .TRUE.
Tmp % ValuesChanged = .TRUE.
END IF
IF ( Var % DOFs == 4 ) THEN
Tmp => VariableGet( Variables, 'Velocity 3', ThisOnly=.TRUE. )
IF ( ASSOCIATED(Tmp) ) THEN
Tmp % Valid = .TRUE.
Tmp % ValuesChanged = .TRUE.
END IF
END IF
Tmp => VariableGet( Variables, 'Pressure', ThisOnly=.TRUE. )
IF ( ASSOCIATED(Tmp) ) THEN
Tmp % Valid = .TRUE.
Tmp % ValuesChanged = .TRUE.
END IF
ELSE IF ( Var % DOFs > 1 ) THEN
DO i = 1,Var % DOFs
tmpname = ComponentName( Var % Name, i )
Tmp => VariableGet( Variables, tmpname, ThisOnly=.TRUE. )
IF ( ASSOCIATED(Tmp) ) THEN
Tmp % Valid = .TRUE.
Tmp % ValuesChanged = .TRUE.
END IF
END DO
END IF
END FUNCTION VariableGet
FUNCTION ListHead(list) RESULT(head)
TYPE(ValueList_t) :: List
TYPE(ValueListEntry_t), POINTER :: Head
head => List % Head
END FUNCTION ListHead
FUNCTION ListEmpty(list) RESULT(l)
LOGICAL :: L
TYPE(ValueList_t) :: list
L = .NOT.ASSOCIATED(list % head)
END FUNCTION ListEmpty
FUNCTION ListAllocate() RESULT(ptr)
TYPE(ValueList_t), POINTER :: ptr
ALLOCATE( ptr )
ptr % Head => Null()
END FUNCTION ListAllocate
FUNCTION ListEntryAllocate() RESULT(ptr)
TYPE(ValueListEntry_t), POINTER :: ptr
ALLOCATE( ptr )
ptr % PROCEDURE = 0
ptr % TYPE = 0
ptr % NameLen = 0
ptr % LValue = .FALSE.
NULLIFY( ptr % CubicCoeff )
NULLIFY( ptr % Cumulative )
NULLIFY( ptr % Next )
NULLIFY( ptr % FValues )
NULLIFY( ptr % TValues )
NULLIFY( ptr % IValues )
END FUNCTION ListEntryAllocate
SUBROUTINE ListDelete( ptr )
TYPE(ValueListEntry_t), POINTER :: ptr
IF ( ASSOCIATED(ptr % CubicCoeff) ) DEALLOCATE(ptr % CubicCoeff)
IF ( ASSOCIATED(ptr % Cumulative) ) DEALLOCATE(ptr % Cumulative)
IF ( ASSOCIATED(ptr % FValues) ) DEALLOCATE(ptr % FValues)
IF ( ASSOCIATED(ptr % TValues) ) DEALLOCATE(ptr % TValues)
IF ( ASSOCIATED(ptr % IValues) ) DEALLOCATE(ptr % IValues)
DEALLOCATE( ptr )
END SUBROUTINE ListDelete
SUBROUTINE ListRemove( List, Name )
TYPE(ValueList_t) :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr, prev
IF ( ASSOCIATED(List % Head) ) THEN
k = StringToLowerCase( str,Name,.TRUE. )
ptr => List % Head
Prev => ptr
DO WHILE( ASSOCIATED(ptr) )
IF ( ptr % NameLen == k) THEN
IF(ptr % Name(1:k) == str(1:k) ) THEN
IF ( ASSOCIATED(ptr,List % Head) ) THEN
List % Head => ptr % Next
Prev => List % Head
ELSE
Prev % Next => ptr % Next
END IF
CALL ListDelete(ptr)
EXIT
END IF
END IF
Prev => ptr
ptr => ptr % Next
END DO
END IF
END SUBROUTINE ListRemove
FUNCTION ListAdd( List, Name ) RESULT(NEW)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
TYPE(ValueListEntry_t), POINTER :: new
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr, prev
Prev => NULL()
Found = .FALSE.
IF(.NOT.ASSOCIATED(List)) List => ListAllocate()
New => ListEntryAllocate()
IF ( ASSOCIATED(List % Head) ) THEN
k = StringToLowerCase( str,Name,.TRUE. )
ptr => List % Head
NULLIFY( prev )
DO WHILE( ASSOCIATED(ptr) )
Found = ptr % NameLen == k
IF(Found) Found = ptr % Name(1:k) == str(1:k)
IF(Found) EXIT
Prev => Ptr
Ptr => Ptr % Next
END DO
IF ( Found ) THEN
New % Next => ptr % Next
IF ( ASSOCIATED( prev ) ) THEN
Prev % Next => New
ELSE
List % Head => New
END IF
CALL ListDelete( Ptr )
ELSE
IF ( ASSOCIATED(prev) ) THEN
prev % next => NEW
ELSE
NEW % Next => List % Head % Next
List % Head % Next => NEW
END IF
END IF
ELSE
List % Head => NEW
END IF
#ifdef DEVEL_LISTCOUNTER
#endif
END FUNCTION ListAdd
SUBROUTINE ListSetNamespace(str)
CHARACTER(LEN=*) :: str
CHARACTER(LEN=LEN_TRIM(str)) :: str_lcase
INTEGER :: n
n = StringToLowerCase( str_lcase,str,.TRUE. )
CALL Info('ListSetNamespace','Setting namespace to: '//TRIM(str_lcase),Level=15)
NameSpace = str_lcase
END SUBROUTINE ListSetNamespace
FUNCTION ListGetNamespace(str) RESULT(l)
LOGICAL :: l
CHARACTER(:), ALLOCATABLE :: str
IF (ALLOCATED(Namespace)) THEN
l = .TRUE.
str = Namespace
ELSE
l = .FALSE.
END IF
END FUNCTION ListGetNamespace
SUBROUTINE ListPushNamespace(str)
CHARACTER(LEN=*) :: str
LOGICAL :: L
CHARACTER(:), ALLOCATABLE :: tstr
TYPE(String_stack_t), POINTER :: stack
CALL Info('ListPushNameSpace','Adding name space: '//TRIM(str),Level=12)
ALLOCATE(stack)
L = ListGetNameSpace(tstr)
IF(ALLOCATED(tstr)) THEN
stack % name = tstr
ELSE
stack % name = ''
END IF
stack % next => Namespace_stack
Namespace_stack => stack
CALL ListSetNamespace(str)
END SUBROUTINE ListPushNamespace
SUBROUTINE ListPopNamespace( str0 )
CHARACTER(LEN=*), OPTIONAL :: str0
TYPE(String_stack_t), POINTER :: stack
IF(ASSOCIATED(Namespace_stack)) THEN
IF( PRESENT( str0 ) ) THEN
IF( str0 /= Namespace ) THEN
CALL Fatal('ListPopNamespace','Wrong namespace to pop: '&
//TRIM(str0)//' vs '//TRIM(Namespace))
END IF
END IF
Namespace = Namespace_stack % name
CALL Info('ListPopNameSpace','Deleting entry from name space: '&
//TRIM(Namespace),Level=12)
stack => Namespace_stack
Namespace_stack => stack % Next
DEALLOCATE(stack)
ELSE
CALL Info('ListPopNameSpace','No namespace entry to delete',Level=20)
END IF
END SUBROUTINE ListPopNamespace
SUBROUTINE ListPushActivename(str)
CHARACTER(LEN=*) :: str
LOGICAL :: L
TYPE(String_stack_t), POINTER :: stack
ALLOCATE(stack)
stack % name = ListGetActiveName()
stack % next => Activename_stack
Activename_stack => stack
ActiveListName = str
END SUBROUTINE ListPushActiveName
SUBROUTINE ListPopActiveName()
TYPE(String_stack_t), POINTER :: stack
IF(ASSOCIATED(Activename_stack)) THEN
ActiveListName = Activename_stack % name
stack => Activename_stack
Activename_stack => stack % Next
DEALLOCATE(stack)
END IF
END SUBROUTINE ListPopActiveName
FUNCTION ListGetActiveName() RESULT(str)
CHARACTER(:), ALLOCATABLE :: str
IF (ALLOCATED(ActiveListName)) THEN
str = ActiveListName
ELSE
str = ''
END IF
END FUNCTION ListGetActiveName
SUBROUTINE SetNamespaceCheck(L)
LOGICAL :: L
DoNamespaceCheck = L
END SUBROUTINE SetNamespaceCheck
FUNCTION GetNamespaceCheck() RESULT(L)
LOGICAL :: L
L = DoNameSpaceCheck
END FUNCTION GetNamespaceCheck
FUNCTION ListFind( list, name, Found ) RESULT(ptr)
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: name
LOGICAL, OPTIONAL :: Found
TYPE(String_stack_t), POINTER :: stack
CHARACTER(:), ALLOCATABLE :: stra
CHARACTER(:), ALLOCATABLE :: strn
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, k1, n
IF(PRESENT(Found)) Found = .FALSE.
ptr => NULL()
IF(.NOT.ASSOCIATED(List)) RETURN
k = StringToLowerCase( str,Name,.TRUE. )
IF( ListGetnamespace(strn) ) THEN
stack => Namespace_stack
DO WHILE(.TRUE.)
stra = trim(strn)
strn = stra //' '//str(1:k)
k1 = LEN(strn)
ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n==k1 ) THEN
IF ( ptr % Name(1:n) == strn ) EXIT
END IF
ptr => ptr % Next
END DO
IF(.NOT.DoNamespaceCheck) EXIT
IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT
IF(stack % name=='') EXIT
strn = stack % name
stack => stack % next
END DO
END IF
IF ( .NOT. ASSOCIATED(ptr) ) THEN
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n==k ) THEN
IF ( ptr % Name(1:n) == str(1:n) ) EXIT
END IF
ptr => ptr % Next
END DO
END IF
#ifdef DEVEL_LISTCOUNTER
IF( ASSOCIATED( ptr ) ) THEN
ptr % Counter = ptr % Counter + 1
END IF
#endif
#ifdef DEVEL_LISTUSAGE
IF( ASSOCIATED( ptr ) ) THEN
ptr % Counter = 1
END IF
#endif
IF ( PRESENT(Found) ) THEN
Found = ASSOCIATED(ptr)
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
CALL Warn( 'ListFind', ' ' )
WRITE(Message,*) 'Requested property: ', '[',TRIM(Name),'], not found'
CALL Warn( 'ListFind', Message )
CALL Warn( 'ListFind', ' ' )
END IF
END FUNCTION ListFind
SUBROUTINE ListRename( list, name, name2, Found )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: name, name2
LOGICAL, OPTIONAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr
CHARACTER(:), ALLOCATABLE :: strn
CHARACTER(LEN=LEN_TRIM(Name)) :: str
CHARACTER(LEN=LEN_TRIM(Name2)) :: str2
INTEGER :: k, k2, n
IF(PRESENT(Found)) Found = .FALSE.
ptr => NULL()
IF(.NOT.ASSOCIATED(List)) RETURN
k = StringToLowerCase( str,Name,.TRUE. )
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n==k ) THEN
IF ( ptr % Name(1:n) == str(1:n) ) EXIT
END IF
ptr => ptr % Next
END DO
IF( ASSOCIATED( ptr ) ) THEN
k2 = StringToLowerCase( str2,Name2,.TRUE. )
ptr % Name = str2(1:k2)
ptr % NameLen = k2
END IF
IF ( PRESENT(Found) ) THEN
Found = ASSOCIATED(ptr)
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
CALL Warn( 'ListRename', ' ' )
WRITE(Message,*) 'Requested property: ', '[',TRIM(Name),'], not found'
CALL Warn( 'ListRename', Message )
CALL Warn( 'ListRename', ' ' )
END IF
END SUBROUTINE ListRename
SUBROUTINE ListRenameAllBC( Model, Name, Name2 )
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name, Name2
LOGICAL :: Found
INTEGER :: bc, n
n = 0
DO bc = 1,Model % NumberOfBCs
CALL ListRename( Model % BCs(bc) % Values, Name, Name2, Found )
IF( Found ) n = n + 1
END DO
IF( n > 0 ) CALL Info('ListRenameAllBCs',&
'"'//TRIM(Name)//'" renamed to "'//TRIM(Name2)//'" on '//I2S(n)//' BCs',Level=6)
END SUBROUTINE ListRenameAllBC
SUBROUTINE ListRenameAllBodyForce( Model, Name, Name2 )
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name, Name2
LOGICAL :: Found
INTEGER :: bc, n
n = 0
DO bc = 1,Model % NumberOfBodyForces
CALL ListRename( Model % BodyForces(bc) % Values, Name, Name2, Found )
IF( Found ) n = n + 1
END DO
IF( n > 0 ) CALL Info('ListRenameAllBodyForces',&
'"'//TRIM(Name)//'" renamed to "'//TRIM(Name2)//'" on '//I2S(n)//' BCs',Level=6)
END SUBROUTINE ListRenameAllBodyForce
FUNCTION ListCheckPresent( List,Name ) RESULT(Found)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListFind(List,Name,Found)
END FUNCTION ListCheckPresent
FUNCTION ListFindPrefix( list, name, Found) RESULT(ptr)
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(ValueList_t), POINTER :: list
CHARACTER(LEN=*) :: name
LOGICAL, OPTIONAL :: Found
TYPE(String_stack_t), POINTER :: stack
CHARACTER(:), ALLOCATABLE :: strn,stra
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, k1, n, m
ptr => NULL()
IF(.NOT.ASSOCIATED(List)) RETURN
k = StringToLowerCase( str,Name,.TRUE. )
IF ( ListGetNamespace(strn) ) THEN
stack => Namespace_stack
DO WHILE(.TRUE.)
stra = trim(strn)
strn = stra //' '//str(1:k)
k1 = LEN(strn)
ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n >= k1 ) THEN
IF ( ptr % Name(1:k1) == strn ) EXIT
END IF
ptr => ptr % Next
END DO
IF(.NOT.DoNamespaceCheck) EXIT
IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT
IF(stack % name=='') EXIT
strn = stack % name
stack => stack % next
END DO
END IF
IF ( .NOT. ASSOCIATED(ptr) ) THEN
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n >= k ) THEN
IF ( ptr % Name(1:k) == str(1:k) ) EXIT
END IF
ptr => ptr % Next
END DO
END IF
IF ( PRESENT(Found) ) THEN
Found = ASSOCIATED(ptr)
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
CALL Warn( 'ListFindPrefix', ' ' )
WRITE(Message,*) 'Requested prefix: ', '[',TRIM(Name),'], not found'
CALL Warn( 'ListFindPrefix', Message )
CALL Warn( 'ListFindPrefix', ' ' )
END IF
END FUNCTION ListFindPrefix
FUNCTION ListFindSuffix( list, name, Found) RESULT(ptr)
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(ValueList_t), POINTER :: list
CHARACTER(LEN=*) :: name
LOGICAL, OPTIONAL :: Found
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, k1, n, m
ptr => Null()
IF(.NOT.ASSOCIATED(List)) RETURN
k = StringToLowerCase( str,Name,.TRUE. )
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n >= k ) THEN
IF ( ptr % Name(n-k+1:n) == str(1:k) ) EXIT
END IF
ptr => ptr % Next
END DO
IF ( PRESENT(Found) ) THEN
Found = ASSOCIATED(ptr)
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
CALL Warn( 'ListFindSuffix', ' ' )
WRITE(Message,*) 'Requested suffix: ', '[',TRIM(Name),'], not found'
CALL Warn( 'ListFindSuffix', Message )
CALL Warn( 'ListFindSuffix', ' ' )
END IF
END FUNCTION ListFindSuffix
FUNCTION ListCheckSuffix( List, Name ) RESULT(Found)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
TYPE(ValuelistEntry_t), POINTER :: ptr
ptr => ListFindSuffix( List, Name, Found )
END FUNCTION ListCheckSuffix
FUNCTION ListCheckSuffixAnyBC( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: bc
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO bc = 1,Model % NumberOfBCs
ptr => ListFindSuffix( Model % BCs(bc) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckSuffixAnyBC
FUNCTION ListCheckSuffixAnyBody( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: body_id
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO body_id = 1,Model % NumberOfBodies
ptr => ListFindSuffix( Model % Bodies(body_id) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckSuffixAnyBody
FUNCTION ListCheckSuffixAnyMaterial( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: mat_id
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO mat_id = 1,Model % NumberOfMaterials
ptr => ListFindSuffix( Model % Materials(mat_id) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckSuffixAnyMaterial
FUNCTION ListCheckSuffixAnyBodyForce( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: bf_id
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO bf_id = 1,Model % NumberOfBodyForces
ptr => ListFindSuffix( Model % BodyForces(bf_id) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckSuffixAnyBodyForce
FUNCTION ListFindVectorPrefix( list, name, ComponentWise,Found ) RESULT(ptr)
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(ValueList_t), POINTER :: list
CHARACTER(LEN=*) :: name
LOGICAL :: ComponentWise
LOGICAL, OPTIONAL :: Found
TYPE(String_stack_t), POINTER :: stack
CHARACTER(:), ALLOCATABLE :: strn
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, k1, n, m
ptr => NULL()
IF(.NOT.ASSOCIATED(List)) RETURN
k = StringToLowerCase( str,Name,.TRUE. )
IF ( ListGetNamespace(strn) ) THEN
stack => Namespace_stack
DO WHILE(.TRUE.)
strn = TRIM(strn) //' '//str(1:k)
k1 = LEN(strn)
ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n == k1 ) THEN
IF ( ptr % Name(1:k1) == strn ) THEN
ComponentWise = .FALSE.
EXIT
END IF
ELSE IF( n == k1 + 2 ) THEN
IF ( ptr % Name(1:k1+1) == strn//' ' ) THEN
ComponentWise = .TRUE.
EXIT
END IF
END IF
ptr => ptr % Next
END DO
IF(.NOT.DoNamespaceCheck) EXIT
IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT
IF(stack % name=='') EXIT
strn = stack % name
stack => stack % next
END DO
END IF
IF ( .NOT. ASSOCIATED(ptr) ) THEN
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n == k ) THEN
IF ( ptr % Name(1:k) == str(1:k) ) THEN
ComponentWise = .FALSE.
EXIT
END IF
ELSE IF( n == k + 2 ) THEN
IF ( ptr % Name(1:k+1) == str(1:k)//' ' ) THEN
ComponentWise = .TRUE.
EXIT
END IF
END IF
ptr => ptr % Next
END DO
END IF
IF ( PRESENT(Found) ) THEN
Found = ASSOCIATED(ptr)
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
CALL Warn( 'ListFindVectorPrefix', ' ' )
WRITE(Message,*) 'Requested vector prefix: ', '[',TRIM(Name),'], not found'
CALL Warn( 'ListFindVectorPrefix', Message )
CALL Warn( 'ListFindVectorPrefix', ' ' )
END IF
END FUNCTION ListFindVectorPrefix
SUBROUTINE ListSetCoefficients( list, name, coeff )
TYPE(ValueList_t), POINTER :: list
CHARACTER(LEN=*) :: name
REAL(KIND=dp) :: coeff
TYPE(ValueListEntry_t), POINTER :: ptr, ptr2
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, k1, n, n2, m
IF(.NOT.ASSOCIATED(List)) RETURN
k = StringToLowerCase( str,Name,.TRUE. )
Ptr => list % Head
DO WHILE( ASSOCIATED(ptr) )
IF( ptr % disttag ) THEN
WRITE( Message,'(A,ES12.5)') 'Normalizing > '//&
TRIM( ptr2 % Name )// ' < by ',Coeff
CALL Info('ListSetCoefficients',Message,Level=7)
ptr % Coeff = Coeff
ptr => ptr % Next
CYCLE
END IF
n = ptr % NameLen
IF ( n >= k ) THEN
IF ( ptr % Name(n-k+1:n) == str(1:k) ) THEN
Ptr2 => list % Head
DO WHILE( ASSOCIATED(ptr2) )
n2 = ptr2 % NameLen
IF( n2 + k <= n ) THEN
IF ( ptr2 % Name(1:n2) == ptr % Name(1:n2) ) THEN
WRITE( Message,'(A,ES12.5)') 'Normalizing > '//&
TRIM( ptr2 % Name )// ' < by ',Coeff
CALL Info('ListSetCoefficients',Message,Level=7)
ptr2 % Coeff = Coeff
EXIT
END IF
END IF
ptr2 => ptr2 % Next
END DO
END IF
END IF
ptr => ptr % Next
END DO
END SUBROUTINE ListSetCoefficients
SUBROUTINE ListParTagKeyword( List,Name,partag )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: partag
TYPE(ValueListEntry_t), POINTER :: ptr
LOGICAL :: Found
ptr => ListFind( List, Name, Found )
IF(.NOT. Found) THEN
CALL Fatal('ListParTagKeyword','Cannot add tag to non-existing keyword: '//TRIM(Name))
END IF
Ptr % partag = partag
END SUBROUTINE ListParTagKeyword
SUBROUTINE ListDistTagKeyword( List,Name )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
TYPE(ValueListEntry_t), POINTER :: ptr
LOGICAL :: Found
ptr => ListFind( List, Name, Found )
IF(.NOT. Found) THEN
CALL Fatal('ListDistTagKeyword','Cannot add tag to non-existing keyword: '//TRIM(Name))
END IF
Ptr % disttag = .TRUE.
END SUBROUTINE ListDistTagKeyword
SUBROUTINE ListTagKeywords( Model, suffix, tagwei, Found )
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: suffix
LOGICAL :: tagwei
LOGICAL :: Found
INTEGER :: i,cnt
CALL Info('ListTagKeywords','Setting weight for keywords!',Level=20)
cnt = 0
CALL ListTagEntry(Model % Simulation, suffix, tagwei, cnt )
CALL ListTagEntry(Model % Constants, suffix, tagwei, cnt )
DO i=1,Model % NumberOfEquations
CALL ListTagEntry(Model % Equations(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfComponents
CALL ListTagEntry(Model % Components(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfBodyForces
CALL ListTagEntry(Model % BodyForces(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfICs
CALL ListTagEntry(Model % ICs(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfBCs
CALL ListTagEntry(Model % BCs(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfMaterials
CALL ListTagEntry(Model % Materials(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfBoundaries
CALL ListTagEntry(Model % Boundaries(i) % Values, suffix, tagwei, cnt )
END DO
DO i=1,Model % NumberOfSolvers
CALL ListTagEntry(Model % Solvers(i) % Values, suffix, tagwei, cnt )
END DO
Found = ( cnt > 0 )
IF( Found ) THEN
CALL Info('ListTagKeywords',&
'Tagged '//I2S(cnt)//' parameters with suffix: '//TRIM(suffix),Level=7)
ELSE
CALL Info('ListTagKeywords','No parameters width suffix: '//TRIM(suffix),Level=20)
END IF
CONTAINS
SUBROUTINE ListTagEntry( list, name, tagwei, cnt )
TYPE(ValueList_t), POINTER :: list
CHARACTER(LEN=*) :: name
LOGICAL :: tagwei
INTEGER :: cnt
TYPE(ValueListEntry_t), POINTER :: ptr, ptr2
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, k1, n, n2, m, partag
IF(.NOT.ASSOCIATED(List)) RETURN
m = 0
k = StringToLowerCase( str,Name,.TRUE. )
Ptr => list % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n >= k ) THEN
IF ( ptr % Name(n-k+1:n) == str(1:k) ) THEN
Ptr2 => list % Head
DO WHILE( ASSOCIATED(ptr2) )
n2 = ptr2 % NameLen
IF( n2 + k <= n ) THEN
IF ( ptr2 % Name(1:n2) == ptr % Name(1:n2) ) THEN
IF( tagwei ) THEN
ptr2 % disttag = ptr % Lvalue
m = m + 1
WRITE( Message,'(A)') 'Adding dist tag to "'//TRIM( ptr2 % Name )//'"'
CALL Info('ListTagKeywords',Message,Level=15)
ELSE
partag = ptr % IValues(1)
IF(partag<1) THEN
CALL Warn('ListTagKeywords','Positive integer expected for parameter tag!')
ELSE
WRITE( Message,'(A)') 'Adding tag '//I2S(partag)//&
' to "'//TRIM( ptr2 % Name )//'"'
CALL Info('ListTagKeywords',Message,Level=15)
ptr2 % partag = partag
m = m + 1
END IF
END IF
END IF
END IF
ptr2 => ptr2 % Next
END DO
END IF
END IF
ptr => ptr % Next
END DO
IF( m > 0 ) THEN
CALL Info('ListTagKeywords',&
'Tagged '//I2S(m)//' parameters in list',Level=15)
END IF
cnt = cnt + m
END SUBROUTINE ListTagEntry
END SUBROUTINE ListTagKeywords
FUNCTION ListTagCount( Model, tagwei ) RESULT ( cnt )
TYPE(Model_t) :: Model
LOGICAL :: tagwei
INTEGER :: cnt
INTEGER :: i
IF( tagwei ) THEN
CALL Info('ListTagCount','Counting tags for keyword normalization!',Level=12)
ELSE
CALL Info('ListTagCount','Counting tags for keyword variation!',Level=12)
END IF
cnt = 0
DO i=1,Model % NumberOfBCs
CALL ListTagCnt(Model % BCs(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfMaterials
CALL ListTagCnt(Model % Materials(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfBodyForces
CALL ListTagCnt(Model % BodyForces(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfBodies
CALL ListTagCnt(Model % Bodies(i) % Values, tagwei, cnt )
END DO
IF(tagwei) THEN
IF(cnt>0) CALL Info('ListTagCount','Found number of normalized keywords: '//I2S(cnt),Level=6)
RETURN
END IF
CALL ListTagCnt(Model % Simulation, tagwei, cnt )
CALL ListTagCnt(Model % Constants, tagwei, cnt )
DO i=1,Model % NumberOfEquations
CALL ListTagCnt(Model % Equations(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfComponents
CALL ListTagCnt(Model % Components(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfICs
CALL ListTagCnt(Model % ICs(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfBoundaries
CALL ListTagCnt(Model % Boundaries(i) % Values, tagwei, cnt )
END DO
DO i=1,Model % NumberOfSolvers
CALL ListTagCnt(Model % Solvers(i) % Values, tagwei, cnt )
END DO
IF(cnt>0) CALL Info('ListTagCount','Found number of parameters: '//I2S(cnt),Level=6)
CONTAINS
SUBROUTINE ListTagCnt( list, tagwei, cnt )
TYPE(ValueList_t), POINTER :: list
LOGICAL :: tagwei
INTEGER :: cnt
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: m
IF(.NOT.ASSOCIATED(List)) RETURN
m = 0
Ptr => list % Head
DO WHILE( ASSOCIATED(ptr) )
IF( tagwei ) THEN
IF( ptr % disttag ) m = m + 1
ELSE
IF( ptr % partag > 0 ) m = m + 1
END IF
ptr => ptr % Next
END DO
IF( m > 0 ) THEN
CALL Info('ListTagParameters',&
'Tagged number of parameters in list: '//I2S(m),Level=15)
END IF
cnt = cnt + m
END SUBROUTINE ListTagCnt
END FUNCTION ListTagCount
SUBROUTINE ListSetParameters( Model, partag, val, mult, Found )
TYPE(Model_t) :: Model
INTEGER :: partag
REAL(KIND=dp) :: val
LOGICAL :: mult
LOGICAL :: Found
INTEGER :: i,cnt
TYPE(Mesh_t), POINTER :: Mesh
REAL(KIND=dp), POINTER :: Weights(:)
CALL Info('ListSetParameters',&
'Setting variation to parameter: '//I2S(partag),Level=12)
cnt = 0
Weights => NULL()
Mesh => Model % Mesh
DO i=1,Model % NumberOfBodies
Weights => Mesh % BodyWeight
CALL ListSetTagged(Model % Bodies(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfBodyForces
Weights => Mesh % BodyForceWeight
CALL ListSetTagged(Model % BodyForces(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfBCs
Weights => Mesh % BCWeight
CALL ListSetTagged(Model % BCs(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfMaterials
Weights => Mesh % MaterialWeight
CALL ListSetTagged(Model % Materials(i) % Values, partag, val, mult, cnt )
END DO
IF( partag > 0 ) THEN
CALL ListSetTagged(Model % Simulation, partag, val, mult, cnt )
CALL ListSetTagged(Model % Constants, partag, val, mult, cnt )
DO i=1,Model % NumberOfEquations
CALL ListSetTagged(Model % Equations(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfComponents
CALL ListSetTagged(Model % Components(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfICs
CALL ListSetTagged(Model % ICs(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfBoundaries
CALL ListSetTagged(Model % Boundaries(i) % Values, partag, val, mult, cnt )
END DO
DO i=1,Model % NumberOfSolvers
CALL ListSetTagged(Model % Solvers(i) % Values, partag, val, mult, cnt )
END DO
END IF
10 Found = ( cnt > 0 )
IF( Found ) THEN
CALL Info('ListSetParameters',&
'Scaled number of parameters: '//I2S(cnt),Level=6)
ELSE
CALL Warn('ListSetParameters','No parameters were altered!')
END IF
CONTAINS
SUBROUTINE ListSetTagged(list, partag, val, mult, cnt)
TYPE(ValueList_t), POINTER :: list
INTEGER :: partag
REAL(KIND=dp) :: val
LOGICAL :: mult
INTEGER :: cnt
TYPE(ValueListEntry_t), POINTER :: ptr
IF(.NOT.ASSOCIATED(List)) RETURN
ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
IF( partag == 0 ) THEN
IF( ptr % disttag ) THEN
IF(ASSOCIATED(Weights)) THEN
IF( Weights(i) > TINY(Weights(i)) ) THEN
ptr % coeff = 1.0_dp / Weights(i)
cnt = cnt + 1
WRITE( Message,'(A,ES12.3)') 'Scaling parameter "'//TRIM(ptr % name)//'" with:',ptr % coeff
CALL Info('ListSetParameters',Message,Level=15)
ELSE
CALL Warn('ListSetParameters','Refusing division with zero!')
END IF
END IF
END IF
ELSE IF(partag == ptr % partag ) THEN
IF( mult ) THEN
ptr % coeff = val * ptr % coeff
ELSE
ptr % coeff = val
END IF
cnt = cnt + 1
END IF
ptr => ptr % Next
END DO
END SUBROUTINE ListSetTagged
END SUBROUTINE ListSetParameters
SUBROUTINE ListEchoKeywords( Model )
TYPE(Model_t) :: Model
INTEGER :: i,cnt
CALL Info('ListEchoKeywords','Echoing parameters for debgging purposes')
CALL EchoList(Model % Simulation, 0, 'simulation' )
CALL EchoList(Model % Constants, 0, 'constants' )
DO i=1,Model % NumberOfEquations
CALL EchoList(Model % Equations(i) % Values, i, 'equation' )
END DO
DO i=1,Model % NumberOfBodies
CALL EchoList(Model % Bodies(i) % Values, i, 'body' )
END DO
DO i=1,Model % NumberOfBoundaries
CALL EchoList(Model % Boundaries(i) % Values, i, 'boundary' )
END DO
DO i=1,Model % NumberOfBodyForces
CALL EchoList(Model % BodyForces(i) % Values, i, 'body force' )
END DO
DO i=1,Model % NumberOfBCs
CALL EchoList(Model % BCs(i) % Values, i, 'boundary condition' )
END DO
DO i=1,Model % NumberOfMaterials
CALL EchoList(Model % Materials(i) % Values, i, 'material' )
END DO
DO i=1,Model % NumberOfComponents
CALL EchoList(Model % Components(i) % Values, i, 'component' )
END DO
DO i=1,Model % NumberOfICs
CALL EchoList(Model % ICs(i) % Values, i, 'initial condition' )
END DO
DO i=1,Model % NumberOfSolvers
CALL EchoList(Model % Solvers(i) % Values, i, 'solver ' )
END DO
CONTAINS
SUBROUTINE EchoList(list, i, section )
TYPE(ValueList_t), POINTER :: list
INTEGER :: i
CHARACTER(LEN=*) :: section
CHARACTER(LEN=MAX_NAME_LEN) :: str
TYPE(ValueListEntry_t), POINTER :: ptr
IF(.NOT.ASSOCIATED(List)) RETURN
ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
WRITE(str,'(A,ES12.3)') 'Real ',ptr % Coeff * ptr % Fvalues(1,1,1)
CASE( LIST_TYPE_LOGICAL )
IF( ptr % LValue ) THEN
str = 'Logical True'
ELSE
str = 'Logical False'
END IF
CASE( LIST_TYPE_INTEGER )
str = 'Integer '//I2S(ptr % Ivalues(1))
CASE DEFAULT
ptr => ptr % Next
CYCLE
END SELECT
IF( i==0 ) THEN
WRITE(*,'(A)') TRIM(Section)//' :: '//TRIM(ptr % Name)//' '//TRIM(str)
ELSE
WRITE(*,'(A)') TRIM(Section)//' '//I2S(i)//' :: '//TRIM(ptr % name)//' '//TRIM(str)
END IF
ptr => ptr % Next
END DO
END SUBROUTINE EchoList
END SUBROUTINE ListEchoKeywords
SUBROUTINE ListCopyItem( ptr, list, name )
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(ValueList_t), POINTER :: list
CHARACTER(LEN=*), OPTIONAL :: name
INTEGER :: i,j,k
TYPE(ValueListEntry_t), POINTER :: ptrb, ptrnext
IF( PRESENT( name ) ) THEN
ptrb => ListAdd( List, Name )
ELSE
ptrb => ListAdd( List, ptr % Name )
END IF
ptrnext => ptrb % next
ptrb = ptr
ptrb % tvalues => null()
if(associated(ptr % tvalues)) then
allocate( ptrb % tvalues(size(ptr % tvalues)) )
ptrb % tvalues = ptr % tvalues
end if
ptrb % fvalues => null()
if(associated(ptr % fvalues)) then
i = size(ptr % fvalues,1)
j = size(ptr % fvalues,2)
k = size(ptr % fvalues,3)
allocate( ptrb % fvalues(i,j,k) )
ptrb % fvalues = ptr % fvalues
end if
ptrb % ivalues => null()
if(associated(ptr % ivalues)) then
allocate( ptrb % ivalues(size(ptr % ivalues)) )
ptrb % ivalues = ptr % ivalues
end if
ptrb % cumulative => null()
if(associated(ptr % cumulative)) then
allocate( ptrb % cumulative(size(ptr % cumulative)) )
ptrb % cumulative = ptr % cumulative
end if
ptrb % next => ptrnext
IF( PRESENT( name ) ) THEN
ptrb % Name = name
ptrb % Namelen = lentrim( name )
END IF
#ifdef DEVEL_LISTCOUNTER
IF( ASSOCIATED( ptr ) ) THEN
ptr % Counter = ptr % Counter + 1
END IF
#endif
#ifdef DEVEL_LISTUSAGE
IF( ASSOCIATED( ptr ) ) THEN
ptr % Counter = 1
END IF
#endif
END SUBROUTINE ListCopyItem
SUBROUTINE ListCompareAndCopy( list, listb, name, Found, remove, nooverwrite)
TYPE(ValueList_t), POINTER :: list, listb
CHARACTER(LEN=*) :: name
LOGICAL, OPTIONAL :: Found
LOGICAL, OPTIONAL :: remove
LOGICAL, OPTIONAL :: nooverwrite
TYPE(ValueListEntry_t), POINTER :: ptr
CHARACTER(LEN=LEN_TRIM(Name)) :: str
INTEGER :: k, n
k = StringToLowerCase( str,Name,.TRUE. )
IF(PRESENT(Found)) Found = .FALSE.
IF(PRESENT(nooverwrite)) THEN
IF(nooverwrite) THEN
IF( ListCheckPresent( listb, str ) ) RETURN
END IF
END IF
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF ( n==k ) THEN
IF ( ptr % Name(1:n) == str(1:n) ) EXIT
END IF
ptr => ptr % Next
END DO
IF(.NOT. ASSOCIATED( ptr ) ) RETURN
CALL ListCopyItem( ptr, listb )
IF(PRESENT(Found)) Found = .TRUE.
IF( PRESENT(remove) ) THEN
IF( remove ) CALL ListRemove( list, name)
END IF
END SUBROUTINE ListCompareAndCopy
SUBROUTINE ListCopyPrefixedKeywords( list, listb, prefix )
TYPE(ValueList_t), POINTER :: list, listb
CHARACTER(LEN=*) :: prefix
TYPE(ValueListEntry_t), POINTER :: ptr
CHARACTER(LEN=LEN_TRIM(prefix)) :: str
INTEGER :: k, l, n, ncopy
k = StringToLowerCase( str,prefix,.TRUE. )
ncopy = 0
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
IF( n > k ) THEN
IF( ptr % Name(1:k) == str(1:k) ) THEN
l = k+1
IF( ptr % Name(l:l) == ' ') l = l+1
CALL Info('ListCopyPrefixedKeywords',&
'Prefix: '//TRIM(prefix)// ' Keyword: '//TRIM(ptr % Name(l:n)),Level=12)
CALL ListCopyItem( ptr, listb, ptr % Name(l:n) )
ncopy = ncopy + 1
END IF
END IF
ptr => ptr % Next
END DO
IF( ncopy > 0 ) THEN
CALL Info('ListCopyPrefixedKeywords',&
'Copied '//I2S(ncopy)//' keywords with prefix: '//TRIM(prefix),Level=6)
END IF
END SUBROUTINE ListCopyPrefixedKeywords
SUBROUTINE ListCopyAllKeywords( list, listb )
TYPE(ValueList_t), POINTER :: list, listb
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: ncopy
ncopy = 0
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
CALL ListCopyItem( ptr, listb, ptr % Name )
ncopy = ncopy + 1
ptr => ptr % Next
END DO
IF( ncopy > 0 ) THEN
CALL Info('ListCopyAllKeywords',&
'Copied '//I2S(ncopy)//' keywords to new list',Level=6)
END IF
END SUBROUTINE ListCopyAllKeywords
SUBROUTINE ListObsoleteWarn( List,OldName,NewName )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: OldName,NewName
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListFind(List,OldName,Found)
IF( Found ) THEN
CALL Warn('ListFatalObsolete',&
'Use keyword "'//TRIM(NewName)//'" instead of "'//TRIM(OldName)//'"')
END IF
END SUBROUTINE ListObsoleteWarn
SUBROUTINE ListObsoleteFatal( List,OldName,NewName )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: OldName,NewName
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListFind(List,OldName,Found)
IF( Found ) THEN
CALL Fatal('ListFatalObsolete',&
'Use keyword "'//TRIM(NewName)//'" instead of "'//TRIM(OldName)//'"')
END IF
END SUBROUTINE ListObsoleteFatal
SUBROUTINE ListUntreatedWarn( List, Name, Caller )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*), OPTIONAL :: Caller
IF( ListCheckPresent( List, Name ) ) THEN
IF( PRESENT( Caller ) ) THEN
CALL Warn(Caller,'Untreated keyword may cause problems: '//TRIM(Name))
ELSE
CALL Warn('ListUntreatedWarn','Untreated keyword may cause problems: '//TRIM(Name))
END IF
END IF
END SUBROUTINE ListUntreatedWarn
SUBROUTINE ListUntreatedFatal( List, Name, Caller )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*), OPTIONAL :: Caller
IF( ListCheckPresent( List, Name ) ) THEN
IF( PRESENT( Caller ) ) THEN
CALL Fatal(Caller,'Untreated keyword: '//TRIM(Name))
ELSE
CALL Fatal('ListUntreatedFatal','Untreated keyword: '//TRIM(Name))
END IF
END IF
END SUBROUTINE ListUntreatedFatal
FUNCTION ListCheckPrefix( List,Name ) RESULT(Found)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListFindPrefix(List,Name,Found)
END FUNCTION ListCheckPrefix
FUNCTION ListCheckPrefixAnyBC( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: bc
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO bc = 1,Model % NumberOfBCs
ptr => ListFindPrefix( Model % BCs(bc) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckPrefixAnyBC
FUNCTION ListCheckPrefixAnyBody( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: body_id
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO body_id = 1,Model % NumberOfBodies
ptr => ListFindPrefix( Model % Bodies(body_id) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckPrefixAnyBody
FUNCTION ListCheckPrefixAnyMaterial( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: mat_id
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO mat_id = 1,Model % NumberOfMaterials
ptr => ListFindPrefix( Model % Materials(mat_id) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckPrefixAnyMaterial
FUNCTION ListCheckPrefixAnyBodyForce( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: bf_id
TYPE(ValuelistEntry_t), POINTER :: ptr
Found = .FALSE.
DO bf_id = 1,Model % NumberOfBodyForces
ptr => ListFindPrefix( Model % BodyForces(bf_id) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckPrefixAnyBodyForce
SUBROUTINE ListAddString( List,Name,CValue,CaseConversion )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*) :: CValue
LOGICAL, OPTIONAL :: CaseConversion
INTEGER :: n
LOGICAL :: DoCase
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
DoCase = .TRUE.
IF ( PRESENT(CaseConversion) ) DoCase = CaseConversion
n = LEN_TRIM(Cvalue)
IF(ALLOCATED(ptr % Cvalue)) DEALLOCATE(ptr % Cvalue)
ALLOCATE(CHARACTER(n)::ptr % Cvalue)
IF ( DoCase ) THEN
n = StringToLowerCase( ptr % CValue,CValue )
ELSE
n = MIN( MAX_NAME_LEN,LEN(CValue) )
ptr % CValue = TRIM(Cvalue)
END IF
ptr % TYPE = LIST_TYPE_STRING
n = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(n)::ptr % Name)
ptr % NameLen = StringToLowerCase( Ptr % Name,Name )
END SUBROUTINE ListAddString
SUBROUTINE ListAddLogical( List,Name,LValue )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: LValue
INTEGER :: n
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
Ptr % LValue = LValue
Ptr % TYPE = LIST_TYPE_LOGICAL
n = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(n)::ptr % Name)
Ptr % NameLen = StringToLowerCase( ptr % Name,Name )
END SUBROUTINE ListAddLogical
SUBROUTINE ListAddInteger( List,Name,IValue,Proc )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: IValue
INTEGER(Kind=AddrInt), OPTIONAL :: Proc
INTEGER :: n
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
ALLOCATE( ptr % IValues(1) )
ptr % IValues(1) = IValue
ptr % TYPE = LIST_TYPE_INTEGER
n = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(n)::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
END SUBROUTINE ListAddInteger
SUBROUTINE ListAddIntegerArray( List,Name,Nv,IValues,Proc )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: Nv
INTEGER :: IValues(Nv)
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
INTEGER :: n
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
ALLOCATE( ptr % IValues(Nv) )
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
ptr % TYPE = LIST_TYPE_INTEGER
ptr % IValues(1:nv) = IValues(1:nv)
n = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(n)::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
END SUBROUTINE ListAddIntegerArray
SUBROUTINE ListAddConstReal( List,Name,FValue,Proc,CValue )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*), OPTIONAL :: Cvalue
REAL(KIND=dp) :: FValue
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
INTEGER :: n
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
NULLIFY( ptr % TValues )
ALLOCATE( ptr % FValues(1,1,1) )
ptr % FValues = FValue
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR
IF ( PRESENT(Proc) ) THEN
ptr % PROCEDURE = Proc
IF( Proc /= 0 ) THEN
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_PROC
END IF
END IF
IF ( PRESENT( CValue ) ) THEN
ptr % Cvalue = TRIM(CValue)
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_STR
END IF
n = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(n)::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
END SUBROUTINE ListAddConstReal
SUBROUTINE ListAddDepReal(List,Name,DependName,N,TValues, &
FValues,Proc,CValue,CubicTable, Monotone, Harmonic)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name,DependName
CHARACTER(LEN=*), OPTIONAL :: Cvalue
INTEGER :: N
LOGICAL, OPTIONAL :: CubicTable, Monotone, Harmonic
REAL(KIND=dp) :: FValues(N)
REAL(KIND=dp) :: TValues(N)
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
INTEGER :: l
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
ALLOCATE( ptr % FValues(1,1,n),ptr % TValues(n) )
IF( .NOT. CheckMonotone( n, TValues ) ) THEN
CALL Fatal('ListAddDepReal',&
'Values x in > '//TRIM(Name)//' < not monotonically ordered!')
END IF
ptr % TValues = TValues(1:n)
ptr % FValues(1,1,:) = FValues(1:n)
ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR
IF(PRESENT(harmonic)) THEN
IF(Harmonic) THEN
CALL ConvertTableToHarmonic(n, ptr % TValues,ptr % Fvalues(1,1,:))
END IF
END IF
IF ( n>3 .AND. PRESENT(CubicTable)) THEN
IF ( CubicTable ) THEN
ALLOCATE(ptr % CubicCoeff(n))
CALL CubicSpline(n,ptr % TValues,Ptr % Fvalues(1,1,:), &
Ptr % CubicCoeff, Monotone )
END IF
END IF
ALLOCATE(ptr % Cumulative(n))
CALL CumulativeIntegral(ptr % TValues, Ptr % FValues(1,1,:), &
Ptr % CubicCoeff, Ptr % Cumulative )
l = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(l)::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
l = LEN_TRIM(DependName)
IF(ALLOCATED(ptr % DependName)) DEALLOCATE(ptr % DependName)
ALLOCATE(CHARACTER(l)::ptr % DependName)
ptr % DepNameLen = StringToLowerCase( ptr % DependName,DependName )
IF ( PRESENT( Cvalue ) ) THEN
ptr % CValue = CValue
ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR_STR
END IF
END SUBROUTINE ListAddDepReal
SUBROUTINE ListAddConstRealArray( List,Name,N,M,FValues,Proc,CValue )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*), OPTIONAL :: Cvalue
INTEGER :: N,M
REAL(KIND=dp) :: FValues(:,:)
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
INTEGER :: l
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
NULLIFY( ptr % TValues )
ALLOCATE( ptr % FValues(N,M,1) )
ptr % Fdim = 0
IF( N > 1 ) ptr % Fdim = 1
IF( M > 1 ) ptr % Fdim = ptr % Fdim + 1
IF( ptr % Fdim == 0 ) THEN
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR
ELSE
ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR
END IF
ptr % FValues(1:n,1:m,1) = FValues(1:n,1:m)
IF ( PRESENT(Proc) ) THEN
ptr % PROCEDURE = Proc
END IF
IF ( PRESENT( Cvalue ) ) THEN
ptr % CValue = CValue
IF( ptr % Fdim == 0 ) THEN
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_STR
ELSE
ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR_STR
END IF
END IF
l = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(l)::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
END SUBROUTINE ListAddConstRealArray
SUBROUTINE ListAddDepRealArray(List,Name,DependName, &
ni,TValues,n,m,FValues,Proc,Cvalue)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name,DependName
CHARACTER(LEN=*), OPTIONAL :: Cvalue
INTEGER :: ni,n,m
REAL(KIND=dp) :: FValues(:,:,:)
REAL(KIND=dp) :: TValues(ni)
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
INTEGER :: l
TYPE(ValueListEntry_t), POINTER :: ptr
ptr => ListAdd( List, Name )
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
ALLOCATE( ptr % FValues(n,m,ni),ptr % TValues(ni) )
ptr % TValues = TValues(1:ni)
ptr % FValues = FValues(1:n,1:m,1:ni)
ptr % TYPE = LIST_TYPE_VARIABLE_TENSOR
ptr % fdim = 0
IF( n > 1 ) ptr % fdim = 1
IF( m > 1 ) ptr % fdim = ptr % fdim + 1
IF ( PRESENT( Cvalue ) ) THEN
ptr % CValue = CValue
ptr % TYPE = LIST_TYPE_VARIABLE_TENSOR_STR
END IF
l = LEN_TRIM(Name)
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
ALLOCATE(CHARACTER(l)::ptr % Name)
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
l = LEN_TRIM(DependName)
IF(ALLOCATED(ptr % DependName)) DEALLOCATE(ptr % DependName)
ALLOCATE(CHARACTER(l)::ptr % DependName)
ptr % DepNameLen = StringToLowerCase( ptr % DependName,DependName )
END SUBROUTINE ListAddDepRealArray
SUBROUTINE ListRealArrayToDepReal(List,Name,DepName,CubicTable,Monotone)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*) :: DepName
LOGICAL, OPTIONAL :: CubicTable, Monotone
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: n,m, l
REAL(KIND=dp), ALLOCATABLE :: TmpValues(:,:,:)
ptr => ListFind( List, Name )
IF( ptr % TYPE /= LIST_TYPE_CONSTANT_TENSOR ) RETURN
IF(.NOT. ASSOCIATED(ptr) ) THEN
CALL Warn('ListRealArrayToDepArray','Could not find: '//TRIM(Name))
RETURN
END IF
IF( ptr % Fdim < 2 ) THEN
CALL Warn('ListRealArrayToDepArray','No array form to transform!')
RETURN
END IF
n = SIZE(ptr % FValues,1)
m = SIZE(ptr % FValues,2)
IF( m /= 2 ) THEN
CALL Warn('ListRealArrayToDepArray','Number of columns must be 2!')
RETURN
END IF
ALLOCATE( TmpValues(n,m,1) )
TmpValues = ptr % FValues
DEALLOCATE( ptr % FValues )
ALLOCATE( ptr % FValues(1,1,n), ptr % TValues(n) )
ptr % FValues(1,1,1:n) = TmpValues(1:n,2,1)
ptr % TValues(1:n) = TmpValues(1:n,1,1)
DEALLOCATE( TmpValues )
IF( .NOT. CheckMonotone( n, ptr % FValues(1,1,:) ) ) THEN
CALL Fatal('ListRealArrayToDepReal',&
'Values x in > '//TRIM(Name)//' < not monotonically ordered!')
END IF
IF ( n>3 .AND. PRESENT(CubicTable)) THEN
IF ( CubicTable ) THEN
ALLOCATE(ptr % CubicCoeff(n))
CALL CubicSpline(n,ptr % TValues,Ptr % Fvalues(1,1,:), &
Ptr % CubicCoeff, Monotone )
END IF
END IF
ALLOCATE(ptr % Cumulative(n))
CALL CumulativeIntegral(ptr % TValues, Ptr % FValues(1,1,:), &
Ptr % CubicCoeff, Ptr % Cumulative )
l = LEN_TRIM(DepName)
IF(ALLOCATED(ptr % DependName)) DEALLOCATE(ptr % DependName)
ALLOCATE(CHARACTER(l)::ptr % DependName)
ptr % DepNameLen = StringToLowerCase( ptr % DependName,DepName )
ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR
CALL Info('ListRealArrayToDepReal',&
'Changed constant array to dependence table of size '//I2S(n)//'!')
END SUBROUTINE ListRealArrayToDepReal
SUBROUTINE ListAddNewLogical( List,Name,LValue )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: LValue
TYPE(ValueListEntry_t), POINTER :: ptr
IF( ListCheckPresent( List, Name ) ) RETURN
CALL ListAddLogical( List,Name,LValue )
END SUBROUTINE ListAddNewLogical
SUBROUTINE ListAddNewInteger( List,Name,IValue,Proc )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: IValue
INTEGER(Kind=AddrInt), OPTIONAL :: Proc
TYPE(ValueListEntry_t), POINTER :: ptr
IF( ListCheckPresent( List, Name ) ) RETURN
CALL ListAddInteger( List,Name,IValue,Proc )
END SUBROUTINE ListAddNewInteger
SUBROUTINE ListAddNewConstReal( List,Name,FValue,Proc,CValue )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*), OPTIONAL :: Cvalue
REAL(KIND=dp) :: FValue
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
TYPE(ValueListEntry_t), POINTER :: ptr
IF( ListCheckPresent( List, Name ) ) RETURN
CALL ListAddConstReal( List,Name,FValue,Proc,CValue )
END SUBROUTINE ListAddNewConstReal
SUBROUTINE ListAddNewString( List,Name,CValue,CaseConversion )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
CHARACTER(LEN=*) :: CValue
LOGICAL, OPTIONAL :: CaseConversion
IF( ListCheckPresent( List, Name ) ) RETURN
CALL ListAddString( List,Name,CValue,CaseConversion )
END SUBROUTINE ListAddNewString
RECURSIVE FUNCTION ListGetInteger( List,Name,Found,minv,maxv,UnfoundFatal,DefValue) RESULT(L)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER, OPTIONAL :: DefValue
INTEGER :: L
LOGICAL, OPTIONAL :: Found, UnfoundFatal
INTEGER, OPTIONAL :: minv,maxv
TYPE(ValueListEntry_t), POINTER :: ptr
IF(PRESENT(DefValue)) THEN
L = DefValue
ELSE
L = 0
END IF
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
WRITE(Message, '(A,A)') "Failed to find integer: ",Name
CALL Fatal("ListGetInteger", Message)
END IF
END IF
RETURN
END IF
IF( ptr % type /= LIST_TYPE_INTEGER ) THEN
CALL Fatal('ListGetInteger','Invalid list type for: '//TRIM(Name))
END IF
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ListPushActiveName(Name)
L = ExecIntFunction( ptr % PROCEDURE, CurrentModel )
CALL ListPopActiveName()
ELSE
IF ( .NOT. ASSOCIATED(ptr % IValues) ) THEN
CALL Fatal( 'ListGetInteger', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
L = ptr % IValues(1)
END IF
IF ( PRESENT( minv ) ) THEN
IF ( L < minv ) THEN
WRITE( Message, '(A,I0,A,I0)') 'Given value ',L,' for property: ['//TRIM(Name)//&
'] smaller than given minimum: ', minv
CALL Fatal( 'ListGetInteger', Message )
END IF
END IF
IF ( PRESENT( maxv ) ) THEN
IF ( L > maxv ) THEN
WRITE( Message, '(A,I0,A,I0)') 'Given value ',L,' for property: ['//TRIM(Name)//&
'] larger than given maximum: ', maxv
CALL Fatal( 'ListGetInteger', Message )
END IF
END IF
END FUNCTION ListGetInteger
RECURSIVE FUNCTION ListGetIntegerArray( List,Name,Found,UnfoundFatal ) RESULT( IValues )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found, UnfoundFatal
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: i,n
INTEGER, POINTER :: IValues(:)
NULLIFY( IValues )
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
WRITE(Message, '(A,A)') "Failed to find integer array: ",Name
CALL Fatal("ListGetIntegerArray", Message)
END IF
END IF
RETURN
END IF
IF ( .NOT. ASSOCIATED(ptr % IValues) ) THEN
CALL Fatal( 'ListGetIntegerArray', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
n = SIZE(ptr % IValues)
IValues => Ptr % IValues(1:n)
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ListPushActiveName(Name)
IValues = 0
DO i=1,N
Ivalues(i) = ExecIntFunction( ptr % PROCEDURE, CurrentModel )
END DO
CALL ListPopActiveName()
END IF
END FUNCTION ListGetIntegerArray
RECURSIVE FUNCTION ListCheckIsArray( List,Name,Found ) RESULT( IsArray )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found
LOGICAL :: IsArray
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: n
ptr => ListFind(List,Name,Found)
IsArray = .FALSE.
IF(.NOT. ASSOCIATED( ptr ) ) RETURN
n = 0
IF ( ASSOCIATED(ptr % IValues) ) THEN
n = SIZE(ptr % IValues)
END IF
IF( ASSOCIATED( ptr % FValues ) ) THEN
n = SIZE(ptr % FValues)
END IF
IsArray = ( n > 1 )
END FUNCTION ListCheckIsArray
RECURSIVE FUNCTION ListGetLogical( List,Name,Found,UnfoundFatal,DefValue ) RESULT(L)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: L
LOGICAL, OPTIONAL :: Found, UnfoundFatal, DefValue
TYPE(ValueListEntry_t), POINTER :: ptr
IF(PRESENT(DefValue)) THEN
L = DefValue
ELSE
L = .FALSE.
END IF
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
WRITE(Message, '(A,A)') "Failed to find logical: ",Name
CALL Fatal("ListGetLogical", Message)
END IF
END IF
RETURN
END IF
IF(ptr % TYPE == LIST_TYPE_LOGICAL ) THEN
L = ptr % Lvalue
ELSE
CALL Fatal('ListGetLogical','Invalid list type for: '//TRIM(Name))
END IF
END FUNCTION ListGetLogical
RECURSIVE FUNCTION ListGetLogicalGen( List, Name) RESULT(L)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL :: L
TYPE(ValueListEntry_t), POINTER :: ptr
LOGICAL :: Found
REAL(KIND=dp) :: Rval
L = .FALSE.
ptr => ListFind(List,Name,Found)
IF ( .NOT. ASSOCIATED(ptr) ) RETURN
IF(ptr % TYPE == LIST_TYPE_LOGICAL ) THEN
L = ptr % Lvalue
ELSE IF ( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_STR .OR. &
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN
RVal = ListGetConstReal( List, Name )
L = ( RVal > 0.0_dp )
ELSE
L = .TRUE.
END IF
END FUNCTION ListGetLogicalGen
RECURSIVE FUNCTION ListGetString( List,Name,Found,UnfoundFatal,DefValue ) RESULT(S)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found,UnfoundFatal
CHARACTER(:), ALLOCATABLE :: S
CHARACTER(*), OPTIONAL :: DefValue
TYPE(ValueListEntry_t), POINTER :: ptr
S = ' '
IF(PRESENT(DefValue)) S = TRIM(DefValue)
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
WRITE(Message, '(A,A)') "Failed to find string: ",Name
CALL Fatal("ListGetString", Message)
END IF
END IF
RETURN
END IF
IF( ptr % Type == LIST_TYPE_STRING ) THEN
S = TRIM(ptr % Cvalue)
ELSE
CALL Fatal('ListGetString','Invalid list type: '//TRIM(Name))
END IF
END FUNCTION ListGetString
RECURSIVE FUNCTION ListGetConstReal( List,Name,Found,x,y,z,minv,maxv,UnfoundFatal,DefValue) RESULT(F)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
REAL(KIND=dp) :: F
LOGICAL, OPTIONAL :: Found,UnfoundFatal
REAL(KIND=dp), OPTIONAL :: x,y,z,DefValue
REAL(KIND=dp), OPTIONAL :: minv,maxv
TYPE(Variable_t), POINTER :: Variable
TYPE(ValueListEntry_t), POINTER :: ptr
REAL(KIND=dp) :: xx,yy,zz
INTEGER :: i,j,k,n
IF(PRESENT(DefValue)) THEN
F = DefValue
ELSE
F = 0.0_dp
END IF
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
WRITE(Message, '(A,A)') "Failed to find constant real: ",Name
CALL Fatal("ListGetConstReal", Message)
END IF
END IF
RETURN
END IF
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetConstReal', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
F = ptr % Coeff * ptr % Fvalues(1,1,1)
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
F = ptr % Coeff * GetMatcReal(ptr % Cvalue)
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE == 0 ) THEN
CALL Fatal( 'ListGetConstReal', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
xx = 0.0_dp
yy = 0.0_dp
zz = 0.0_dp
IF ( PRESENT(x) ) xx = x
IF ( PRESENT(y) ) yy = y
IF ( PRESENT(z) ) zz = z
CALL ListPushActiveName(Name)
F = Ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,xx,yy,zz )
CALL ListPopActiveName()
CASE( LIST_TYPE_VARIABLE_SCALAR, LIST_TYPE_VARIABLE_SCALAR_STR )
CALL Fatal('ListGetConstReal','Constant cannot depend on variables: '//TRIM(Name))
CASE DEFAULT
CALL Fatal('ListGetConstReal','Invalid list type for: '//TRIM(Name))
END SELECT
IF ( PRESENT( minv ) ) THEN
IF ( F < minv ) THEN
WRITE( Message, *) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', &
' smaller than given minimum: ', minv
CALL Fatal( 'ListGetInteger', Message )
END IF
END IF
IF ( PRESENT( maxv ) ) THEN
IF ( F > maxv ) THEN
WRITE( Message, *) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', &
' larger than given maximum: ', maxv
CALL Fatal( 'ListGetInteger', Message )
END IF
END IF
END FUNCTION ListGetConstReal
RECURSIVE FUNCTION ListGetCReal( List, Name, Found, minv, maxv, UnfoundFatal, DefValue ) RESULT(s)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
REAL(KIND=dp), OPTIONAL :: minv,maxv
LOGICAL, OPTIONAL :: Found,UnfoundFatal
INTEGER, TARGET :: Dnodes(1)
INTEGER, POINTER :: NodeIndexes(:)
REAL(KIND=dp), OPTIONAL :: DefValue
REAL(KIND=dp) :: s
REAL(KIND=dp) :: x(1)
TYPE(Element_t), POINTER :: Element
LOGICAL :: LFound
INTEGER :: n, istat
LFound = .FALSE.
NodeIndexes => Dnodes
n = 1
NodeIndexes(n) = 1
x = 0.0_dp
IF ( ASSOCIATED(List % head) ) THEN
x(1:n) = ListGetReal( List, Name, n, NodeIndexes, LFound, minv=minv, maxv=maxv, &
UnfoundFatal=UnfoundFatal )
END IF
s = x(1)
IF( PRESENT( DefValue ) ) THEN
IF(.NOT. LFound ) s = DefValue
END IF
IF ( PRESENT( Found ) ) Found = LFound
END FUNCTION ListGetCReal
RECURSIVE FUNCTION ListGetRealAtNode( List, Name, Node, Found, UnfoundFatal ) RESULT(s)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: Node
LOGICAL, OPTIONAL :: Found, UnfoundFatal
REAL(KIND=dp) :: s
INTEGER, TARGET, SAVE :: Dnodes(1)
INTEGER, POINTER :: NodeIndexes(:)
REAL(KIND=dp) :: x(1)
INTEGER, PARAMETER :: one = 1
IF ( PRESENT( Found ) ) Found = .FALSE.
IF ( ASSOCIATED(List % Head) ) THEN
NodeIndexes => Dnodes
NodeIndexes(one) = Node
x(1:one) = ListGetReal( List, Name, one, NodeIndexes, Found, UnfoundFatal=UnfoundFatal)
s = x(one)
ELSE
s = 0.0_dp
END IF
END FUNCTION ListGetRealAtNode
FUNCTION ListGetSection( Element, SectionName, Found ) RESULT(lst)
TYPE(ValueList_t), POINTER :: Lst
CHARACTER(LEN=*) :: SectionName
LOGICAL, OPTIONAL :: Found
TYPE(Element_t) :: Element
TYPE(ValueList_t), POINTER :: BodyLst
INTEGER :: id
LOGICAL :: LFound
id = Element % BodyId
IF( id > 0 ) THEN
bodylst => CurrentModel % Bodies(id) % Values
ELSE
NULLIFY( bodylst )
END IF
LFound = .FALSE.
NULLIFY( lst )
SELECT CASE ( SectionName )
CASE( 'body' )
lst => bodylst
Lfound = ASSOCIATED( lst )
CASE( 'material' )
id = ListGetInteger( bodylst, SectionName, LFound )
IF( LFound ) lst => CurrentModel % Materials(id) % Values
CASE( 'body force' )
id = ListGetInteger( bodylst, SectionName, LFound )
IF( LFound ) lst => CurrentModel % BodyForces(id) % Values
CASE( 'initial condition' )
id = ListGetInteger( bodylst, SectionName, LFound )
IF( LFound ) lst => CurrentModel % ICs(id) % Values
CASE( 'equation' )
id = ListGetInteger( bodylst, SectionName, LFound )
IF( LFound ) lst => CurrentModel % Equations(id) % Values
CASE( 'boundary condition' )
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
id = Element % BoundaryInfo % Constraint
IF( id > 0 ) THEN
lst => CurrentModel % BCs(id) % Values
LFound = .TRUE.
END IF
END IF
CASE DEFAULT
CALL Fatal('ListGetSection','Unknown section name: '//TRIM(SectionName))
END SELECT
IF( PRESENT( Found ) ) Found = LFound
END FUNCTION ListGetSection
SUBROUTINE ListWarnUnsupportedKeyword( SectionName, Keyword, Found, FatalFound )
CHARACTER(LEN=*) :: SectionName, Keyword
LOGICAL, OPTIONAL :: Found, FatalFound
LOGICAL :: LFound, LFatal
INTEGER :: k
CHARACTER(LEN=LEN(SectionName)) :: str
k = StringToLowerCase( str,SectionName )
LFatal = .FALSE.
IF( PRESENT( FatalFound ) ) LFatal = FatalFound
SELECT CASE ( str )
CASE( 'body' )
LFound = ListCheckPresentAnyBody( CurrentModel, Keyword )
CASE( 'material' )
LFound = ListCheckPresentAnyMaterial( CurrentModel, Keyword )
CASE( 'body force' )
LFound = ListCheckPresentAnyBodyForce( CurrentModel, Keyword )
CASE( 'solver' )
LFound = ListCheckPresentAnySolver( CurrentModel, Keyword )
CASE( 'equation' )
LFound = ListCheckPresentAnyEquation( CurrentModel, Keyword )
CASE( 'boundary condition' )
LFound = ListCheckPresentAnyBC( CurrentModel, Keyword )
CASE( 'simulation' )
LFound = ListCheckPresent( CurrentModel % Simulation, Keyword )
CASE( 'constants' )
LFound = ListCheckPresent( CurrentModel % Constants, Keyword )
CASE DEFAULT
CALL Fatal('ListWarnUnsupportedKeyword',&
'Unknown section for "'//TRIM(Keyword)//'": '//TRIM(SectionName))
END SELECT
IF( LFound ) THEN
IF( LFatal ) THEN
CALL Fatal('ListWarnUnsupportedKeyword',&
'Keyword in section "'//TRIM(SectionName)//'" not supported: '//TRIM(Keyword) )
ELSE
CALL Warn('ListWarnUnsupportedKeyword',&
'Keyword in section "'//TRIM(SectionName)//'" not supported: '//TRIM(Keyword) )
END IF
END IF
IF( PRESENT( Found ) ) Found = LFound
END SUBROUTINE ListWarnUnsupportedKeyword
FUNCTION ListGetSectionId( Element, SectionName, Found ) RESULT(id)
INTEGER :: id
CHARACTER(LEN=*) :: SectionName
LOGICAL, OPTIONAL :: Found
TYPE(Element_t) :: Element
TYPE(ValueList_t), POINTER :: BodyLst
INTEGER :: body_id
LOGICAL :: LFound
id = 0
body_id = Element % BodyId
IF( body_id > 0 ) THEN
bodylst => CurrentModel % Bodies(body_id) % Values
ELSE
NULLIFY( bodylst )
END IF
LFound = .FALSE.
SELECT CASE ( SectionName )
CASE( 'body' )
id = body_id
CASE( 'material' )
id = ListGetInteger( bodylst, SectionName, LFound )
CASE( 'body force' )
id = ListGetInteger( bodylst, SectionName, LFound )
CASE( 'initial condition' )
id = ListGetInteger( bodylst, SectionName, LFound )
CASE( 'equation' )
id = ListGetInteger( bodylst, SectionName, LFound )
CASE( 'boundary condition' )
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
id = Element % BoundaryInfo % Constraint
END IF
CASE DEFAULT
CALL Fatal('ListGetSection','Unknown section name: '//TRIM(SectionName))
END SELECT
IF( PRESENT( Found ) ) Found = ( id > 0 )
END FUNCTION ListGetSectionId
SUBROUTINE ListParseStrToVars( str, slen, name, count, VarTable, &
SomeAtIp, SomeAtNodes, AllGlobal, DummyCount, List )
CHARACTER(LEN=*) :: str, name
INTEGER :: slen, count
TYPE(VariableTable_t) :: VarTable(:)
LOGICAL :: SomeAtIp, SomeAtNodes, AllGlobal
INTEGER :: DummyCount
TYPE(ValueList_t), POINTER, OPTIONAL :: List
INTEGER :: i,j,k,n,k1,l,l0,l1
TYPE(Variable_t), POINTER :: Var
REAL(KIND=dp) :: Val
LOGICAL :: Found
TYPE(ValueListEntry_t), POINTER :: ptr
SomeAtIp = .FALSE.
SomeAtNodes = .FALSE.
AllGlobal = .TRUE.
count=0
l0=1
IF(slen<=0) RETURN
DO WHILE( .TRUE. )
DO WHILE( str(l0:l0) == ' ' )
l0 = l0 + 1
IF ( l0 > slen ) EXIT
END DO
IF ( l0 > slen ) EXIT
l1 = INDEX( str(l0:slen),',')
IF ( l1 > 0 ) THEN
l1=l0+l1-2
ELSE
l1=slen
END IF
IF( count < DummyCount ) THEN
Var => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) )
IF(ASSOCIATED(Var)) THEN
CALL Fatal('ListParseStrToVars','Function has '//I2S(DummyCount)//&
' internal variables, use dummy names not: '//str(l0:l1))
END IF
AllGlobal = .FALSE.
count = count + 1
SomeAtIp = .TRUE.
VarTable(count) % Variable => NULL()
VarTable(count) % ParamValue = -1.0_dp
ELSE IF ( str(l0:l1) == 'coordinate' ) THEN
VarTable(count+1) % Variable => VariableGet( CurrentModel % Variables,"coordinate 1")
VarTable(count+2) % Variable => VariableGet( CurrentModel % Variables,"coordinate 2")
VarTable(count+3) % Variable => VariableGet( CurrentModel % Variables,"coordinate 3")
count = count + 3
SomeAtNodes = .TRUE.
AllGlobal = .FALSE.
ELSE
Found = .FALSE.
Var => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) )
count = count + 1
IF ( ASSOCIATED( Var ) ) THEN
VarTable(count) % Variable => Var
IF( SIZE( Var % Values ) > Var % Dofs ) AllGlobal = .FALSE.
IF( Var % TYPE == Variable_on_gauss_points ) THEN
SomeAtIp = .TRUE.
ELSE
SomeAtNodes = .TRUE.
END IF
Found = .TRUE.
ELSE IF(l1-l0 > 5) THEN
IF(str(l0:l0+4) == 'prev ') THEN
Var => VariableGet( CurrentModel % Variables,TRIM(str(l0+5:l1)) )
IF( ASSOCIATED( Var ) ) THEN
VarTable(count) % Variable => Var
VarTable(count) % tstep = -1
IF( SIZE( Var % Values ) > Var % Dofs ) AllGlobal = .FALSE.
IF( Var % TYPE == Variable_on_gauss_points ) THEN
SomeAtIp = .TRUE.
ELSE
SomeAtNodes = .TRUE.
END IF
Found = .TRUE.
END IF
END IF
END IF
IF(.NOT. Found) THEN
IF( VERIFY( str(l0:l1),'-.0123456789eE') == 0 ) THEN
READ(str(l0:l1),*) Val
VarTable(count) % Variable => NULL()
VarTable(count) % ParamValue = Val
ELSE
Found = .FALSE.
IF(PRESENT(List) ) THEN
ptr => ListFind(List,str(l0:l1),Found)
END IF
IF( Found ) THEN
VarTable(count) % Keyword => ptr
AllGlobal = .FALSE.
SomeAtNodes = .TRUE.
ELSE
CALL Info('ListParseStrToVars','Parsed variable '//I2S(count)//' of '//str(1:slen),Level=3)
CALL Info('ListParseStrToVars','Parse counters: '&
//I2S(l0)//', '//I2S(l1)//', '//I2S(slen),Level=10)
CALL Fatal('ListParseStrToVars', 'Can''t find independent variable:['// &
TRIM(str(l0:l1))//'] for dependent variable:['//TRIM(Name)//']' )
END IF
END IF
END IF
END IF
l0 = l1+2
IF ( l0 > slen ) EXIT
END DO
END SUBROUTINE ListParseStrToVars
RECURSIVE SUBROUTINE VarsToValuesOnNodes( VarCount, VarTable, ind, T, count, intvarcount, tStep )
INTEGER :: Varcount
TYPE(VariableTable_t) :: VarTable(:)
INTEGER :: ind
INTEGER :: count
INTEGER, OPTIONAL :: intvarcount
INTEGER, OPTIONAL :: tstep
REAL(KIND=dp) :: T(:)
TYPE(Element_t), POINTER :: Element
INTEGER :: i,j,k,n,k1,l,varsize,vari,vari0,tstep0,dti
TYPE(Variable_t), POINTER :: Var
LOGICAL :: Failed
REAL(KIND=dp), POINTER :: Values(:)
Failed = .FALSE.
vari0 = 0
IF(PRESENT(intvarcount)) vari0 = IntVarCount
count = vari0
tstep0 = 0
IF(PRESENT(tstep)) tstep0 = tstep
DO Vari = vari0+1, VarCount
Var => VarTable(Vari) % Variable
dti = -(tstep0 + VarTable(Vari) % tstep)
IF(.NOT. ASSOCIATED( Var ) ) THEN
count = count + 1
IF(ASSOCIATED( VarTable(Vari) % Keyword ) ) THEN
T(count) = ListGetRealInside( VarTable(Vari) % Keyword,'',ind)
ELSE
T(count) = VarTable(Vari) % ParamValue
END IF
CYCLE
END IF
Varsize = SIZE( Var % Values ) / Var % Dofs
IF( Varsize == 1 ) THEN
DO l=1,Var % DOFs
count = count + 1
T(count) = Var % Values(l)
END DO
ELSE
k1 = ind
IF ( Var % TYPE == Variable_on_gauss_points ) THEN
count = count + Var % DOFs
CYCLE
ELSE IF( Var % TYPE == Variable_on_elements ) THEN
Element => CurrentModel % CurrentElement
IF( ASSOCIATED( Element ) ) THEN
k1 = Element % ElementIndex
ELSE
CALL Fatal('VarsToValuesOnNodes','CurrentElement not associated!')
END IF
ELSE IF ( Var % TYPE == Variable_on_nodes_on_elements ) THEN
Element => CurrentModel % CurrentElement
IF ( ASSOCIATED(Element) ) THEN
k1 = 0
IF ( ASSOCIATED(Element % DGIndexes) ) THEN
n = SIZE(Element % DGIndexes)
DO i=1,n
IF ( Element % NodeIndexes(i)==ind ) THEN
k1 = Element % DGIndexes(i)
EXIT
END IF
END DO
ELSE IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
BLOCK
TYPE(Element_t), POINTER :: Parent
DO j=1,2
IF(j==1) THEN
Parent => Element % BoundaryInfo % Left
ELSE
Parent => Element % BoundaryInfo % Right
END IF
DO i=1,Parent % TYPE % NumberOfNodes
IF( Parent % NodeIndexes(i) == ind) THEN
k1 = Parent % DGIndexes(i)
EXIT
END IF
END DO
IF( k1 > 0 ) THEN
IF(Var % Perm(k1) > 0) EXIT
END IF
END DO
END BLOCK
END IF
IF( k1 == 0 ) THEN
CALL Fatal('VarsToValueOnNodes','Could not find index '//I2S(ind)//&
' in element '//I2S(Element % ElementIndex)//' for '//TRIM(Var % Name))
END IF
ELSE
CALL Fatal('VarsToValuesOnNodes','CurrentElement not associated!')
END IF
END IF
IF ( ASSOCIATED(Var % Perm) ) k1 = Var % Perm(k1)
IF ( k1 > 0 .AND. k1 <= VarSize ) THEN
Values => Var % Values
IF( dti > 0 ) THEN
IF ( ASSOCIATED(Var % PrevValues) ) THEN
IF ( dti <= SIZE(Var % PrevValues,2)) &
Values => Var % PrevValues(:,dti)
END IF
END IF
DO l=1,Var % DOFs
count = count + 1
T(count) = Values(Var % Dofs*(k1-1)+l)
END DO
ELSE
Failed = .TRUE.
DO l=1,Var % DOFs
count = count + 1
T(count) = HUGE(1.0_dp)
END DO
RETURN
END IF
END IF
END DO
END SUBROUTINE VarsToValuesOnNodes
SUBROUTINE VarsToValuesOnNodesWhich( VarCount, VarTable, IsNodalVar, count )
INTEGER :: Varcount
TYPE(VariableTable_t) :: VarTable(:)
INTEGER :: count
LOGICAL :: IsNodalVar(:)
INTEGER :: vari
TYPE(Variable_t), POINTER :: Var
LOGICAL :: Failed
count = 0
DO Vari = 1, VarCount
Var => VarTable(Vari) % Variable
IF(.NOT. ASSOCIATED( Var ) ) THEN
count = count + 1
IsNodalVar(count) = .FALSE.
ELSE IF( SIZE(Var % Values) / Var % Dofs == 1 ) THEN
IsNodalVar(count+1:count+var % dofs) = .FALSE.
count = count + var % dofs
ELSE
IF ( Var % TYPE == Variable_on_gauss_points ) THEN
IsNodalVar(count+1:count+var%dofs) = .FALSE.
count = count + Var % DOFs
ELSE
IsNodalVar(count+1:count+var%dofs) = .TRUE.
count = count + Var % DOFs
END IF
END IF
END DO
END SUBROUTINE VarsToValuesOnNodesWhich
FUNCTION InterpolateIPVariableToBoundary( Element, Basis, Var, dof ) RESULT ( T )
TYPE(Element_t), POINTER :: Element
REAL(KIND=dp) :: Basis(:)
TYPE(Variable_t), POINTER :: Var
INTEGER, OPTIONAL :: dof
REAL(KIND=dp) :: T
TYPE(Element_t), POINTER :: Parent
INTEGER :: ipar, npar, i, j, n, np, nip, dofs
REAL(KIND=dp), ALLOCATABLE :: fip(:),fdg(:)
INTERFACE
SUBROUTINE Ip2DgFieldInElement( Mesh, Parent, nip, fip, np, fdg )
USE Types
TYPE(Mesh_t), POINTER :: Mesh
TYPE(Element_t), POINTER :: Parent
INTEGER :: nip, np
REAL(KIND=dp) :: fip(:), fdg(:)
END SUBROUTINE Ip2DgFieldInElement
END INTERFACE
T = 0.0_dp
n = Element % TYPE % NumberOfNodes
npar = 0.0_dp
dofs = Var % Dofs
IF(dofs > 1) THEN
IF(.NOT. PRESENT(dof)) THEN
CALL Fatal('InterpolateIPVariableToBoundary','Give component of ip variable!')
END IF
END IF
DO ipar = 1,2
IF( ipar == 1 ) THEN
Parent => Element % BoundaryInfo % Left
ELSE
Parent => Element % BoundaryInfo % Right
END IF
IF(.NOT. ASSOCIATED( Parent ) ) CYCLE
i = Parent % ElementIndex
j = Var % Perm(i)
nip = Var % Perm(i+1) - j
IF( nip == 0 ) CYCLE
np = Parent % TYPE % NumberOfNodes
ALLOCATE( fip(nip), fdg(np) )
IF( dofs > 1 ) THEN
DO i=1,nip
fip(i) = Var % Values(dofs*(j+i-1)+dof)
END DO
ELSE
fip(1:nip) = Var % Values(j+1:j+nip)
END IF
fdg(1:np) = 0.0_dp
CALL Ip2DgFieldInElement( CurrentModel % Mesh, Parent, nip, fip, np, fdg )
npar = npar + 1
DO i=1,n
DO j=1,np
IF( Element % NodeIndexes(i) == Parent % NodeIndexes(j) ) THEN
T = T + Basis(i) * fdg(j)
EXIT
END IF
END DO
END DO
DEALLOCATE( fip, fdg )
END DO
IF( npar == 2 ) T = T / 2
END FUNCTION InterpolateIPVariableToBoundary
SUBROUTINE VarsToValuesOnIps( VarCount, VarTable, T, count, ind, Basis, intvarcount, tstep)
INTEGER :: Varcount
TYPE(VariableTable_t) :: VarTable(:)
INTEGER :: count
REAL(KIND=dp) :: T(:)
INTEGER, OPTIONAL :: ind
REAL(KIND=dp), OPTIONAL :: Basis(:)
INTEGER, OPTIONAL :: intvarcount
INTEGER, OPTIONAL :: tstep
TYPE(Element_t), POINTER :: Element
INTEGER :: i,j,k,n,k1,l,varsize,vari,vari0,dti,tstep0
TYPE(Variable_t), POINTER :: Var
LOGICAL :: Failed
REAL(KIND=dp), POINTER :: Values(:)
Failed = .FALSE.
vari0 = 0
IF( PRESENT(intvarcount)) THEN
vari0 = intvarcount
END IF
count = vari0
tstep0 = 0
IF(PRESENT(tstep)) tstep0 = tstep
DO Vari = vari0+1, VarCount
Var => VarTable(Vari) % Variable
IF(.NOT. ASSOCIATED( Var ) ) THEN
count = count + 1
T(count) = VarTable(Vari) % ParamValue
CYCLE
END IF
dti = -(tstep0 + VarTable(Vari) % tstep)
Varsize = SIZE( Var % Values ) / Var % Dofs
k1 = 0
IF ( Var % TYPE == Variable_on_gauss_points ) THEN
Element => CurrentModel % CurrentElement
i = Element % ElementIndex
n = Var % Perm(i+1) - Var % Perm(i)
IF( n > 0 ) THEN
IF(.NOT. PRESENT(ind) ) THEN
CALL Fatal('VarsToValuesOnIPs','Ip field '//TRIM(Var % Name)//' given but no ip point given as parameter!')
ELSE IF( n < ind ) THEN
CALL Warn('VarsToValuesOnIPs','Too few integration points ('&
//I2S(n)//' vs. '//I2S(ind)//') tabulated!')
ELSE
k1 = Var % Perm(i) + ind
END IF
ELSE
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
IF(.NOT. PRESENT(Basis) ) THEN
CALL Fatal('VarsToValuesOnIps','We need the "Basis" parameter to map stuff to boundaries!')
END IF
IF( Var % Dofs > 1 ) THEN
DO l=1,Var % Dofs
T(count+l) = InterpolateIPVariableToBoundary( Element, Basis, Var, l )
END DO
ELSE
T(count+1) = InterpolateIPVariableToBoundary( Element, Basis, Var )
END IF
ELSE
CALL Warn('VarsToValuesOnIPs','Could not find dependent IP variable: '//TRIM(Var % Name))
END IF
END IF
END IF
IF ( k1 > 0 ) THEN
Values => Var % Values
IF( dti > 0 ) THEN
IF ( ASSOCIATED(Var % PrevValues) ) THEN
IF ( dti <= SIZE(Var % PrevValues,2)) &
Values => Var % PrevValues(:,dti)
END IF
END IF
DO l=1,Var % DOFs
count = count + 1
T(count) = Values(Var % Dofs*(k1-1)+l)
END DO
ELSE
count = count + Var % Dofs
END IF
END DO
END SUBROUTINE VarsToValuesOnIps
SUBROUTINE ListParseStrToValues( str, slen, ind, name, T, count, AllGlobal )
CHARACTER(LEN=*) :: str, name
REAL(KIND=dp) :: T(:)
INTEGER :: slen, count, ind
LOGICAL :: AllGlobal
TYPE(Element_t), POINTER :: Element
INTEGER :: i,j,k,n,k1,l,l0,l1
TYPE(Variable_t), POINTER :: Variable, CVar
AllGlobal = .TRUE.
count=0
l0=1
IF(slen<=0) RETURN
DO WHILE( .TRUE. )
DO WHILE( str(l0:l0) == ' ' )
l0 = l0 + 1
IF ( l0 > slen ) EXIT
END DO
IF ( l0 > slen ) EXIT
l1 = INDEX( str(l0:slen),',')
IF ( l1 > 0 ) THEN
l1=l0+l1-2
ELSE
l1=slen
END IF
IF ( str(l0:l1) /= 'coordinate' ) THEN
Variable => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) )
IF ( .NOT. ASSOCIATED( Variable ) ) THEN
CALL Info('ListParseStrToValues','Parsed variable '//I2S(count+1)//' of '//str(1:slen),Level=3)
CALL Info('ListParseStrToValues','Parse counters: '&
//I2S(l0)//', '//I2S(l1)//', '//I2S(slen),Level=10)
CALL Fatal('ListParseStrToValues','Can''t find independent variable:['// &
TRIM(str(l0:l1))//'] for dependent variable:['//TRIM(Name)//']')
END IF
IF( SIZE( Variable % Values ) > Variable % Dofs ) AllGlobal = .FALSE.
ELSE
AllGlobal = .FALSE.
Variable => VariableGet( CurrentModel % Variables,'Coordinate 1' )
END IF
IF( Variable % TYPE == Variable_on_gauss_points ) THEN
DO l=1,Variable % DOFs
count = count + 1
T(count) = HUGE(1.0_dp)
END DO
l0 = l1+2
IF ( l0 > slen ) EXIT
CYCLE
END IF
k1 = ind
IF ( Variable % TYPE == Variable_on_nodes_on_elements ) THEN
Element => CurrentModel % CurrentElement
IF ( ASSOCIATED(Element) ) THEN
IF ( ASSOCIATED(Element % DGIndexes) ) THEN
n = SIZE(Element % DGIndexes)
DO i=1,n
IF ( Element % NodeIndexes(i)==ind ) THEN
k1 = Element % DGIndexes(i)
EXIT
END IF
END DO
END IF
END IF
END IF
IF ( ASSOCIATED(Variable % Perm) ) k1 = Variable % Perm(k1)
IF ( k1>0 .AND. k1<=SIZE(Variable % Values) ) THEN
IF ( str(l0:l1) == 'coordinate' ) THEN
CVar => VariableGet( CurrentModel % Variables, 'Coordinate 1' )
count = count + 1
T(1) = CVar % Values(k1)
CVar => VariableGet( CurrentModel % Variables, 'Coordinate 2' )
count = count + 1
T(2) = CVar % Values(k1)
CVar => VariableGet( CurrentModel % Variables, 'Coordinate 3' )
count = count + 1
T(3) = CVar % Values(k1)
ELSE
IF ( Variable % DOFs == 1 ) THEN
count = count + 1
T(count) = Variable % Values(k1)
ELSE
DO l=1,Variable % DOFs
count = count + 1
T(count) = Variable % Values(Variable % DOFs*(k1-1)+l)
END DO
END IF
END IF
ELSE
count = count + 1
IF ( ASSOCIATED(Variable % Perm) ) THEN
T(count) = HUGE(1.0_dp)
EXIT
ELSE
T(count) = Variable % Values(1)
END IF
END IF
l0 = l1+2
IF ( l0 > slen ) EXIT
END DO
END SUBROUTINE ListParseStrToValues
FUNCTION ListCheckGlobal( ptr ) RESULT ( IsGlobal )
TYPE(ValueListEntry_t), POINTER :: ptr
LOGICAL :: IsGlobal
TYPE(Element_t), POINTER :: Element
INTEGER :: ind,i,j,k,n,k1,l,l0,l1,ll,count
TYPE(Variable_t), POINTER :: Variable, CVar
INTEGER :: slen
IsGlobal = .TRUE.
IF(.NOT.ASSOCIATED(ptr)) THEN
CALL Warn('ListCheckGlobal','ptr not associated!')
RETURN
END IF
IF( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_STR ) THEN
RETURN
ELSE IF( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN
IF ( ptr % PROCEDURE /= 0 ) THEN
IsGlobal = .FALSE.
RETURN
END IF
slen = ptr % DepNameLen
IF( slen > 0 ) THEN
count = 0
l0 = 1
DO WHILE( .TRUE. )
DO WHILE( ptr % DependName(l0:l0) == ' ' )
l0 = l0 + 1
END DO
IF ( l0 > slen ) EXIT
l1 = INDEX( ptr % DependName(l0:slen),',')
IF ( l1 > 0 ) THEN
l1=l0+l1-2
ELSE
l1=slen
END IF
count = count + 1
IF ( ptr % DependName(l0:l1) /= 'coordinate' ) THEN
Variable => VariableGet( CurrentModel % Variables,TRIM(ptr % DependName(l0:l1)) )
IF ( .NOT. ASSOCIATED( Variable ) ) THEN
CALL Info('ListCheckGlobal','Parsed variable '//I2S(count)//' of '&
//ptr % DependName(1:slen),Level=3)
CALL Info('ListCheckGlobal','Parse counters: '&
//I2S(l0)//', '//I2S(l1)//', '//I2S(slen),Level=10)
WRITE( Message, * ) 'Can''t find independent variable:[', &
TRIM(ptr % DependName(l0:l1)),']'
CALL Fatal( 'ListCheckGlobal', Message )
END IF
IF( SIZE( Variable % Values ) > 1 ) THEN
IsGlobal = .FALSE.
RETURN
END IF
ELSE
IsGlobal = .FALSE.
EXIT
END IF
l0 = l1+2
IF ( l0 > slen ) EXIT
END DO
ELSE
IsGlobal = .FALSE.
END IF
END IF
END FUNCTION ListCheckGlobal
FUNCTION ListCheckAllGlobal( List, name ) RESULT ( AllGlobal )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: name
LOGICAL :: AllGlobal
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(Element_t), POINTER :: Element
INTEGER :: ind,i,j,k,n,k1,l,l0,l1
TYPE(Variable_t), POINTER :: Variable, CVar
INTEGER :: slen
AllGlobal = .TRUE.
IF(.NOT.ASSOCIATED(List)) RETURN
ptr => List % Head
IF(.NOT.ASSOCIATED(ptr)) RETURN
AllGlobal = ListCheckGlobal( ptr )
END FUNCTION ListCheckAllGlobal
RECURSIVE FUNCTION ListCheckIsConstant( List,Name,Found) RESULT( IsConstant )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found
LOGICAL :: IsConstant
TYPE(ValueListEntry_t), POINTER :: ptr
IsConstant = .FALSE.
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) RETURN
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR, &
LIST_TYPE_CONSTANT_TENSOR, &
LIST_TYPE_LOGICAL, &
LIST_TYPE_INTEGER )
IsConstant = .TRUE.
END SELECT
IF( ptr % PROCEDURE /= 0) IsConstant = .FALSE.
END FUNCTION ListCheckIsConstant
RECURSIVE FUNCTION ListGetReal( List,Name,N,NodeIndexes,Found,minv,maxv,UnfoundFatal ) RESULT(F)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: N,NodeIndexes(:)
REAL(KIND=dp) :: F(N)
LOGICAL, OPTIONAL :: Found, UnfoundFatal
REAL(KIND=dp), OPTIONAL :: minv,maxv
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
TYPE(ValueListEntry_t), POINTER :: ptr
REAL(KIND=dp) :: T(MAX_FNC)
TYPE(VariableTable_t) :: VarTable(MAX_FNC)
INTEGER :: i,j,k,k1,l,l0,l1,lsize, VarCount
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes
F = 0.0_dp
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
WRITE(Message, '(A,A)') "Failed to find real: ",Name
CALL Fatal("ListGetReal", Message)
END IF
END IF
RETURN
END IF
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
F = ptr % Coeff * ptr % Fvalues(1,1,1)
CASE( LIST_TYPE_VARIABLE_SCALAR )
CALL ListPushActiveName(Name)
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, VarTable, &
SomeAtIp, SomeAtNodes, AllGlobal, 0, List )
IF( SomeAtIp ) THEN
CALL Fatal('ListGetReal','Function cannot deal with variables on IPs!')
END IF
DO i=1,n
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( VarCount, VarTable, k, T, j )
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
IF ( ptr % PROCEDURE /= 0 ) THEN
F(i) = ptr % Coeff * &
ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T )
ELSE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
F(i) = ptr % Coeff * &
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
T(1), ptr % CubicCoeff )
IF( AllGlobal) THEN
F(2:n) = F(1)
EXIT
END IF
END IF
END IF
END DO
CALL ListPopActiveName()
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
TVar => VariableGet( CurrentModel % Variables, 'Time' )
F(1:n) = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % values,'st')
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, &
VarTable, SomeAtIp, SomeAtNodes, AllGlobal, 0, List )
IF( SomeAtIp ) THEN
CALL Fatal('ListGetReal','Function cannot deal with variables on IPs!')
END IF
DO i=1,n
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( VarCount, VarTable, k, T, j )
IF ( .NOT. ptr % LuaFun ) THEN
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
F(i) = Ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
END IF
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, F(i), j )
END IF
IF( AllGlobal ) THEN
F(2:n) = F(1)
EXIT
END IF
END DO
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE == 0 ) THEN
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)//&
'] not used consistently.')
END IF
CALL ListPushActiveName(name)
DO i=1,n
F(i) = Ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), &
CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), &
CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) )
END DO
CALL ListPopActiveName()
END SELECT
IF ( PRESENT( minv ) ) THEN
IF ( MINVAL(F(1:n)) < minv ) THEN
WRITE( Message,*) 'Given VALUE ', MINVAL(F(1:n)), ' for property: ', '[', TRIM(Name),']', &
' smaller than given minimum: ', minv
CALL Fatal( 'ListGetReal', Message )
END IF
END IF
IF ( PRESENT( maxv ) ) THEN
IF ( MAXVAL(F(1:n)) > maxv ) THEN
WRITE( Message,*) 'Given VALUE ', MAXVAL(F(1:n)), ' for property: ', '[', TRIM(Name),']', &
' larger than given maximum ', maxv
CALL Fatal( 'ListGetReal', Message )
END IF
END IF
END FUNCTION ListGetReal
RECURSIVE FUNCTION ListGetRealInside( ptr,Name,NodeIndex) RESULT(F)
TYPE(ValueListEntry_t), POINTER :: ptr
CHARACTER(LEN=*) :: Name
INTEGER :: NodeIndex
REAL(KIND=dp) :: F
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
REAL(KIND=dp) :: T(MAX_FNC)
TYPE(VariableTable_t) :: VarTable(MAX_FNC)
INTEGER :: j, VarCount
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes
F = 0.0_dp
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetRealInside', 'Value type for property ['//TRIM(Name)// &
'] not used consistently.' )
END IF
F = ptr % Coeff * ptr % Fvalues(1,1,1)
CASE( LIST_TYPE_VARIABLE_SCALAR )
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, VarTable, &
SomeAtIp, SomeAtNodes, AllGlobal, 0 )
IF( SomeAtIp ) THEN
CALL Fatal('ListGetRealInside','Function cannot deal with variables on IPs!')
END IF
CALL VarsToValuesOnNodes( VarCount, VarTable, NodeIndex, T, j )
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
IF ( ptr % PROCEDURE /= 0 ) THEN
F = ptr % Coeff * &
ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndex, T )
ELSE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetRealInside','Value type for property ['//TRIM(Name)// &
'] not used consistently.' )
END IF
F = ptr % Coeff * &
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
T(1), ptr % CubicCoeff )
END IF
END IF
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
TVar => VariableGet( CurrentModel % Variables, 'Time' )
F = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % values,'st')
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, &
VarTable, SomeAtIp, SomeAtNodes, AllGlobal, 0 )
IF( SomeAtIp ) THEN
CALL Fatal('ListGetRealInside','Function cannot deal with variables on IPs!')
END IF
CALL VarsToValuesOnNodes( VarCount, VarTable, NodeIndex, T, j )
IF ( .NOT. ptr % LuaFun ) THEN
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
F = Ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
END IF
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, F, j )
END IF
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE == 0 ) THEN
CALL Fatal('ListGetRealInside','Value type for property ['//TRIM(Name)// &
'] not used consistently.')
END IF
F = Ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
CurrentModel % Mesh % Nodes % x( NodeIndex ), &
CurrentModel % Mesh % Nodes % y( NodeIndex ), &
CurrentModel % Mesh % Nodes % z( NodeIndex ) )
END SELECT
END FUNCTION ListGetRealInside
RECURSIVE FUNCTION ListGetFun( List,Name,x,Found,minv,maxv,dFdx,eps ) RESULT(F)
TYPE(ValueList_t), POINTER :: List
REAL(KIND=dp), OPTIONAL :: x
REAL(KIND=dp) :: f
CHARACTER(LEN=*), OPTIONAL :: Name
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp), OPTIONAL :: minv,maxv
REAL(KIND=dp), OPTIONAL :: dFdx, eps
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
TYPE(ValueListEntry_t), POINTER :: ptr, prevptr, derptr
REAL(KIND=dp) :: T(1)
INTEGER :: i,j,k,k1,l,l0,l1,lsize
LOGICAL :: AllGlobal, GotIt
REAL(KIND=dp) :: xeps, F2, F1
SAVE prevptr, derptr
IF(.NOT. PRESENT(x) ) THEN
CALL Fatal('ListGetFun','Variable "x" is in fact compulsory!')
END IF
F = 0.0_dp
IF( PRESENT( Name ) ) THEN
ptr => ListFind(List,Name,Found)
IF ( .NOT.ASSOCIATED(ptr) ) RETURN
ELSE
IF(.NOT.ASSOCIATED(List)) RETURN
ptr => List % Head
IF ( .NOT.ASSOCIATED(ptr) ) THEN
CALL Warn('ListGetFun','List entry not associated')
RETURN
END IF
END IF
k = 0
T(1) = x
IF( PRESENT( DfDx) ) THEN
IF( .NOT. ASSOCIATED( Ptr, PrevPtr ) ) THEN
PrevPtr => Ptr
derPtr => ListFind(List,TRIM(Name)//' Derivative',GotIt )
END IF
END IF
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)// &
'] not used consistently.')
END IF
F = ptr % Coeff * ptr % Fvalues(1,1,1)
IF( PRESENT( dFdx ) ) THEN
dFdx = 0.0_dp
END IF
CASE( LIST_TYPE_VARIABLE_SCALAR )
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ListPushActiveName(name)
F = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) )
IF( PRESENT( dFdx ) ) THEN
IF( ASSOCIATED( derPtr ) ) THEN
IF(derptr % PROCEDURE /= 0) THEN
dFdx = ExecRealFunction( derptr % PROCEDURE, CurrentModel, k, T(1) )
ELSE
CALL Fatal('ListGetFun','Derivative should be UDF if primary keyword is!')
END IF
ELSE
IF( PRESENT( eps ) ) THEN
xeps = eps
ELSE
xeps = 1.0d-8
END IF
T(1) = x - xeps
F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) )
T(1) = x + xeps
F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) )
dFdx = ( F2 - F1 ) / (2*xeps)
END IF
END IF
CALL ListPopActiveName()
ELSE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetFun', 'Value type for property ['//TRIM(Name)// &
'] not used consistently.')
END IF
F = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
x, ptr % CubicCoeff )
IF( PRESENT( dFdx ) ) THEN
dFdx = DerivateCurve(ptr % TValues,ptr % FValues(1,1,:), &
x, ptr % CubicCoeff )
END IF
END IF
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
IF ( .NOT. ptr % LuaFun ) THEN
F = GetMatcReal(ptr % Cvalue,1,[x])
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, F, 1 )
END IF
IF( PRESENT( dFdx ) ) THEN
IF( ASSOCIATED( derPtr ) ) THEN
IF( derPtr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN
IF ( .NOT. derPtr % LuaFun ) THEN
dFdx = GetMatcReal(derptr % Cvalue)
ELSE
CALL ElmerEvalLua(LuaState, derPtr, T, dFdx, 1 )
END IF
ELSE
CALL Fatal('ListGetFun','Derivative should be given the same was as the primary keyword!')
END IF
ELSE
IF( PRESENT( eps ) ) THEN
xeps = eps
ELSE
xeps = 1.0d-8
END IF
IF ( .NOT. ptr % LuaFun ) THEN
F1 = GetMatcReal(Ptr % Cvalue,1,[x-xeps])
F2 = GetMatcReal(Ptr % Cvalue,1,[x+xeps])
ELSE
T(1) = x-xeps
CALL ElmerEvalLua(LuaState, derPtr, T, F1, 1 )
T(1) = x+xeps
CALL ElmerEvalLua(LuaState, derPtr, T, F2, 1 )
T(1) = x
END IF
dFdx = (F2-F1) / (2*xeps)
END IF
END IF
CASE DEFAULT
CALL Fatal('ListGetFun','LIST_TYPE not implemented!')
END SELECT
IF ( PRESENT( minv ) ) THEN
IF ( F < minv ) THEN
WRITE( Message,*) 'Given value ', F, ' for property: ', '[', TRIM(Name),']', &
' smaller than given minimum: ', minv
CALL Fatal( 'ListGetFun', Message )
END IF
END IF
IF ( PRESENT( maxv ) ) THEN
IF ( F > maxv ) THEN
WRITE( Message,*) 'Given value ', F, ' for property: ', '[', TRIM(Name),']', &
' larger than given maximum ', maxv
CALL Fatal( 'ListGetFun', Message )
END IF
END IF
END FUNCTION ListGetFun
RECURSIVE FUNCTION ListGetFunVec( List,Name,x,dofs,Found,dFdx,eps ) RESULT(F)
TYPE(ValueList_t), POINTER :: List
REAL(KIND=dp), OPTIONAL :: x(*)
INTEGER, OPTIONAL :: dofs
REAL(KIND=dp) :: f
CHARACTER(LEN=*), OPTIONAL :: Name
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp), OPTIONAL :: dFdx(*), eps
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
TYPE(ValueListEntry_t), POINTER :: ptr, prevptr, derptr
REAL(KIND=dp) :: T(10)
INTEGER :: i,j,k,k1,l,l0,l1,lsize
LOGICAL :: GotIt
REAL(KIND=dp) :: xeps, F2, F1
CHARACTER(:), ALLOCATABLE :: tstr
SAVE prevptr, derptr
IF(.NOT. PRESENT(x) ) THEN
CALL Fatal('ListGetFunVec','Variable "x" is in fact compulsory!')
END IF
F = 0.0_dp
IF( PRESENT( Name ) ) THEN
ptr => ListFind(List,Name,Found)
IF ( .NOT.ASSOCIATED(ptr) ) RETURN
ELSE
IF(.NOT.ASSOCIATED(List)) RETURN
ptr => List % Head
IF ( .NOT.ASSOCIATED(ptr) ) THEN
CALL Warn('ListGetFunVec','List entry not associated')
RETURN
END IF
END IF
k = 0
T(1:dofs) = x(1:dofs)
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_VARIABLE_SCALAR )
IF ( ptr % PROCEDURE /= 0 ) THEN
F = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1:dofs) )
IF( PRESENT( dFdx ) ) THEN
IF( PRESENT( eps ) ) THEN
xeps = eps
ELSE
xeps = 1.0d-6
END IF
DO i=1,dofs
T(i) = x(i) - xeps
F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1:dofs) )
T(i) = x(i) + xeps
F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1:dofs) )
dFdx(i) = ( F2 - F1 ) / (2*xeps)
T(i) = x(i)
END DO
END IF
END IF
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
IF ( .NOT. ptr % LuaFun ) THEN
F = GetMatcReal(ptr % Cvalue,dofs,T)
ELSE
CALL ElmerEvalLua(LuaState, ptr, T(1:dofs), F, dofs )
END IF
IF( PRESENT( dFdx ) ) THEN
IF( PRESENT( eps ) ) THEN
xeps = eps
ELSE
xeps = 1.0d-6
END IF
DO i=1,dofs
IF ( .NOT. ptr % LuaFun ) THEN
tstr = 'tx('//I2S(i-1)//')'
F1 = GetMatcReal(ptr % Cvalue,1,[x(i)-xeps],tstr)
F2 = GetMatcReal(ptr % Cvalue,1,[x(i)+xeps],tstr)
ELSE
T(i) = T(i) - eps
CALL ElmerEvalLua(LuaState, ptr, T(1:dofs), F1, dofs )
T(i) = T(i) + 2*eps
CALL ElmerEvalLua(LuaState, ptr, T(1:dofs), F2, dofs )
T(i) = T(i) - eps
END IF
dFdx(i) = (F2-F1) / (2*xeps)
END DO
END IF
CASE DEFAULT
CALL Fatal('ListGetFunVec','LIST_TYPE not implemented!')
END SELECT
END FUNCTION ListGetFunVec
RECURSIVE SUBROUTINE ListInitHandle( Handle )
TYPE(ValueHandle_t) :: Handle
Handle % ValueType = -1
Handle % SectionType = -1
Handle % ListId = -1
Handle % Element => NULL()
Handle % List => NULL()
Handle % Ptr => NULL()
Handle % Nodes => NULL()
Handle % Indexes => NULL()
Handle % nValuesVec = 0
Handle % ValuesVec => NULL()
Handle % Values => NULL()
Handle % ParValues => NULL()
Handle % ParNo = 0
Handle % DefIValue = 0
Handle % DefRValue = 0.0_dp
Handle % Rdim = 0
Handle % RTensor => NULL()
Handle % RTensorValues => NULL()
Handle % DefLValue = .FALSE.
Handle % Initialized = .FALSE.
Handle % AllocationsDone = .FALSE.
Handle % ConstantEverywhere = .FALSE.
Handle % GlobalEverywhere = .FALSE.
Handle % GlobalInList = .FALSE.
Handle % EvaluateAtIP = .FALSE.
Handle % SomeVarAtIp = .FALSE.
Handle % SomewhereEvaluateAtIP = .FALSE.
Handle % NotPresentAnywhere = .FALSE.
Handle % UnfoundFatal = .FALSE.
Handle % GotMinv = .FALSE.
Handle % GotMaxv = .FALSE.
Handle % VarCount = 0
Handle % HandleIm => NULL()
Handle % Handle2 => NULL()
Handle % Handle3 => NULL()
END SUBROUTINE ListInitHandle
RECURSIVE SUBROUTINE ListInitElementKeyword( Handle,Section,Name,minv,maxv,&
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,&
FoundSomewhere,InitIm,InitVec3D,DummyCount)
TYPE(ValueHandle_t) :: Handle
CHARACTER(LEN=*) :: Section,Name
REAL(KIND=dp), OPTIONAL :: minv,maxv
REAL(KIND=dp), OPTIONAL :: DefRValue
INTEGER, OPTIONAL :: DefIValue
LOGICAL, OPTIONAL :: DefLValue
LOGICAL, OPTIONAL :: UnfoundFatal
LOGICAL, OPTIONAL :: EvaluateAtIp
LOGICAL, OPTIONAL :: FoundSomewhere
LOGICAL, OPTIONAL :: InitIm
LOGICAL, OPTIONAL :: InitVec3D
INTEGER, OPTIONAL :: DummyCount
TYPE(ValueList_t), POINTER :: List
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: i, ni, NoVal, ValueType, IValue, dim, n, m, maxn, maxm
TYPE(Model_t), POINTER :: Model
REAL(KIND=dp) :: val, Rvalue
CHARACTER(:), ALLOCATABLE :: CValue
LOGICAL :: ConstantEverywhere, NotPresentAnywhere, Lvalue, FirstList, AllGlobal, Found
REAL(KIND=dp), POINTER :: Basis(:)
INTEGER, POINTER :: NodeIndexes(:)
TYPE(Element_t), POINTER :: Element
LOGICAL :: GotIt, FoundSomewhere1, FoundSomewhere2
IF( PRESENT( DummyCount ) ) THEN
Handle % IntVarCount = DummyCount
END IF
IF( PRESENT( InitIm ) ) THEN
IF( InitIm ) THEN
IF( .NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
ALLOCATE( Handle % HandleIm )
CALL ListInitHandle( Handle % HandleIm )
END IF
CALL Info('ListInitElementKeyword','Treating real part of keyword',Level=15)
CALL ListInitElementKeyword( Handle,Section,Name,minv,maxv,&
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere,InitVec3D=InitVec3D)
IF( PRESENT( FoundSomewhere) ) FoundSomewhere1 = FoundSomewhere
CALL Info('ListInitElementKeyword','Treating imaginary part of keyword',Level=15)
CALL ListInitElementKeyword( Handle % HandleIm,Section,TRIM(Name)//' im',minv,maxv,&
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere,InitVec3D=InitVec3D)
IF( PRESENT( FoundSomewhere ) ) FoundSomewhere = FoundSomewhere .OR. FoundSomewhere1
RETURN
END IF
END IF
IF( PRESENT( InitVec3D ) ) THEN
IF( InitVec3D ) THEN
IF( .NOT. ASSOCIATED( Handle % Handle2 ) ) THEN
ALLOCATE( Handle % Handle2 )
CALL ListInitHandle( Handle % Handle2 )
END IF
IF( .NOT. ASSOCIATED( Handle % Handle3 ) ) THEN
ALLOCATE( Handle % Handle3 )
CALL ListInitHandle( Handle % Handle3 )
END IF
CALL ListInitElementKeyword( Handle,Section,TRIM(Name)//' 1',minv,maxv,&
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere)
IF( PRESENT( FoundSomewhere) ) FoundSomewhere1 = FoundSomewhere
CALL ListInitElementKeyword( Handle % Handle2,Section,TRIM(Name)//' 2',minv,maxv,&
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere)
IF( PRESENT( FoundSomewhere) ) FoundSomewhere2 = FoundSomewhere
CALL ListInitElementKeyword( Handle % Handle3,Section,TRIM(Name)//' 3',minv,maxv,&
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere)
IF( PRESENT( FoundSomewhere ) ) FoundSomewhere = FoundSomewhere .OR. &
FoundSomewhere1 .OR. FoundSomewhere2
RETURN
END IF
END IF
CALL Info('ListInitElementKeyword','Treating keyword: '//TRIM(Name),Level=12)
Model => CurrentModel
Handle % BulkElement = .TRUE.
NULLIFY(ptr)
SELECT CASE ( Section )
CASE('Body')
Handle % SectionType = SECTION_TYPE_BODY
CASE('Material')
Handle % SectionType = SECTION_TYPE_MATERIAL
CASE('Body Force')
Handle % SectionType = SECTION_TYPE_BF
CASE('Initial Condition')
Handle % SectionType = SECTION_TYPE_IC
CASE('Boundary Condition')
Handle % SectionType = SECTION_TYPE_BC
Handle % BulkElement = .FALSE.
CASE('Component')
Handle % SectionType = SECTION_TYPE_COMPONENT
CASE('Equation')
Handle % SectionType = SECTION_TYPE_EQUATION
CASE DEFAULT
CALL Fatal('ListInitElementKeyword','Unknown section: '//TRIM(Section))
END SELECT
Handle % ConstantEverywhere = .TRUE.
Handle % GlobalInList = .FALSE.
Handle % NotPresentAnywhere = .TRUE.
Handle % SomewhereEvaluateAtIP = .FALSE.
Handle % GlobalEverywhere = .TRUE.
Handle % SomeVarAtIp = .FALSE.
Handle % Name = TRIM(Name)
Handle % ListId = -1
Handle % EvaluateAtIp = .FALSE.
Handle % List => NULL()
Handle % Element => NULL()
Handle % Unfoundfatal = .FALSE.
IF (.NOT. ASSOCIATED( Handle % Ptr ) ) THEN
Handle % Ptr => ListAllocate()
END IF
IF( Handle % nValuesVec > 0 ) THEN
DEALLOCATE( Handle % ValuesVec )
Handle % nValuesVec = 0
END IF
Handle % Initialized = .TRUE.
FirstList = .TRUE.
maxn = 0
maxm = 0
i = 0
DO WHILE(.TRUE.)
i = i + 1
SELECT CASE ( Handle % SectionType )
CASE( SECTION_TYPE_BODY )
IF(i > Model % NumberOfBodies ) EXIT
List => Model % Bodies(i) % Values
CASE( SECTION_TYPE_MATERIAL )
IF(i > Model % NumberOfMaterials ) EXIT
List => Model % Materials(i) % Values
CASE( SECTION_TYPE_BF )
IF(i > Model % NumberOfBodyForces ) EXIT
List => Model % BodyForces(i) % Values
CASE( SECTION_TYPE_IC )
IF( i > Model % NumberOfICs ) EXIT
List => Model % ICs(i) % Values
CASE( SECTION_TYPE_EQUATION )
IF( i > Model % NumberOfEquations ) EXIT
List => Model % Equations(i) % Values
CASE( SECTION_TYPE_COMPONENT )
IF( i > Model % NumberOfComponents ) EXIT
List => Model % Components(i) % Values
CASE( SECTION_TYPE_BC )
IF( i > Model % NumberOfBCs ) EXIT
List => Model % BCs(i) % Values
Handle % ConstantEverywhere = .FALSE.
CASE DEFAULT
CALL Fatal('ListInitElementKeyword','Unknown section: '//I2S(Handle % SectionType))
END SELECT
ptr => ListFind(List,Name,Found)
Handle % ptr % Head => ptr
IF ( .NOT. ASSOCIATED(ptr) ) THEN
Handle % ConstantEverywhere = .FALSE.
CYCLE
ELSE IF( FirstList ) THEN
Handle % NotPresentAnywhere = .FALSE.
Handle % ValueType = ptr % Type
END IF
ValueType = ptr % TYPE
IF( ValueType == LIST_TYPE_LOGICAL ) THEN
Lvalue = ptr % Lvalue
IF( FirstList ) THEN
Handle % LValue = LValue
ELSE
IF( Handle % LValue .NEQV. LValue ) THEN
Handle % ConstantEverywhere = .FALSE.
EXIT
END IF
END IF
ELSE IF( ValueType == LIST_TYPE_STRING ) THEN
Cvalue = ptr % Cvalue
IF( FirstList ) THEN
Handle % CValueLen = len_trim(CValue)
Handle % CValue = CValue(1:Handle % CValueLen)
ELSE IF( Handle % CValue(1:Handle % CValueLen) /= Cvalue ) THEN
Handle % ConstantEverywhere = .FALSE.
EXIT
END IF
ELSE IF( ValueType == LIST_TYPE_INTEGER ) THEN
Ivalue = ptr % Ivalues(1)
IF( FirstList ) THEN
Handle % IValue = Ivalue
ELSE IF( Handle % IValue /= Ivalue ) THEN
Handle % ConstantEverywhere = .FALSE.
EXIT
END IF
ELSE IF( ValueType >= LIST_TYPE_CONSTANT_SCALAR .AND. &
ValueType <= List_TYPE_CONSTANT_SCALAR_PROC ) THEN
IF( PRESENT( DummyCount ) ) THEN
AllGlobal = .FALSE.
ELSE
AllGlobal = ListCheckAllGlobal( Handle % ptr, name )
END IF
IF(.NOT. AllGlobal ) THEN
Handle % GlobalEverywhere = .FALSE.
Handle % ConstantEverywhere = .FALSE.
IF( ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) ) THEN
Handle % SomewhereEvaluateAtIp = .TRUE.
EXIT
END IF
END IF
IF( Handle % ConstantEverywhere ) THEN
Rvalue = ListGetCReal( List,Name)
IF( FirstList ) THEN
Handle % RValue = Rvalue
ELSE IF( ABS( Handle % RValue - Rvalue ) > TINY( RValue ) ) THEN
Handle % ConstantEverywhere = .FALSE.
END IF
END IF
ELSE IF( ValueType >= LIST_TYPE_CONSTANT_TENSOR .AND. &
ValueType <= LIST_TYPE_VARIABLE_TENSOR_STR ) THEN
Handle % GlobalEverywhere = .FALSE.
Handle % ConstantEverywhere = .FALSE.
IF( ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) ) THEN
Handle % SomewhereEvaluateAtIp = .TRUE.
END IF
n = SIZE( ptr % FValues,1 )
m = SIZE( ptr % FValues,2 )
maxn = MAX( n, maxn )
maxm = MAX( m, maxm )
ELSE
CALL Fatal('ListInitElementKeyword','Unknown value type: '//I2S(ValueType))
END IF
FirstList = .FALSE.
END DO
CALL Info('ListInitElementKeyword',&
'Initiated handle for: > '//TRIM(Handle % Name)//' < of type: '// &
I2S(Handle % ValueType),Level=12)
IF( PRESENT( UnfoundFatal ) ) THEN
Handle % Unfoundfatal = UnfoundFatal
IF( Handle % UnfoundFatal .AND. Handle % NotPresentAnywhere ) THEN
CALL Fatal('ListInitElementKeywords','Keyword required but not present: '&
//TRIM(Handle % Name))
END IF
END IF
IF( PRESENT( DefLValue ) ) THEN
Handle % DefLValue = DefLValue
END IF
IF( PRESENT( DefRValue ) ) THEN
Handle % DefRValue = DefRValue
END IF
IF( PRESENT( DefIValue ) ) THEN
Handle % DefIValue = DefIValue
END IF
IF( PRESENT( minv ) ) THEN
Handle % GotMinv = .TRUE.
Handle % minv = minv
END IF
IF( PRESENT( maxv ) ) THEN
Handle % GotMaxv = .TRUE.
Handle % maxv = maxv
END IF
IF( PRESENT( EvaluateAtIp ) ) THEN
Handle % EvaluateAtIp = EvaluateAtIp
END IF
IF( PRESENT( FoundSomewhere ) ) THEN
FoundSomewhere = .NOT. Handle % NotPresentAnywhere
END IF
IF( maxn > 1 .OR. maxm > 1 ) THEN
ni = CurrentModel % Mesh % MaxElementNodes
IF( ASSOCIATED( Handle % RtensorValues ) ) THEN
IF( SIZE( Handle % RtensorValues, 1 ) < maxn .OR. &
SIZE( Handle % RtensorValues, 2 ) < maxm .OR. &
SIZE( Handle % RtensorValues, 3 ) < ni ) THEN
DEALLOCATE( Handle % RtensorValues )
END IF
END IF
IF(.NOT. ASSOCIATED( Handle % RtensorValues ) ) THEN
ALLOCATE( Handle % RtensorValues(maxn,maxm,ni) )
END IF
END IF
END SUBROUTINE ListInitElementKeyword
FUNCTION ElementHandleList( Element, Handle, ListSame, ListFound ) RESULT( List )
TYPE(Element_t), POINTER :: Element
TYPE(ValueHandle_t) :: Handle
TYPE(ValueList_t), POINTER :: List
LOGICAL :: ListSame, ListFound
INTEGER :: ListId, id
List => NULL()
ListSame = .FALSE.
ListFound = .FALSE.
IF( ASSOCIATED( Element, Handle % Element ) ) THEN
ListSame = .TRUE.
List => Handle % List
RETURN
END IF
IF( Handle % BulkElement ) THEN
ListId = Element % BodyId
ELSE
ListId = 0
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
ListId = Element % BoundaryInfo % Constraint
END IF
END IF
IF( Handle % ListId == ListId ) THEN
ListSame = .TRUE.
List => Handle % List
RETURN
ELSE
Handle % ListId = ListId
IF( ListId <= 0 ) RETURN
END IF
SELECT CASE ( Handle % SectionType )
CASE( SECTION_TYPE_BODY )
List => CurrentModel % Bodies(ListId) % Values
ListFound = .TRUE.
CASE( SECTION_TYPE_BF )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Body Force', ListFound )
IF( ListFound ) List => CurrentModel % BodyForces(id) % Values
CASE( SECTION_TYPE_IC )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Initial Condition', ListFound )
IF(ListFound) List => CurrentModel % ICs(id) % Values
CASE( SECTION_TYPE_MATERIAL )
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
id = Element % BoundaryInfo % Constraint
IF(id >= 1 .AND. id <= CurrentModel % NumberOfBCs ) THEN
id = ListGetInteger( CurrentModel % BCs(id) % Values, &
'Material', ListFound )
ELSE
id = 0
END IF
ELSE
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Material', ListFound )
END IF
IF(ListFound) List => CurrentModel % Materials(id) % Values
CASE( SECTION_TYPE_COMPONENT )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Component', ListFound )
IF(ListFound) List => CurrentModel % Components(id) % Values
CASE( SECTION_TYPE_EQUATION )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Equation', ListFound )
IF(ListFound) List => CurrentModel % Equations(id) % Values
CASE( SECTION_TYPE_BC )
IF( ListId <= 0 .OR. ListId > CurrentModel % NumberOfBCs ) RETURN
IF( CurrentModel % BCs(ListId) % Tag == ListId ) THEN
List => CurrentModel % BCs(ListId) % Values
ListFound = .TRUE.
END IF
CASE( -1 )
CALL Fatal('ElementHandleList','Handle not initialized!')
CASE DEFAULT
CALL Fatal('ElementHandleList','Unknown section type!')
END SELECT
IF( ListFound ) THEN
IF( ASSOCIATED( List, Handle % List ) ) THEN
ListSame = .TRUE.
ELSE
Handle % List => List
END IF
ELSE
Handle % List => NULL()
END IF
END FUNCTION ElementHandleList
FUNCTION SectionHandleList( Handle, ListId, EndLoop ) RESULT( List )
TYPE(ValueHandle_t) :: Handle
TYPE(ValueList_t), POINTER :: List
INTEGER :: ListId
LOGICAL :: EndLoop
LOGICAL :: Found
INTEGER :: id
List => NULL()
IF( Handle % SectionType == SECTION_TYPE_BC ) THEN
EndLoop = ( ListId <= 0 .OR. ListId > CurrentModel % NumberOfBCs )
ELSE
EndLoop = ( ListId > CurrentModel % NumberOfBodies )
END IF
IF( EndLoop ) RETURN
SELECT CASE ( Handle % SectionType )
CASE( SECTION_TYPE_BODY )
List => CurrentModel % Bodies(ListId) % Values
CASE( SECTION_TYPE_BF )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Body Force', Found )
IF( Found ) List => CurrentModel % BodyForces(id) % Values
CASE( SECTION_TYPE_IC )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Initial Condition', Found )
IF(Found) List => CurrentModel % ICs(id) % Values
CASE( SECTION_TYPE_MATERIAL )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Material', Found )
IF(Found) List => CurrentModel % Materials(id) % Values
CASE( SECTION_TYPE_EQUATION )
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
'Equation',Found )
IF(Found) List => CurrentModel % Equations(id) % Values
CASE( SECTION_TYPE_BC )
List => CurrentModel % BCs(ListId) % Values
CASE( -1 )
CALL Fatal('SectionHandleList','Handle not initialized!')
CASE DEFAULT
CALL Fatal('SectionHandleList','Unknown section type!')
END SELECT
END FUNCTION SectionHandleList
FUNCTION ListCompareElementAnyString( Handle, RefValue ) RESULT( Same )
TYPE(ValueHandle_t) :: Handle
CHARACTER(LEN=*) :: RefValue
LOGICAL :: Same
TYPE(ValueList_t), POINTER :: List
LOGICAL :: Found, EndLoop
INTEGER :: id, n
CHARACTER(:), ALLOCATABLE :: ThisValue
Same = .FALSE.
IF( Handle % NotPresentAnywhere ) RETURN
id = 0
DO WHILE (.TRUE.)
id = id + 1
List => SectionHandleList( Handle, id, EndLoop )
IF( EndLoop ) EXIT
IF(.NOT. ASSOCIATED( List ) ) CYCLE
ThisValue = ListGetString( List, Handle % Name, Found )
IF( Found ) THEN
n = len_TRIM(ThisValue)
Same = ( ThisValue(1:n) == RefValue )
IF( Same ) EXIT
END IF
END DO
END FUNCTION ListCompareElementAnyString
FUNCTION ListCompareElementAnyLogical( Handle, RefValue ) RESULT( Same )
TYPE(ValueHandle_t) :: Handle
LOGICAL :: RefValue
LOGICAL :: Same
LOGICAL :: ThisValue
TYPE(ValueList_t), POINTER :: List
LOGICAL :: Found, EndLoop
INTEGER :: id, CValueLen
Same = .FALSE.
IF( Handle % NotPresentAnywhere ) RETURN
id = 0
DO WHILE (.TRUE.)
id = id + 1
List => SectionHandleList( Handle, id, EndLoop )
IF( EndLoop ) EXIT
IF(.NOT. ASSOCIATED( List ) ) CYCLE
ThisValue = ListGetLogical( List, Handle % Name, Found )
IF( Found ) THEN
IF( ThisValue .AND. RefValue ) THEN
Same = .TRUE.
ELSE IF(.NOT. ThisValue .AND. .NOT. RefValue ) THEN
Same = .TRUE.
END IF
IF( Same ) EXIT
END IF
END DO
END FUNCTION ListCompareElementAnyLogical
FUNCTION ListGetElementRealParent( Handle, Basis, Element, Found ) RESULT( RValue )
TYPE(ValueHandle_t) :: Handle
TYPE(Element_t), OPTIONAL, POINTER :: Element
REAL(KIND=dp), OPTIONAL :: Basis(:)
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp) :: RValue
LOGICAL :: IntFound
LOGICAL :: lefttest = .TRUE.
TYPE(Element_t), POINTER :: Parent, PElement
SAVE lefttest
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
IntFound = .FALSE.
IF( lefttest) THEN
Parent => PElement % BoundaryInfo % Left
ELSE
Parent => PElement % BoundaryInfo % Right
END IF
RValue = ListGetElementReal( Handle, Basis, Parent, IntFound, PElement % NodeIndexes )
IF(.NOT. IntFound ) THEN
IF( lefttest) THEN
Parent => PElement % BoundaryInfo % Right
ELSE
Parent => PElement % BoundaryInfo % Left
END IF
RValue = ListGetElementReal( Handle, Basis, Parent, IntFound, PElement % NodeIndexes )
IF( IntFound ) lefttest = .NOT. lefttest
END IF
IF( PRESENT( Found ) ) Found = IntFound
END FUNCTION ListGetElementRealParent
FUNCTION ListGetElementReal( Handle,Basis,Element,Found,Indexes,&
GaussPoint,Rdim,Rtensor,DummyVals,tstep) RESULT(Rvalue)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: Rdim
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
REAL(KIND=dp), OPTIONAL :: DummyVals(:)
INTEGER, OPTIONAL :: tstep
REAL(KIND=dp) :: Rvalue
TYPE(ValueList_t), POINTER :: List
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER, POINTER :: NodeIndexes(:)
REAL(KIND=dp) :: T(MAX_FNC),x,y,z
REAL(KIND=dp), POINTER :: F(:)
REAL(KIND=dp), POINTER :: ParF(:,:)
INTEGER :: i,j,j0,k,j2,k2,k1,l,l0,l1,lsize,ni,bodyid,id,n,m
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes, ListSame, ListFound, GotIt, IntFound, &
ElementSame
TYPE(Element_t), POINTER :: PElement
INTEGER :: lstat
IF( Handle % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
Rvalue = Handle % DefRValue
RETURN
END IF
IF( PRESENT( Rdim ) ) Rdim = 0
IF( Handle % ConstantEverywhere ) THEN
IF(PRESENT(Found)) Found = .TRUE.
RValue = Handle % RValue
RETURN
END IF
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
Rvalue = Handle % DefRValue
ElementSame = .FALSE.
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
IF( ListSame ) THEN
IF( PRESENT( Found ) ) Found = Handle % Found
IF( .NOT. Handle % Found ) RETURN
IF( Handle % GlobalInList ) THEN
IF( Handle % Rdim == 0 ) THEN
Rvalue = Handle % Values(1)
RETURN
ELSE
Rdim = Handle % Rdim
Rtensor => Handle % Rtensor
RETURN
END IF
ELSE
ptr => Handle % ptr % head
IF (PRESENT(Rdim) .AND. PRESENT(Rtensor)) THEN
Rdim = Handle % Rdim
Rtensor => Handle % Rtensor
END IF
END IF
ELSE IF( ListFound ) THEN
ptr => ListFind(List,Handle % Name,IntFound )
IF(PRESENT(Found)) Found = IntFound
Handle % Found = IntFound
IF(.NOT. IntFound ) THEN
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementReal','Could not find required keyword in list: '//TRIM(Handle % Name))
END IF
RETURN
END IF
Handle % Ptr % Head => ptr
Handle % Rdim = ptr % Fdim
IF( ptr % Fdim > 0 ) THEN
n = SIZE(ptr % FValues,1)
m = SIZE(ptr % FValues,2)
IF ( ASSOCIATED( Handle % Rtensor) ) THEN
IF ( SIZE(Handle % Rtensor,1) /= n .OR. SIZE(Handle % Rtensor,2) /= m ) THEN
DEALLOCATE( Handle % Rtensor )
END IF
END IF
IF(.NOT. ASSOCIATED( Handle % Rtensor) ) THEN
ALLOCATE( Handle % Rtensor(n,m) )
END IF
IF( PRESENT( Rdim ) .AND. PRESENT( Rtensor ) ) THEN
Rdim = Handle % Rdim
Rtensor => Handle % Rtensor
ELSE
CALL Fatal('ListGetElementReal','For tensors Rdim and Rtensor should be present!')
END IF
END IF
IF( Handle % SomewhereEvaluateAtIp ) THEN
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN
Handle % EvaluateAtIP = ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt )
ELSE
Handle % EvaluateAtIp = .FALSE.
END IF
END IF
IF( Ptr % DepNameLen > 0 ) THEN
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, &
Handle % Name, Handle % VarCount, Handle % VarTable, &
SomeAtIp, SomeAtNodes, AllGlobal, Handle % IntVarCount, List )
Handle % GlobalInList = ( AllGlobal .AND. ptr % PROCEDURE == 0 )
IF( SomeAtIP ) Handle % EvaluateAtIp = .TRUE.
Handle % SomeVarAtIp = SomeAtIp
IF( AllGlobal ) Handle % EvaluateAtIp = .FALSE.
ELSE
Handle % GlobalInList = ( ptr % PROCEDURE == 0 )
END IF
ELSE
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementReal','Could not find list for required keyword: '//TRIM(Handle % Name))
END IF
Rvalue = Handle % DefRValue
IF( PRESENT(Found) ) THEN
Found = .FALSE.
Handle % Found = .FALSE.
END IF
RETURN
END IF
IF( Handle % IntVarCount > 0 ) THEN
IF(.NOT. PRESENT( DummyVals ) ) THEN
CALL Fatal('ListGetElementReal','This handle expects '&
//I2S(Handle % IntVarCount)//' internal variables: '//TRIM(Handle % Name))
END IF
IF( SIZE( DummyVals ) /= Handle % IntVarCount ) THEN
CALL Fatal('ListGetElementReal','We are expecting '&
//I2S(Handle % IntVarCount)//' internal variables: '//TRIM(Handle % Name))
END IF
END IF
IF( Handle % EvaluateAtIp ) THEN
IF(.NOT. PRESENT(Basis)) THEN
CALL Fatal('ListGetElementReal','Parameter > Basis < is required for: '//TRIM(Handle % Name))
END IF
IF( ASSOCIATED( PElement, Handle % Element ) ) THEN
IF( PRESENT( Indexes ) ) THEN
ni = SIZE( Indexes )
NodeIndexes => Indexes
ELSE
ni = Handle % Element % TYPE % NumberOfNodes
NodeIndexes => PElement % NodeIndexes
END IF
ParF => Handle % ParValues
ELSE
IF( .NOT. Handle % AllocationsDone ) THEN
ni = CurrentModel % Mesh % MaxElementNodes
ALLOCATE( Handle % Values(ni) )
Handle % Values = 0.0_dp
ALLOCATE( Handle % ParValues(MAX_FNC,ni), Handle % ParUsed(MAX_FNC) )
Handle % ParValues = 0.0_dp
Handle % ParUsed = .FALSE.
Handle % AllocationsDone = .TRUE.
END IF
Handle % Element => PElement
IF( PRESENT( Indexes ) ) THEN
ni = SIZE( Indexes )
NodeIndexes => Indexes
ELSE
ni = PElement % TYPE % NumberOfNodes
NodeIndexes => PElement % NodeIndexes
END IF
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_TENSOR .OR. &
ptr % Type == LIST_TYPE_VARIABLE_TENSOR_STR ) THEN
IF(.NOT. ASSOCIATED( Handle % ParValues )) THEN
ALLOCATE( Handle % ParValues(MAX_FNC,CurrentModel % Mesh % MaxElementNodes), &
Handle % ParUsed(MAX_FNC) )
Handle % ParValues = 0.0_dp
Handle % ParUsed = .FALSE.
END IF
CALL VarsToValuesOnNodesWhich( Handle % VarCount, Handle % VarTable, &
Handle % ParUsed, j)
j0 = Handle % IntVarCount+1
DO i=1,ni
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
k, T, j, Handle % IntVarCount, tstep )
Handle % ParNo = j
Handle % ParValues(j0:j,i) = T(j0:j)
IF( Handle % GlobalInList ) EXIT
END DO
END IF
ParF => Handle % ParValues
END IF
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_VARIABLE_SCALAR )
IF( Handle % IntVarCount > 0 ) THEN
T(1:Handle % IntVarCount) = DummyVals
END IF
j0 = Handle % IntVarCount+1
DO j=j0,Handle % VarCount
IF( Handle % ParUsed(j) ) THEN
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
END IF
END DO
IF( Handle % SomeVarAtIp ) THEN
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, &
GaussPoint, Basis, Handle % IntVarCount, tstep )
END IF
IF ( ptr % PROCEDURE /= 0 ) THEN
IF( PRESENT( GaussPoint ) ) THEN
j = -GaussPoint
ELSE
j = 0
END IF
Rvalue = ExecRealFunction( ptr % PROCEDURE,CurrentModel, j, T )
ELSE
RValue = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
T(1), ptr % CubicCoeff )
END IF
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
IF( Handle % IntVarCount > 0 ) THEN
T(1:Handle % IntVarCount) = DummyVals
END IF
j0 = Handle % IntVarCount + 1
DO j=j0,Handle % ParNo
IF( Handle % ParUsed(j) ) THEN
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
END IF
END DO
IF( Handle % SomeVarAtIp ) THEN
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, GaussPoint, Basis, &
Handle % IntVarCount, tstep )
END IF
IF ( ptr % LuaFun ) THEN
CALL ElmerEvalLua(LuaState, ptr, T, RValue, Handle % ParNo )
ELSE
Rvalue = GetMatcReal(Ptr % Cvalue,Handle % ParNo,T)
END IF
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE /= 0 ) THEN
x = SUM( Basis(1:ni) * CurrentModel % Mesh % Nodes % x( NodeIndexes(1:ni) ) )
y = SUM( Basis(1:ni) * CurrentModel % Mesh % Nodes % y( NodeIndexes(1:ni) ) )
z = SUM( Basis(1:ni) * CurrentModel % Mesh % Nodes % z( NodeIndexes(1:ni) ) )
RValue = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,x,y,z)
ELSE
CALL Fatal('ListGetElementReal','Constant scalar evaluation failed at ip!')
END IF
CASE ( LIST_TYPE_CONSTANT_TENSOR )
n = SIZE( Handle % Rtensor, 1 )
m = SIZE( Handle % Rtensor, 2 )
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL Fatal('ListGetElementReal','No proper API exists for constant tensors?!')
ELSE
Handle % Rtensor(:,:) = ptr % FValues(:,:,1)
END IF
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
END IF
CASE( LIST_TYPE_VARIABLE_TENSOR )
IF( Handle % IntVarCount > 0 ) THEN
T(1:Handle % IntVarCount) = DummyVals
END IF
j0 = Handle % IntVarCount + 1
DO j=j0,Handle % ParNo
IF( Handle % ParUsed(j) ) THEN
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
END IF
END DO
IF( Handle % SomeVarAtIp ) THEN
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, GaussPoint, Basis, &
Handle % IntVarCount, tstep )
END IF
IF ( ptr % PROCEDURE /= 0 ) THEN
IF( PRESENT( GaussPoint ) ) THEN
j = -GaussPoint
ELSE
j = 0
END IF
CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, &
j, T, Handle % RTensor )
ELSE
IF( Handle % ParNo /= 1 ) THEN
CALL Fatal('ListGetElementReal','Table dependence only for one variable!')
END IF
DO j2=1,n
DO k2=1,m
Handle % Rtensor(j2,k2) = InterpolateCurve(ptr % TValues, ptr % FValues(j2,k2,:), &
T(1), ptr % CubicCoeff )
END DO
END DO
END IF
CASE( LIST_TYPE_VARIABLE_TENSOR_STR )
Handle % GlobalInList = .FALSE.
IF( Handle % IntVarCount > 0 ) THEN
T(1:Handle % IntVarCount) = DummyVals
END IF
j0 = Handle % IntVarCount + 1
DO j=j0,Handle % ParNo
IF( Handle % ParUsed(j) ) THEN
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
END IF
END DO
IF( Handle % SomeVarAtIp ) THEN
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, GaussPoint, Basis, &
Handle % IntVarCount, tstep )
END IF
IF ( .NOT. ptr % LuaFun ) THEN
Handle % Rtensor = GetMatcRealArray(ptr % Cvalue,n,m,Handle % ParNo,T)
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, Handle % RTensor, j )
END IF
CASE DEFAULT
CALL Fatal('ListGetElementReal','Unknown case for avaluation at ip: '//I2S(ptr % Type))
END SELECT
ELSE
IF( Handle % IntVarCount > 0 ) THEN
CALL Fatal('ListGetElementReal','It is assumed that dummy variables are given on IP points only!')
END IF
IF( ASSOCIATED( PElement, Handle % Element ) ) THEN
IF( PRESENT( Indexes ) ) THEN
ni = SIZE( Indexes )
NodeIndexes => Indexes
ELSE
ni = Handle % Element % TYPE % NumberOfNodes
NodeIndexes => PElement % NodeIndexes
END IF
F => Handle % Values
ElementSame = .TRUE.
ELSE
IF( .NOT. Handle % AllocationsDone ) THEN
ni = CurrentModel % Mesh % MaxElementNodes
ALLOCATE( Handle % Values(ni) )
Handle % Values = 0.0_dp
IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN
ALLOCATE( Handle % ParValues(MAX_FNC,ni), Handle % ParUsed(MAX_FNC) )
Handle % ParValues = 0.0_dp
Handle % ParUsed = .FALSE.
END IF
Handle % AllocationsDone = .TRUE.
END IF
Handle % Element => PElement
F => Handle % Values
IF( PRESENT( Indexes ) ) THEN
ni = SIZE( Indexes )
NodeIndexes => Indexes
ELSE
ni = PElement % TYPE % NumberOfNodes
NodeIndexes => PElement % NodeIndexes
END IF
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetElementReal', 'Value type for property ['//TRIM(Handle % Name)// &
'] not used consistently.')
END IF
F(1) = ptr % Coeff * ptr % Fvalues(1,1,1)
CASE( LIST_TYPE_VARIABLE_SCALAR )
DO i=1,ni
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
k, T, j )
IF ( ptr % PROCEDURE /= 0 ) THEN
F(i) = ptr % Coeff * &
ExecRealFunction( ptr % PROCEDURE,CurrentModel, &
NodeIndexes(i), T )
ELSE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal('ListGetElementReal','Value type for property ['//TRIM(Handle % Name)// &
'] not used consistently!')
END IF
F(i) = ptr % Coeff * &
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
T(1), ptr % CubicCoeff )
IF( Handle % GlobalInList ) EXIT
END IF
END DO
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
IF ( ptr % LuaFun ) THEN
CALL Fatal('ListGetElementReal','No routine for constant scalars LUA available!')
ELSE
TVar => VariableGet( CurrentModel % Variables, 'Time' )
F(1) = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % values,'st')
END IF
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
DO i=1,ni
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
k, T, j )
IF ( .NOT. ptr % LuaFun ) THEN
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
F(i) = ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
END IF
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, F(i), j )
END IF
IF( Handle % GlobalInList ) EXIT
END DO
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE == 0 ) THEN
CALL Fatal('ListGetElementReal','Value type for property ['//TRIM(Handle % Name)// &
'] not used consistently!')
END IF
DO i=1,ni
F(i) = ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), &
CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), &
CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) )
END DO
CASE ( LIST_TYPE_CONSTANT_TENSOR )
n = SIZE( Handle % Rtensor, 1 )
m = SIZE( Handle % Rtensor, 2 )
IF ( ptr % PROCEDURE /= 0 ) THEN
DO i=1,n
DO j=1,m
Handle % Rtensor(i,j) = ExecConstRealFunction( ptr % PROCEDURE, &
CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp )
END DO
END DO
ELSE
Handle % Rtensor(:,:) = ptr % FValues(:,:,1)
END IF
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
END IF
CASE( LIST_TYPE_VARIABLE_TENSOR )
Handle % GlobalInList = .FALSE.
IF( PRESENT( Indexes ) ) THEN
n = SIZE( Indexes )
NodeIndexes => Indexes
ELSE
n = Handle % Element % TYPE % NumberOfNodes
NodeIndexes => Handle % Element % NodeIndexes
END IF
n = SIZE( Handle % Rtensor, 1 )
m = SIZE( Handle % Rtensor, 2 )
DO i=1,ni
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
k, T, j )
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, &
NodeIndexes(i), T, Handle % RTensor )
ELSE
DO j2=1,n
DO k2=1,m
Handle % Rtensor(j2,k2) = InterpolateCurve(ptr % TValues, ptr % FValues(j2,k2,:), &
T(1), ptr % CubicCoeff )
END DO
END DO
END IF
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
END IF
IF( Handle % GlobalInList ) EXIT
Handle % RtensorValues(1:n,1:m,i) = Handle % Rtensor(1:n,1:m)
END DO
CASE( LIST_TYPE_VARIABLE_TENSOR_STR )
Handle % GlobalInList = .FALSE.
IF( PRESENT( Indexes ) ) THEN
n = SIZE( Indexes )
NodeIndexes => Indexes
ELSE
n = Handle % Element % TYPE % NumberOfNodes
NodeIndexes => Handle % Element % NodeIndexes
END IF
n = SIZE( Handle % Rtensor, 1 )
m = SIZE( Handle % Rtensor, 2 )
DO i=1,ni
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
k, T, j )
IF ( .NOT. ptr % LuaFun ) THEN
Handle % Rtensor = GetMatcRealArray(ptr % Cvalue,n,m,j,T)
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, Handle % RTensor, j )
END IF
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
END IF
IF( Handle % GlobalInList ) EXIT
Handle % RtensorValues(1:n,1:m,i) = Handle % Rtensor(1:n,1:m)
END DO
END SELECT
END IF
IF( Handle % Rdim == 0 ) THEN
IF( Handle % GlobalInList ) THEN
RValue = F(1)
ELSE
IF(.NOT. PRESENT(Basis)) THEN
CALL Fatal('ListGetElementReal','Parameter > Basis < is required for: '//TRIM(Handle % Name))
ELSE
RValue = SUM( Basis(1:ni) * F(1:ni) )
END IF
END IF
ELSE
Rtensor => Handle % Rtensor
Rdim = Handle % Rdim
IF( .NOT. Handle % GlobalInList ) THEN
IF(.NOT. PRESENT(Basis)) THEN
CALL Fatal('ListGetElementReal','Parameter > Basis < is required for: '//TRIM(Handle % Name))
ELSE
DO j2=1,SIZE( Handle % RTensor, 1 )
DO k2=1,SIZE( Handle % RTensor, 2 )
Handle % RTensor(j2,k2) = SUM( Basis(1:ni) * Handle % RtensorValues(j2,k2,1:ni) )
END DO
END DO
END IF
END IF
END IF
END IF
IF ( Handle % GotMinv ) THEN
IF ( RValue < Handle % minv ) THEN
WRITE( Message,*) 'Given value ',RValue, ' for property: ', '[', TRIM(Handle % Name),']', &
' smaller than given minimum: ', Handle % minv
CALL Fatal( 'ListGetElementReal', Message )
END IF
END IF
IF ( Handle % GotMaxv ) THEN
IF ( RValue > Handle % maxv ) THEN
WRITE( Message,*) 'Given value ',RValue, ' for property: ', '[', TRIM(Handle % Name),']', &
' larger than given maximum ', Handle % maxv
CALL Fatal( 'ListGetElementReal', Message )
END IF
END IF
END FUNCTION ListGetElementReal
FUNCTION ListGetElementIm( Handle,Basis,Element,Found,Indexes,&
GaussPoint,Rdim,Rtensor) RESULT(Rvalue)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: Rdim
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
REAL(KIND=dp) :: Rvalue
IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
CALL Fatal('ListGetElementIm','Initialize with imaginary component!')
END IF
Rvalue = ListGetElementReal(Handle % HandleIm,Basis,Element,Found,Indexes,&
GaussPoint,Rdim,Rtensor)
END FUNCTION ListGetElementIm
FUNCTION ListGetElementComplex( Handle,Basis,Element,Found,Indexes,&
GaussPoint,Rdim,Rtensor) RESULT(Zvalue)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: Rdim
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
COMPLEX(KIND=dp) :: Zvalue
REAL(KIND=dp) :: RValue, Ivalue
LOGICAL :: RFound
IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
CALL Fatal('ListGetElementComplex','Initialize with imaginary component!')
END IF
IF( Handle % NotPresentAnywhere .AND. Handle % HandleIm % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
Zvalue = CMPLX( Handle % DefRValue, 0.0_dp )
RETURN
END IF
Rvalue = ListGetElementReal(Handle,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) RFound = Found
Ivalue = ListGetElementReal(Handle % HandleIm,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) Found = Found .OR. RFound
Zvalue = CMPLX( Rvalue, Ivalue )
END FUNCTION ListGetElementComplex
FUNCTION ListGetElementReal3D( Handle,Basis,Element,Found,Indexes,&
GaussPoint,Rdim,Rtensor) RESULT(RValue3D)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: Rdim
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
REAL(KIND=dp) :: RValue3D(3)
LOGICAL :: Found1, Found2
IF(.NOT. ASSOCIATED( Handle % Handle2 ) ) THEN
CALL Fatal('ListGetElementReal3D','Initialize with 3D components!')
END IF
IF( Handle % NotPresentAnywhere .AND. Handle % Handle2 % NotPresentAnywhere &
.AND. Handle % Handle3 % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
RValue3D = 0.0_dp
RETURN
END IF
Rvalue3D(1) = ListGetElementReal(Handle,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) Found1 = Found
Rvalue3D(2) = ListGetElementReal(Handle % Handle2,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) Found2 = Found
Rvalue3D(3) = ListGetElementReal(Handle % Handle3,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) Found = Found1 .OR. Found2 .OR. Found
END FUNCTION ListGetElementReal3D
FUNCTION ListGetElementRealGrad( Handle,dBasisdx,Element,Found,Indexes,tstep) RESULT(RGrad)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp) :: dBasisdx(:,:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
INTEGER, OPTIONAL :: tstep
REAL(KIND=dp) :: RGrad(3)
LOGICAL :: Lfound
INTEGER :: i
RGrad = 0.0_dp
IF( Handle % NotPresentAnywhere ) THEN
IF( PRESENT( Found ) ) Found = .FALSE.
RETURN
END IF
IF( Handle % ConstantEverywhere ) THEN
IF( PRESENT( Found ) ) Found = .TRUE.
RETURN
END IF
DO i=1,3
RGrad(i) = ListGetElementReal(Handle,dBasisdx(:,i),Element,Lfound,Indexes,tstep=tstep)
IF(.NOT. Lfound ) EXIT
END DO
IF( PRESENT( Found ) ) Found = Lfound
END FUNCTION ListGetElementRealGrad
FUNCTION ListGetElementRealDiv( Handle,dBasisdx,Element,Found,Indexes) RESULT(Rdiv)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp) :: dBasisdx(:,:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
REAL(KIND=dp) :: Rdiv, Rdiv_comps(3)
LOGICAL :: Found1
IF(PRESENT(Found)) Found = .FALSE.
Rdiv = 0.0_dp
IF(.NOT. ASSOCIATED( Handle % Handle2 ) ) THEN
CALL Fatal('ListGetElementReal3D','Initialize with 3D components!')
END IF
IF( Handle % NotPresentAnywhere .AND. Handle % Handle2 % NotPresentAnywhere &
.AND. Handle % Handle3 % NotPresentAnywhere ) THEN
RETURN
END IF
Rdiv_comps(1) = ListGetElementReal(Handle,dBasisdx(:,1),Element,Found1,Indexes)
IF(.NOT. Found1) RETURN
Rdiv_comps(2) = ListGetElementReal(Handle % Handle2,dBasisdx(:,2),Element,Found1,Indexes)
Rdiv_comps(3) = ListGetElementReal(Handle % Handle3,dBasisdx(:,3),Element,Found1,Indexes)
Rdiv = SUM(Rdiv_comps)
IF( PRESENT( Found ) ) Found = .TRUE.
END FUNCTION ListGetElementRealDiv
FUNCTION ListGetElementComplex3D( Handle,Basis,Element,Found,Indexes,&
GaussPoint,Rdim,Rtensor) RESULT(ZValue3D)
TYPE(ValueHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
INTEGER, POINTER, OPTIONAL :: Indexes(:)
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: Rdim
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
COMPLEX(KIND=dp) :: ZValue3D(3)
REAL(KIND=dp) :: RValue3D(3), IValue3D(3)
LOGICAL :: RFound
IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
CALL Fatal('ListGetElementComplex3D','Initialize with imaginary component!')
END IF
Rvalue3D = ListGetElementReal3D(Handle,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) RFound = Found
Ivalue3D = ListGetElementReal3D(Handle % HandleIm,Basis,Element,Found,Indexes,GaussPoint)
IF( PRESENT( Found ) ) Found = Found .OR. RFound
Zvalue3D = CMPLX( Rvalue3D, Ivalue3D )
END FUNCTION ListGetElementComplex3D
FUNCTION ListGetElementRealVec( Handle,ngp,BasisVec,Element,Found ) RESULT( Rvalues )
TYPE(ValueHandle_t) :: Handle
INTEGER :: ngp
REAL(KIND=dp), OPTIONAL :: BasisVec(:,:)
LOGICAL, OPTIONAL :: Found
TYPE(Element_t), POINTER, OPTIONAL :: Element
REAL(KIND=dp), POINTER :: Rvalues(:)
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER, POINTER :: NodeIndexes(:)
REAL(KIND=dp) :: T(MAX_FNC),x,y,z, RValue
REAL(KIND=dp), POINTER :: F(:)
REAL(KIND=dp), POINTER :: ParF(:,:)
INTEGER :: i,j,k,k1,l,l0,l1,lsize,n,bodyid,id,node,gp
TYPE(Element_t), POINTER :: PElement
TYPE(ValueList_t), POINTER :: List
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes, ListSame, ListFound, &
GotIt, IntFound, SizeSame
IF( Handle % nValuesVec < ngp ) THEN
IF( Handle % nValuesVec > 0 ) THEN
DEALLOCATE( Handle % ValuesVec )
END IF
ALLOCATE( Handle % ValuesVec(ngp) )
Handle % nValuesVec = ngp
IF( Handle % ConstantEverywhere ) THEN
Handle % ValuesVec = Handle % Rvalue
ELSE
Handle % ValuesVec = Handle % DefRValue
END IF
Handle % ListId = -1
SizeSame = .FALSE.
ELSE
SizeSame = .TRUE.
END IF
Rvalues => Handle % ValuesVec
IF( Handle % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
RETURN
END IF
IF( Handle % ConstantEverywhere ) THEN
IF(PRESENT(Found)) Found = .TRUE.
RETURN
END IF
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
IF( ListSame .AND. SizeSame ) THEN
IF( PRESENT( Found ) ) Found = Handle % Found
IF( .NOT. Handle % Found ) RETURN
IF( Handle % GlobalInList ) THEN
RETURN
ELSE
ptr => Handle % ptr % head
END IF
ELSE IF( ListFound ) THEN
ptr => ListFind(List,Handle % Name,IntFound)
IF(PRESENT(Found)) Found = IntFound
Handle % Found = IntFound
IF(.NOT. IntFound ) THEN
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementRealVec','Could not find required keyword in list: '//TRIM(Handle % Name))
END IF
Handle % ValuesVec = Handle % DefRValue
RETURN
END IF
Handle % Ptr % Head => ptr
IF( Handle % SomewhereEvaluateAtIp ) THEN
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN
Handle % EvaluateAtIp = ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt )
ELSE
Handle % EvaluateAtIp = .FALSE.
END IF
END IF
IF( ptr % DepNameLen > 0 ) THEN
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, &
Handle % Name, Handle % VarCount, Handle % VarTable, &
SomeAtIp, SomeAtNodes, AllGlobal, 0, List )
IF( SomeAtIp ) Handle % EvaluateAtIp = .TRUE.
Handle % GlobalInList = ( AllGlobal .AND. ptr % PROCEDURE == 0 )
IF( AllGlobal ) Handle % EvaluateAtIp = .FALSE.
Handle % SomeVarAtIp = SomeAtIp
ELSE
Handle % GlobalInList = ( ptr % PROCEDURE == 0 )
END IF
IF( Handle % IntVarCount > 0 ) THEN
CALL Fatal('ListGetElementRealVec','Not yet implemented for dummy variables!')
END IF
ELSE
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementRealVec','Could not find list for required keyword: '//TRIM(Handle % Name))
END IF
IF( .NOT. Handle % AllocationsDone ) THEN
n = CurrentModel % Mesh % MaxElementNodes
ALLOCATE( Handle % Values(n) )
Handle % Values = 0.0_dp
IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN
ALLOCATE( Handle % ParValues(MAX_FNC,n), Handle % ParUsed(MAX_FNC) )
Handle % ParValues = 0.0_dp
Handle % ParUsed = .FALSE.
END IF
Handle % AllocationsDone = .TRUE.
END IF
Handle % ValuesVec = Handle % DefRValue
IF( PRESENT(Found) ) THEN
Found = .FALSE.
Handle % Found = .FALSE.
END IF
RETURN
END IF
IF( Handle % EvaluateAtIp ) THEN
IF(.NOT. PRESENT(BasisVec)) THEN
CALL Fatal('ListGetElementRealVec','Parameter > Basis < is required for: '//TRIM(Handle % Name))
END IF
IF( .NOT. Handle % AllocationsDone ) THEN
n = CurrentModel % Mesh % MaxElementNodes
ALLOCATE( Handle % Values(n) )
Handle % Values = 0.0_dp
ALLOCATE( Handle % ParValues(MAX_FNC,n) )
Handle % ParValues = 0.0_dp
Handle % AllocationsDone = .TRUE.
END IF
Handle % Element => PElement
n = PElement % TYPE % NumberOfNodes
NodeIndexes => PElement % NodeIndexes
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_TENSOR .OR. &
ptr % TYPE == LIST_TYPE_VARIABLE_TENSOR_STR ) THEN
IF(.NOT. ASSOCIATED( Handle % ParValues )) THEN
ALLOCATE( Handle % ParValues(MAX_FNC,CurrentModel % Mesh % MaxElementNodes) )
Handle % ParValues = 0.0_dp
END IF
DO i=1,n
node = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, node, T, j )
IF( Handle % GlobalInList ) THEN
CALL Warn('ListGetElementRealVec','Constant expression need not be evaluated at IPs!')
END IF
Handle % ParNo = j
Handle % ParValues(1:j,i) = T(1:j)
END DO
ParF => Handle % ParValues
END IF
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_VARIABLE_SCALAR )
IF ( ptr % PROCEDURE /= 0 ) THEN
node = 0
DO gp = 1, ngp
DO j=1,Handle % ParNo
T(j) = SUM( BasisVec(gp,1:n) * ParF(j,1:n) )
END DO
Rvalue = ExecRealFunction( ptr % PROCEDURE, CurrentModel, node, T )
Handle % ValuesVec(gp) = RValue
END DO
ELSE
DO gp = 1, ngp
DO j=1,Handle % ParNo
T(j) = SUM( BasisVec(gp,1:n) * ParF(j,1:n) )
END DO
RValue = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
T(1), ptr % CubicCoeff )
Handle % ValuesVec(gp) = RValue
END DO
END IF
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
node = 0
DO gp = 1, ngp
DO j=1,Handle % ParNo
T(j) = SUM( BasisVec(gp,1:n) * Handle % ParValues(j,1:n) )
END DO
IF( Handle % SomeVarAtIp ) THEN
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, gp, BasisVec(gp,1:n) )
END IF
IF ( .NOT. ptr % LuaFun ) THEN
Rvalue = GetMatcReal(ptr % Cvalue,Handle % Parno,T)
ELSE
CALL ElmerEvalLua(LuaState, ptr, T, RValue, j)
END IF
Handle % ValuesVec(gp) = RValue
END DO
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE /= 0 ) THEN
DO gp = 1, ngp
x = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % x( NodeIndexes(1:n)))
y = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % y( NodeIndexes(1:n)))
z = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % z( NodeIndexes(1:n)))
RValue = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,x,y,z)
Handle % ValuesVec(gp) = RValue
END DO
ELSE
CALL Fatal('ListGetElementRealVec','Constant scalar evaluation failed at ip!')
END IF
CASE DEFAULT
CALL Fatal('ListGetElementRealVec','Unknown case for avaluation at ip')
END SELECT
ELSE
IF( .NOT. Handle % AllocationsDone ) THEN
n = CurrentModel % Mesh % MaxElementNodes
ALLOCATE( Handle % Values(n) )
Handle % Values = 0.0_dp
IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN
ALLOCATE( Handle % ParValues(MAX_FNC,n) )
Handle % ParValues = 0.0_dp
END IF
Handle % AllocationsDone = .TRUE.
END IF
Handle % Element => PElement
n = PElement % TYPE % NumberOfNodes
NodeIndexes => PElement % NodeIndexes
F => Handle % Values
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_CONSTANT_SCALAR )
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetElementRealVec', 'Value type for property ['//TRIM(Handle % Name)// &
'] not used consistently.')
END IF
F(1) = ptr % Coeff * ptr % Fvalues(1,1,1)
RValues = F(1)
CASE( LIST_TYPE_VARIABLE_SCALAR )
DO i=1,n
node = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, node, T, j )
IF ( ptr % PROCEDURE /= 0 ) THEN
F(i) = ptr % Coeff * &
ExecRealFunction( ptr % PROCEDURE,CurrentModel, &
NodeIndexes(i), T )
ELSE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetElementRealVec', 'Value type for property ['//TRIM(Handle % Name)// &
'] not used consistently.')
END IF
F(i) = ptr % Coeff * &
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
T(1), ptr % CubicCoeff )
IF( Handle % GlobalInList ) EXIT
END IF
END DO
IF( Handle % GlobalInList ) THEN
Handle % ValuesVec = F(1)
ELSE
Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) )
END IF
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
TVar => VariableGet( CurrentModel % Variables, 'Time' )
Handle % ValuesVec = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % Values,'st')
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
DO i=1,n
k = NodeIndexes(i)
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j )
IF ( .NOT. ptr % LuaFun ) THEN
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
F(i) = ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
END IF
ELSE
call ElmerEvalLuaS(LuaState, ptr, T, F(i), j)
F(i) = ptr % coeff * F(i)
END IF
IF( Handle % GlobalInList ) EXIT
END DO
IF( Handle % GlobalInList ) THEN
Handle % ValuesVec = F(1)
ELSE
Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) )
END IF
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
IF ( ptr % PROCEDURE == 0 ) THEN
CALL Fatal( 'ListGetElementRealVec', 'Value type for property ['//TRIM(Handle % Name)// &
'] not used consistently.')
END IF
DO i=1,n
F(i) = ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), &
CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), &
CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) )
END DO
Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) )
CASE DEFAULT
CALL Info('ListGetElementRealVec','This one implemented ONLY for "ListGetElementReal"',Level=3)
CALL Fatal('ListGetElementRealVec','Impossible entry type for "'&
//TRIM(Handle % Name)//'": '//I2S(ptr % TYPE))
END SELECT
END IF
END FUNCTION ListGetElementRealVec
FUNCTION ListGetElementLogical( Handle, Element, Found ) RESULT(Lvalue)
TYPE(ValueHandle_t) :: Handle
TYPE(Element_t), POINTER, OPTIONAL :: Element
LOGICAL, OPTIONAL :: Found
LOGICAL :: Lvalue
TYPE(ValueList_t), POINTER :: List
TYPE(Element_t), POINTER :: PElement
LOGICAL :: ListSame, ListFound, LFound
INTEGER :: id, BodyId
IF( Handle % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
Lvalue = Handle % DefLValue
RETURN
END IF
IF( Handle % ConstantEverywhere ) THEN
IF(PRESENT(Found)) Found = .TRUE.
Lvalue = Handle % LValue
RETURN
END IF
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
IF( ListSame ) THEN
IF( PRESENT( Found ) ) Found = Handle % Found
LValue = Handle % LValue
ELSE IF( ListFound ) THEN
LValue = ListGetLogical( List, Handle % Name, LFound, UnfoundFatal = Handle % UnfoundFatal )
Handle % LValue = LValue
Handle % Found = LFound
IF(PRESENT(Found)) Found = .TRUE.
ELSE
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementLogical','Could not find list for required keyword: '//TRIM(Handle % Name))
END IF
Lvalue = Handle % DefLValue
Handle % Found = .FALSE.
IF( PRESENT(Found) ) Found = .FALSE.
END IF
END FUNCTION ListGetElementLogical
FUNCTION ListGetElementInteger( Handle, Element, Found ) RESULT(Ivalue)
TYPE(ValueHandle_t) :: Handle
TYPE(Element_t), POINTER, OPTIONAL :: Element
LOGICAL, OPTIONAL :: Found
INTEGER :: Ivalue
TYPE(ValueList_t), POINTER :: List
TYPE(Element_t), POINTER :: PElement
LOGICAL :: ListSame, ListFound
INTEGER :: id, BodyId
IF( Handle % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
Ivalue = Handle % DefIValue
RETURN
END IF
IF( Handle % ConstantEverywhere ) THEN
IF(PRESENT(Found)) Found = .TRUE.
Ivalue = Handle % IValue
RETURN
END IF
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
IF( ListSame ) THEN
IF( PRESENT( Found ) ) Found = Handle % Found
IValue = Handle % IValue
ELSE IF( ListFound ) THEN
IValue = ListGetInteger( List, Handle % Name, Found, UnfoundFatal = Handle % UnfoundFatal )
Handle % IValue = IValue
IF(PRESENT(Found)) Handle % Found = Found
ELSE
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementInteger','Could not find list for required keyword: '//TRIM(Handle % Name))
END IF
Ivalue = Handle % DefIValue
Handle % IValue = IValue
IF( PRESENT(Found) ) THEN
Found = .FALSE.
Handle % Found = .FALSE.
END IF
END IF
END FUNCTION ListGetElementInteger
FUNCTION ListGetElementString( Handle, Element, Found ) RESULT( CValue )
TYPE(ValueHandle_t) :: Handle
CHARACTER(LEN=MAX_NAME_LEN) :: CValue
TYPE(Element_t), POINTER, OPTIONAL :: Element
LOGICAL, OPTIONAL :: Found
TYPE(ValueList_t), POINTER :: List
TYPE(Element_t), POINTER :: PElement
LOGICAL :: ListSame, ListFound
INTEGER :: id, BodyId
IF( Handle % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
Cvalue = ' '
RETURN
END IF
IF( Handle % ConstantEverywhere ) THEN
IF(PRESENT(Found)) Found = .TRUE.
Cvalue = TRIM(Handle % CValue)
RETURN
END IF
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
IF( ListSame ) THEN
IF( PRESENT( Found ) ) Found = Handle % Found
CValue = Handle % CValue(1:Handle % CValueLen)
ELSE IF( ListFound ) THEN
CValue = ListGetString( List, Handle % Name, Found, &
UnfoundFatal = Handle % UnfoundFatal )
Handle % CValue = TRIM(CValue)
Handle % CValueLen = len_trim(CValue)
IF(PRESENT(Found)) Handle % Found = Found
ELSE
IF( Handle % UnfoundFatal ) THEN
CALL Fatal('ListGetElementString','Could not find list for required keyword: '//TRIM(Handle % Name))
END IF
Cvalue = ' '
Handle % CValueLen = 0
IF( PRESENT(Found) ) THEN
Found = .FALSE.
Handle % Found = .FALSE.
END IF
END IF
END FUNCTION ListGetElementString
FUNCTION ListGetElementSomewhere( Handle ) RESULT( Found )
TYPE(ValueHandle_t) :: Handle
LOGICAL :: Found
Found = .NOT. ( Handle % NotPresentAnywhere )
END FUNCTION ListGetElementSomewhere
FUNCTION ListCompareElementString( Handle, CValue2, Element, Found ) RESULT( SameString )
TYPE(ValueHandle_t) :: Handle
CHARACTER(LEN=*) :: CValue2
TYPE(Element_t), POINTER, OPTIONAL :: Element
LOGICAL, OPTIONAL :: Found
LOGICAL :: SameString
CHARACTER(LEN=MAX_NAME_LEN) :: CValue
TYPE(ValueList_t), POINTER :: List
TYPE(Element_t), POINTER :: PElement
LOGICAL :: ListSame, ListFound, IntFound
INTEGER :: id, BodyId
SameString = .FALSE.
IF( Handle % NotPresentAnywhere ) THEN
IF(PRESENT(Found)) Found = .FALSE.
RETURN
END IF
IF( Handle % ConstantEverywhere ) THEN
IF(PRESENT(Found)) Found = .TRUE.
SameString = ( CValue2 == Handle % CValue(1:Handle % CValueLen) )
RETURN
END IF
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
ListSame = .FALSE.
ListFound = .FALSE.
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
IF( ListSame ) THEN
IF( PRESENT( Found ) ) Found = Handle % Found
IF( Handle % Found ) THEN
SameString = ( Handle % CValue(1:Handle % CValueLen) == CValue2 )
END IF
ELSE IF( ListFound ) THEN
CValue = ListGetString( List, Handle % Name, IntFound, &
UnfoundFatal = Handle % UnfoundFatal )
Handle % Found = IntFound
IF( IntFound ) THEN
Handle % CValueLen = len_trim(CValue)
Handle % CValue = CValue(1:Handle % CValueLen )
SameString = (Handle % CValue(1:Handle % CValueLen) == CValue2 )
END IF
IF(PRESENT(Found)) Found = IntFound
ELSE
Handle % Cvalue = ' '
Handle % CValueLen = 0
Handle % Found = .FALSE.
IF( PRESENT(Found) ) Found = .FALSE.
END IF
END FUNCTION ListCompareElementString
SUBROUTINE ListInitElementVariable( Handle, Name, USolver, UVariable, tStep, Found )
TYPE(VariableHandle_t) :: Handle
CHARACTER(LEN=*), OPTIONAL :: Name
TYPE(Solver_t), OPTIONAL, TARGET :: USolver
TYPE(Variable_t), OPTIONAL, TARGET :: UVariable
INTEGER, OPTIONAL :: tStep
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp), POINTER :: Values(:)
TYPE(Variable_t), POINTER :: Variable
TYPE(Solver_t) , POINTER :: Solver
TYPE(Element_t), POINTER :: Element
Handle % Variable => NULL()
Handle % Values => NULL()
Handle % Perm => NULL()
Handle % Element => NULL()
Handle % dofs = 0
Handle % Found = .FALSE.
IF ( PRESENT(USolver) ) THEN
Solver => USolver
ELSE
Solver => CurrentModel % Solver
END IF
IF ( PRESENT(name) ) THEN
Variable => VariableGet( Solver % Mesh % Variables, name )
ELSE IF( PRESENT( UVariable ) ) THEN
Variable => UVariable
ELSE
Variable => Solver % Variable
END IF
IF( PRESENT( Found ) ) Found = Handle % Found
IF ( .NOT. ASSOCIATED( Variable ) ) RETURN
Handle % Variable => Variable
Handle % dofs = Variable % Dofs
Handle % Found = .TRUE.
IF ( PRESENT(tStep) ) THEN
IF ( tStep < 0 ) THEN
IF ( ASSOCIATED(Variable % PrevValues) ) THEN
IF ( -tStep<=SIZE(Variable % PrevValues,2)) &
Handle % Values => Variable % PrevValues(:,-tStep)
END IF
END IF
ELSE
Handle % Values => Variable % Values
END IF
Handle % Perm => Variable % Perm
IF(PRESENT(Found)) Found = Handle % Found
END SUBROUTINE ListInitElementVariable
FUNCTION ListGetElementScalarSolution( Handle, Basis, Element, Found, &
GaussPoint, dof ) RESULT ( Val )
TYPE(VariableHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
TYPE( Element_t), POINTER, OPTIONAL :: Element
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: dof
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp) :: Val
TYPE( Element_t), POINTER :: pElement
INTEGER :: i,j, k, n
INTEGER, POINTER :: Indexes(:)
LOGICAL :: SameElement
Val = 0.0_dp
IF( PRESENT( Found ) ) Found = .FALSE.
IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
SameElement = ASSOCIATED( Handle % Element, pElement )
IF( SameElement ) THEN
IF( .NOT. Handle % ActiveElement ) RETURN
ELSE
Handle % Element => pElement
END IF
IF( Handle % dofs > 1 ) THEN
IF( .NOT. PRESENT( dof ) ) THEN
CALL Fatal('ListGetElementScalarSolution','Argument "dof" is needed for vector fields!')
END IF
END IF
IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN
IF( .NOT. PRESENT( GaussPoint ) ) THEN
CALL Fatal('ListGetElementScalarSolution','Argument "GaussPoint" required as an argument!')
END IF
j = pElement % ElementIndex
IF( .NOT. SameElement ) THEN
n = Handle % Perm(j+1) - Handle % Perm(j)
Handle % ActiveElement = ( n > 0 )
IF( n == 0 ) RETURN
END IF
k = Handle % Perm(j) + GaussPoint
IF( Handle % Dofs == 1 ) THEN
val = Handle % Values( k )
ELSE
val = Handle % Values( Handle % Dofs * (k-1) + dof )
END IF
ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN
j = Handle % Perm( pElement % ElementIndex )
Handle % ActiveElement = ( j > 0 )
IF( j == 0 ) RETURN
IF( Handle % Dofs == 1 ) THEN
val = Handle % Values( j )
ELSE
val = Handle % Values( Handle % Dofs * (j-1) + dof )
END IF
ELSE
IF( .NOT. PRESENT( Basis ) ) THEN
CALL Fatal('ListGetElementScalarSolution',&
'Argument "Basis" required for non gauss-point variable!')
END IF
IF( .NOT. SameElement ) THEN
IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN
n = pElement % TYPE % NumberOfNodes
Indexes => pElement % DGIndexes
IF(.NOT. ASSOCIATED( Indexes ) ) THEN
CALL Fatal('ListGetElementScalarSolution','DGIndexes not associated!')
END IF
ELSE
n = pElement % TYPE % NumberOfNodes
Indexes => pElement % NodeIndexes
END IF
Handle % n = n
IF( ASSOCIATED( Handle % Perm ) ) THEN
Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) )
Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 )
IF(.NOT. Handle % ActiveElement ) RETURN
ELSE
Handle % Indexes(1:n) = [(i,i=1,4)]
Handle % ActiveElement = .TRUE.
END IF
END IF
n = Handle % n
IF( Handle % Dofs == 1 ) THEN
val = SUM( Basis(1:n) * Handle % Values( Handle % Indexes(1:n) ) )
ELSE
val = SUM( Basis(1:n) * Handle % Values( &
Handle % dofs*(Handle % Indexes(1:n)-1)+dof ) )
END IF
END IF
IF( PRESENT( Found ) ) Found = .TRUE.
END FUNCTION ListGetElementScalarSolution
FUNCTION ListGetElementScalarSolutionVec( Handle, ngp, Basis, Element, Found, dof ) RESULT ( Vals )
TYPE(VariableHandle_t) :: Handle
INTEGER :: ngp
REAL(KIND=dp), OPTIONAL :: Basis(:,:)
TYPE( Element_t), POINTER, OPTIONAL :: Element
INTEGER, OPTIONAL :: dof
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp), POINTER :: Vals(:)
TYPE( Element_t), POINTER :: pElement
INTEGER :: i,j, k, n
INTEGER, POINTER :: Indexes(:)
NULLIFY(Vals)
IF( PRESENT( Found ) ) Found = .FALSE.
IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
IF( ASSOCIATED( Handle % Element, pElement ) ) THEN
IF( Handle % ActiveElement ) THEN
Vals => Handle % IpValues
END IF
IF( PRESENT( Found ) ) Found = Handle % ActiveElement
RETURN
ELSE
Handle % Element => pElement
END IF
IF( Handle % dofs > 1 ) THEN
IF( .NOT. PRESENT( dof ) ) THEN
CALL Fatal('ListGetElementScalarSolutionVec','Argument "dof" is needed for vector fields!')
END IF
END IF
IF( Handle % ipN < ngp ) THEN
IF( Handle % ipN > 0 ) THEN
DEALLOCATE( Handle % ipValues )
END IF
ALLOCATE( Handle % ipValues(ngp) )
Handle % ipValues(1:ngp) = 0.0_dp
Handle % ipN = ngp
END IF
IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN
j = pElement % ElementIndex
n = Handle % Perm(j+1) - Handle % Perm(j)
Handle % ActiveElement = ( n > 0 )
IF( n == 0 ) RETURN
IF( n /= ngp ) THEN
CALL Fatal('ListGetElementScalarSolutionVec','Mismatch in number of Gauss points!')
END IF
k = Handle % Perm(j)
IF( Handle % Dofs == 1 ) THEN
Handle % ipValues(1:ngp) = Handle % Values(k+1:k+ngp)
ELSE
Handle % ipValues(1:ngp) = Handle % Values(k+dof:k+ngp*Handle % Dofs:Handle % Dofs)
END IF
Vals => Handle % ipValues
ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN
j = Handle % Perm( pElement % ElementIndex )
Handle % ActiveElement = ( j > 0 )
IF( j == 0 ) RETURN
IF( Handle % Dofs == 1 ) THEN
Handle % ipValues(1:ngp) = Handle % Values( j )
ELSE
Handle % ipValues(1:ngp) = Handle % Values( Handle % Dofs * (j-1) + dof )
END IF
Vals => Handle % ipValues
ELSE
IF( .NOT. PRESENT( Basis ) ) THEN
CALL Fatal('ListGetElementScalarSolutionVec',&
'Argument "Basis" required for non gauss-point variable!')
END IF
IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN
n = pElement % TYPE % NumberOfNodes
Indexes => pElement % DGIndexes
IF(.NOT. ASSOCIATED( Indexes ) ) THEN
CALL Fatal('ListGetElementScalarSolutionVec','DGIndexes not associated!')
END IF
ELSE
n = pElement % TYPE % NumberOfNodes
Indexes => pElement % NodeIndexes
END IF
Handle % n = n
IF( ASSOCIATED( Handle % Perm ) ) THEN
Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) )
Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 )
IF(.NOT. Handle % ActiveElement ) RETURN
ELSE
Handle % Indexes(1:n) = Indexes(1:n)
Handle % ActiveElement = .TRUE.
END IF
IF( Handle % Dofs == 1 ) THEN
Handle % ipValues(1:ngp) = MATMUL(Basis(1:ngp,1:n),&
Handle % Values( Handle % Indexes(1:n) ) )
ELSE
Handle % ipValues(1:ngp) = MATMUL(Basis(1:ngp,1:n),&
Handle % Values( Handle % Dofs*( Handle % Indexes(1:n)-1)+dof ) )
END IF
Vals => Handle % ipValues
END IF
IF( PRESENT( Found ) ) Found = ASSOCIATED( Vals )
END FUNCTION ListGetElementScalarSolutionVec
FUNCTION ListGetElementVectorSolutionVec( Handle, ngp, dim, Basis, Element, Found ) RESULT ( Vals )
TYPE(VariableHandle_t) :: Handle
INTEGER :: ngp, dim
REAL(KIND=dp), OPTIONAL :: Basis(:,:)
TYPE( Element_t), POINTER, OPTIONAL :: Element
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp), POINTER :: Vals(:,:)
TYPE( Element_t), POINTER :: pElement
INTEGER :: i,j, k, n, dof
INTEGER, POINTER :: Indexes(:)
NULLIFY(Vals)
IF( PRESENT( Found ) ) Found = .FALSE.
IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN
IF( PRESENT( Element ) ) THEN
PElement => Element
ELSE
PElement => CurrentModel % CurrentElement
END IF
IF( ASSOCIATED( Handle % Element, pElement ) ) THEN
IF( Handle % ActiveElement ) THEN
Vals => Handle % IpValues3D
END IF
IF( PRESENT( Found ) ) Found = Handle % ActiveElement
RETURN
ELSE
Handle % Element => pElement
END IF
IF( Handle % ipN < ngp ) THEN
IF( Handle % ipN > 0 ) THEN
DEALLOCATE( Handle % ipValues3D )
END IF
ALLOCATE( Handle % ipValues3D(ngp,Handle % dofs) )
Handle % ipValues3D(1:ngp,1:Handle % Dofs) = 0.0_dp
Handle % ipN = ngp
END IF
IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN
j = pElement % ElementIndex
n = Handle % Perm(j+1) - Handle % Perm(j)
Handle % ActiveElement = ( n > 0 )
IF( n == 0 ) RETURN
IF( n /= ngp ) THEN
CALL Fatal('ListGetElementVectorSolutionVec','Mismatch in number of Gauss points!')
END IF
k = Handle % Perm(j)
DO dof=1,MIN(Handle % dofs,dim)
Handle % ipValues3D(1:ngp,dof) = Handle % Values(k+dof:k+ngp*Handle % Dofs:Handle % Dofs)
END DO
Vals => Handle % ipValues3D
ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN
j = Handle % Perm( pElement % ElementIndex )
Handle % ActiveElement = ( j > 0 )
IF( j == 0 ) RETURN
DO dof=1,MIN(Handle % dofs,dim)
Handle % ipValues3D(1:ngp,dof) = Handle % Values( Handle % Dofs * (j-1) + dof )
END DO
Vals => Handle % ipValues3D
ELSE
IF( .NOT. PRESENT( Basis ) ) THEN
CALL Fatal('ListGetElementVectorSolutionVec',&
'Argument "Basis" required for non gauss-point variable!')
END IF
IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN
n = pElement % TYPE % NumberOfNodes
Indexes => pElement % DGIndexes
IF(.NOT. ASSOCIATED( Indexes ) ) THEN
CALL Fatal('ListGetElementVectorSolutionVec','DGIndexes not associated!')
END IF
ELSE
n = pElement % TYPE % NumberOfNodes
Indexes => pElement % NodeIndexes
END IF
Handle % n = n
IF( ASSOCIATED( Handle % Perm ) ) THEN
Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) )
Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 )
IF(.NOT. Handle % ActiveElement ) RETURN
ELSE
Handle % Indexes(1:n) = Indexes(1:n)
Handle % ActiveElement = .TRUE.
END IF
DO dof=1,MIN(Handle % dofs,dim)
Handle % ipValues3D(1:ngp,dof) = MATMUL(Basis(1:ngp,1:n),&
Handle % Values( Handle % Dofs*( Handle % Indexes(1:n)-1)+dof ) )
END DO
Vals => Handle % ipValues3D
END IF
IF( PRESENT( Found ) ) Found = ASSOCIATED( Vals )
END FUNCTION ListGetElementVectorSolutionVec
FUNCTION ListGetElementVectorSolution( Handle, Basis, Element, Found, GaussPoint, &
dofs ) &
RESULT ( Val3D )
TYPE(VariableHandle_t) :: Handle
REAL(KIND=dp), OPTIONAL :: Basis(:)
TYPE( Element_t), POINTER, OPTIONAL :: Element
INTEGER, OPTIONAL :: GaussPoint
INTEGER, OPTIONAL :: dofs
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp) :: Val3D(3)
INTEGER :: dof, Ldofs
Val3D = 0.0_dp
IF( .NOT. ASSOCIATED( Handle % Variable ) ) THEN
IF(PRESENT(Found)) Found = .FALSE.
RETURN
END IF
IF( PRESENT( dofs ) ) THEN
Ldofs = dofs
ELSE
Ldofs = MIN( 3, Handle % Dofs )
END IF
DO dof = 1, Ldofs
Val3D(dof) = ListGetElementScalarSolution( Handle, Basis, Element, Found, &
GaussPoint, dof )
IF( .NOT. Handle % ActiveElement ) RETURN
END DO
END FUNCTION ListGetElementVectorSolution
RECURSIVE FUNCTION ListGetConstRealArray( List,Name,Found,UnfoundFatal ) RESULT( F )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found, UnfoundFatal
REAL(KIND=dp), POINTER :: F(:,:)
INTEGER :: i,j,n,m
TYPE(ValueListEntry_t), POINTER :: ptr
NULLIFY( F )
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
CALL Fatal("ListGetConstRealArray", "Failed to find: "//TRIM(Name) )
END IF
END IF
RETURN
END IF
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetConstRealArray', 'Value type for property ['//TRIM(Name)// &
'] not used consistently.')
END IF
n = SIZE( ptr % FValues,1 )
m = SIZE( ptr % FValues,2 )
F => ptr % FValues(:,:,1)
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ListPushActiveName(name)
DO i=1,n
DO j=1,m
F(i,j) = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,0.0d0,0.0d0,0.0d0 )
END DO
END DO
CALL ListPopActiveName()
END IF
END FUNCTION ListGetConstRealArray
RECURSIVE FUNCTION ListGetConstRealArray1( List,Name,Found,UnfoundFatal ) RESULT( F )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found, UnfoundFatal
REAL(KIND=dp), POINTER :: F(:)
INTEGER :: i,j,n,m
TYPE(ValueListEntry_t), POINTER :: ptr
NULLIFY( F )
ptr => ListFind(List,Name,Found)
IF (.NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
CALL Fatal("ListGetConstRealArray1","Failed to find: "//TRIM(Name))
END IF
END IF
RETURN
END IF
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetConstRealArray1', 'Value type for property ['//TRIM(Name)// &
'] not used consistently.')
END IF
n = SIZE( ptr % FValues,1 )
m = SIZE( ptr % FValues,2 )
IF( m > 1 ) THEN
CALL Warn('ListGetConstRealArray1','The routine is designed for 1D arrays!')
END IF
F => ptr % FValues(:,1,1)
END FUNCTION ListGetConstRealArray1
RECURSIVE SUBROUTINE ListGetRealArray( List,Name,F,ni,NodeIndexes,Found, UnfoundFatal)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found, UnfoundFatal
INTEGER :: ni,NodeIndexes(:)
REAL(KIND=dp), POINTER :: F(:,:,:), G(:,:)
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
REAL(KIND=dp) :: T(MAX_FNC)
LOGICAL :: AllGlobal
INTEGER :: i,j,k,nlen,n,m,k1,l
ptr => ListFind(List,Name,Found)
IF ( .NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(UnfoundFatal)) THEN
IF(UnfoundFatal) THEN
CALL Fatal("ListGetConstRealArray","Failed to find: "//TRIM(Name))
END IF
END IF
RETURN
END IF
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetRealArray', &
'Value type for property > '// TRIM(Name) // '< not used consistently.')
END IF
n = SIZE(ptr % FValues,1)
m = SIZE(ptr % FValues,2)
IF ( .NOT.ASSOCIATED( F ) ) THEN
ALLOCATE( F(n,m,ni) )
ELSE IF ( SIZE(F,1)/=n.OR.SIZE(F,2)/=n.OR.SIZE(F,3)/=ni ) THEN
DEALLOCATE( F )
ALLOCATE( F(n,m,ni) )
END IF
SELECT CASE(ptr % TYPE)
CASE ( LIST_TYPE_CONSTANT_TENSOR )
DO i=1,ni
F(:,:,i) = ptr % Coeff * ptr % FValues(:,:,1)
END DO
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ListPushActiveName(name)
DO i=1,n
DO j=1,m
F(i,j,1) = ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE, &
CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp )
END DO
END DO
CALL ListPopActiveName()
END IF
CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR )
CALL ListPushActiveName(name)
DO i=1,ni
k = NodeIndexes(i)
CALL ListParseStrToValues( Ptr % DependName, Ptr % DepNameLen, k, Name, T, j, AllGlobal)
IF ( ANY(T(1:j)==HUGE(1._dP)) ) CYCLE
IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN
IF ( .NOT. ptr % LuaFun ) THEN
F(1:n,1:m,i) = GetMatcRealArray(ptr % Cvalue,n,m,j,T)
ELSE
call ElmerEvalLuaT(LuaState, ptr, T, F(:,:,i), j)
END IF
ELSE IF ( ptr % PROCEDURE /= 0 ) THEN
G => F(:,:,i)
CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, &
NodeIndexes(i), T, G )
ELSE
DO j=1,n
DO k=1,m
F(j,k,i) = InterpolateCurve(ptr % TValues, ptr % FValues(j,k,:), &
T(1), ptr % CubicCoeff )
END DO
END DO
END IF
IF( AllGlobal ) EXIT
END DO
CALL ListPopActiveName()
IF( AllGlobal ) THEN
DO i=2,ni
DO j=1,n
DO k=1,m
F(j,k,i) = F(j,k,1)
END DO
END DO
END DO
END IF
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
F = ptr % Coeff * F
END IF
CASE DEFAULT
F = 0.0d0
DO i=1,n
IF ( PRESENT( Found ) ) THEN
F(i,1,:) = ListGetReal( List,Name,ni,NodeIndexes,Found )
ELSE
F(i,1,:) = ListGetReal( List,Name,ni,NodeIndexes )
END IF
END DO
END SELECT
END SUBROUTINE ListGetRealArray
RECURSIVE SUBROUTINE ListGetRealVector( List,Name,F,ni,NodeIndexes,Found )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found
INTEGER :: ni,NodeIndexes(:)
REAL(KIND=dp), TARGET :: F(:,:)
TYPE(ValueListEntry_t), POINTER :: ptr
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
REAL(KIND=dp), ALLOCATABLE :: G(:,:)
REAL(KIND=dp) :: T(MAX_FNC)
REAL(KIND=dp), POINTER :: RotMatrix(:,:)
INTEGER :: i,j,k,nlen,n,m,k1,S1,S2,l, cnt
LOGICAL :: AllGlobal, lFound, AnyFound
ptr => ListFind(List,Name,lFound)
IF ( .NOT.ASSOCIATED(ptr) ) THEN
IF(PRESENT(Found)) Found = .FALSE.
AnyFound = .FALSE.
DO i=1,SIZE(F,1)
F(i,1:ni) = ListGetReal(List,TRIM(Name)//' '//I2S(i),ni,NodeIndexes,lFound)
AnyFound = AnyFound.OR.lFound
END DO
IF(PRESENT(Found)) THEN
Found = AnyFound
ELSE IF(.NOT.AnyFound) THEN
CALL Warn( 'ListFind', 'Requested property ['//TRIM(Name)//'] not found')
END IF
IF( .NOT. AnyFound ) RETURN
GOTO 200
ELSE
Found = lFound
END IF
F = 0._dp
cnt = 0
ALLOCATE(G(SIZE(F,1),SIZE(F,2)))
100 CONTINUE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetRealVector', &
'Value type for property > '// TRIM(Name) // '< not used consistently.')
END IF
n = SIZE(ptr % FValues,1)
SELECT CASE(ptr % TYPE)
CASE ( LIST_TYPE_CONSTANT_TENSOR )
DO i=1,n
G(:,i) = ptr % Coeff * ptr % FValues(:,1,1)
END DO
IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ListPushActiveName(name)
DO i=1,n
F(i,1) = ptr % Coeff * &
ExecConstRealFunction( ptr % PROCEDURE, &
CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp )
END DO
CALL ListPopActiveName()
END IF
CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR )
CALL ListPushActiveName(name)
DO i=1,ni
k = NodeIndexes(i)
CALL ListParseStrToValues( Ptr % DependName, Ptr % DepNameLen, k, Name, T, j, AllGlobal)
IF ( ANY(T(1:j)==HUGE(1._dP)) ) CYCLE
IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN
IF ( .NOT. ptr % LuaFun ) THEN
G(1:n,i) = GetMatcRealVector(ptr % Cvalue,n,j,T)
ELSE
CALL ElmerEvalLuaV(LuaState, ptr, T, G(:,i), j)
END IF
ELSE IF ( ptr % PROCEDURE /= 0 ) THEN
CALL ExecRealVectorFunction( ptr % PROCEDURE, CurrentModel, &
NodeIndexes(i), T, G(:,i) )
ELSE
DO k=1,n
G(k,i) = InterpolateCurve(ptr % TValues, &
ptr % FValues(k,1,:), T(MIN(j,k)), ptr % CubicCoeff )
END DO
END IF
IF( AllGlobal ) EXIT
END DO
CALL ListPopActiveName()
IF( AllGlobal ) THEN
DO i=2,ni
DO j=1,n
G(j,i) = G(j,1)
END DO
END DO
END IF
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
G = ptr % Coeff * G
END IF
CASE DEFAULT
G = 0.0d0
DO i=1,n
IF ( PRESENT( Found ) ) THEN
G(i,1:ni) = ListGetReal( List,Name,ni,NodeIndexes,Found )
ELSE
G(i,1:ni) = ListGetReal( List,Name,ni,NodeIndexes )
END IF
END DO
END SELECT
F = F + G
cnt = cnt + 1
ptr => ListFind(List,Name//'{'//I2S(cnt)//'}',lFound)
IF(ASSOCIATED(ptr)) GOTO 100
200 IF( ListGetLogical( List, Name//' Property Rotate', lFound ) ) THEN
RotMatrix => ListGetConstRealArray( List,'Property Rotation Matrix',lFound )
IF( .NOT. ASSOCIATED( RotMatrix ) ) THEN
CALL Fatal('ListGetRealVector','Property rotation matrix not given for: '//TRIM(Name))
END IF
IF( SIZE(F,1) /= 3 ) THEN
CALL Fatal('ListGetRealVector','Property may be rotated only with three components!')
END IF
DO i = 1,SIZE(F,2)
F(1:3,i) = MATMUL( RotMatrix, F(1:3,i) )
END DO
END IF
END SUBROUTINE ListGetRealVector
RECURSIVE FUNCTION ListGetDerivValue(List,Name,N,NodeIndexes,dT) RESULT(F)
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: Name
INTEGER :: N,NodeIndexes(:)
REAL(KIND=dp), OPTIONAL :: dT
REAL(KIND=dp) :: F(N)
TYPE(Variable_t), POINTER :: Variable
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: i,k,l
REAL(KIND=dp) :: T,T1(1),T2(1),F1,F2
F = 0.0D0
ptr => ListFind(List,Name)
IF ( .NOT.ASSOCIATED(ptr) ) RETURN
SELECT CASE(ptr % TYPE)
CASE( LIST_TYPE_VARIABLE_SCALAR )
IF ( ptr % PROCEDURE /= 0 ) THEN
IF( .NOT. PRESENT( dT ) ) THEN
CALL Fatal('ListGetDerivValue','Numerical derivative of function requires dT')
END IF
Variable => VariableGet( CurrentModel % Variables,ptr % DependName )
IF( .NOT. ASSOCIATED( Variable ) ) THEN
CALL Fatal('ListGetDeriveValue','Cannot derivate with variable: '//TRIM(ptr % DependName))
END IF
DO i=1,n
k = NodeIndexes(i)
IF ( ASSOCIATED(Variable % Perm) ) k = Variable % Perm(k)
IF ( k > 0 ) THEN
T = Variable % Values(k)
T1(1) = T + 0.5_dp * dT
T2(1) = T - 0.5_dp * dT
F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndexes(i), T1 )
F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndexes(i), T2 )
F(i) = ptr % Coeff * ( F1 - F2 ) / dT
END IF
END DO
ELSE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListGetDerivValue', &
'Value type for property > '// TRIM(Name) // '< not used consistently.')
END IF
Variable => VariableGet( CurrentModel % Variables,ptr % DependName )
IF( .NOT. ASSOCIATED( Variable ) ) THEN
CALL Fatal('ListGetDeriveValue','Cannot derivate with variable: '//TRIM(ptr % DependName))
END IF
DO i=1,n
k = NodeIndexes(i)
IF ( ASSOCIATED(Variable % Perm) ) k = Variable % Perm(k)
IF ( k > 0 ) THEN
T = Variable % Values(k)
F(i) = ptr % Coeff * &
DerivateCurve(ptr % TValues,ptr % FValues(1,1,:), &
T, ptr % CubicCoeff )
END IF
END DO
END IF
CASE DEFAULT
CALL Fatal( 'ListGetDerivValue', &
'No automated derivation possible for > '//TRIM(Name)//' <' )
END SELECT
END FUNCTION ListGetDerivValue
FUNCTION NextFreeKeyword(keyword0,List) RESULT (Keyword)
CHARACTER(LEN=*) :: Keyword0
TYPE(ValueList_t), POINTER :: List
CHARACTER(:), ALLOCATABLE :: Keyword
INTEGER :: No
DO No = 1, 9999
Keyword = TRIM(Keyword0)//' '//I2S(No)
IF( .NOT. ListCheckPresent(List,Keyword)) EXIT
END DO
END FUNCTION NextFreeKeyword
FUNCTION ListCheckPresentAnyBC( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: bc
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO bc = 1,Model % NumberOfBCs
Found = ListCheckPresent( Model % BCs(bc) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % BCs(bc) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyBC
FUNCTION ListCheckPresentAnyIC( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: ic
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO ic = 1,Model % NumberOfICs
Found = ListCheckPresent( Model % ICs(ic) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % ICs(ic) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyIC
FUNCTION ListGetLogicalAnyBC( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found, GotIt
INTEGER :: bc
Found = .FALSE.
DO bc = 1,Model % NumberOfBCs
Found = ListgetLogical( Model % BCs(bc) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnyBC
FUNCTION ListCheckPresentAnyBody( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: body
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO body = 1,Model % NumberOfBodies
Found = ListCheckPresent( Model % Bodies(body) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % Bodies(body) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyBody
FUNCTION ListGetLogicalAnyBody( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: body
LOGICAL :: GotIt
Found = .FALSE.
DO body = 1,Model % NumberOfBodies
Found = ListGetLogical( Model % Bodies(body) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnyBody
FUNCTION ListGetCRealAnyBody( Model, Name, Found ) RESULT( F )
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL, OPTIONAL :: Found
REAL(KIND=dp) :: F
INTEGER :: body
LOGICAL :: GotIt
F = 0.0_dp
GotIt = .FALSE.
DO body = 1,Model % NumberOfBodies
F = ListGetCReal( Model % Bodies(body) % Values, Name, GotIt )
IF( GotIt ) EXIT
END DO
IF( PRESENT( Found ) ) Found = GotIt
END FUNCTION ListGetCRealAnyBody
FUNCTION ListCheckPresentAnyBodyForce( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: bf
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO bf = 1,Model % NumberOfBodyForces
Found = ListCheckPresent( Model % BodyForces(bf) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % BodyForces(bf) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyBodyForce
FUNCTION ListGetLogicalAnyBodyForce( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found, GotIt
INTEGER :: bf
Found = .FALSE.
DO bf = 1,Model % NumberOfBodyForces
Found = ListGetLogical( Model % BodyForces(bf) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnyBodyForce
FUNCTION ListCheckPresentAnyMaterial( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: mat
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO mat = 1,Model % NumberOfMaterials
Found = ListCheckPresent( Model % Materials(mat) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % Materials(mat) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyMaterial
FUNCTION ListCheckPresentAnySolver( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: ind
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO ind = 1,Model % NumberOfSolvers
Found = ListCheckPresent( Model % Solvers(ind) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % Solvers(ind) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnySolver
FUNCTION ListCheckPresentAnyComponent( Model, Name, ValueLst ) RESULT( Found )
IMPLICIT NONE
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: ind
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO ind=1, Model % NumberOfComponents
Found = ListCheckPresent( Model % Components(ind) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % Components(ind) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyComponent
FUNCTION ListCheckPrefixAnyComponent( Model, Name ) RESULT( Found )
IMPLICIT NONE
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found
INTEGER :: ind
TYPE(ValueListEntry_t), POINTER :: ptr
Found = .FALSE.
DO ind=1, Model % NumberOfComponents
ptr => ListFindPrefix( Model % Components(ind) % Values, Name, Found )
IF( Found ) EXIT
END DO
END FUNCTION ListCheckPrefixAnyComponent
FUNCTION ListGetLogicalAnyComponent( Model, Name ) RESULT( Found )
IMPLICIT NONE
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found, GotIt
INTEGER :: ind
Found = .FALSE.
DO ind=1, Model % NumberOfComponents
Found = ListGetLogical( Model % Components(ind) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnyComponent
FUNCTION ListCheckAnyMaterialIsArray( Model, Name ) RESULT(IsArray)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: IsArray
LOGICAL :: Found
INTEGER :: mat, n, m
TYPE(ValueListEntry_t), POINTER :: ptr
IsArray = .FALSE.
DO mat = 1,Model % NumberOfMaterials
ptr => ListFind(Model % Materials(mat) % Values,Name,Found)
IF( .NOT. ASSOCIATED( ptr ) ) CYCLE
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
CALL Fatal( 'ListCheckAnyMaterialArray', 'Value type for property ['//TRIM(Name)// &
'] not used consistently.')
END IF
n = SIZE( ptr % FValues,1 )
m = SIZE( ptr % FValues,2 )
IsArray = ( n > 1 ) .OR. ( m > 1 )
IF( IsArray ) EXIT
END DO
END FUNCTION ListCheckAnyMaterialIsArray
FUNCTION ListGetLogicalAnyMaterial( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found, GotIt
INTEGER :: mat
Found = .FALSE.
DO mat = 1,Model % NumberOfMaterials
Found = ListGetLogical( Model % Materials(mat) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnyMaterial
FUNCTION ListGetLogicalAnySolver( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found, GotIt
INTEGER :: ind
Found = .FALSE.
DO ind = 1,Model % NumberOfSolvers
Found = ListGetLogical( Model % Solvers(ind) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnySolver
FUNCTION ListCheckPresentAnyEquation( Model, Name, ValueLst ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
LOGICAL :: Found
INTEGER :: eq
Found = .FALSE.
IF(PRESENT(ValueLst)) ValueLst => NULL()
DO eq = 1,Model % NumberOfEquations
Found = ListCheckPresent( Model % Equations(eq) % Values, Name )
IF( Found ) THEN
IF(PRESENT(ValueLst)) ValueLst => Model % Equations(eq) % Values
EXIT
END IF
END DO
END FUNCTION ListCheckPresentAnyEquation
FUNCTION ListGetLogicalAnyEquation( Model, Name ) RESULT(Found)
TYPE(Model_t) :: Model
CHARACTER(LEN=*) :: Name
LOGICAL :: Found, GotIt
INTEGER :: eq
Found = .FALSE.
DO eq = 1,Model % NumberOfEquations
Found = ListGetLogical( Model % Equations(eq) % Values, Name, GotIt )
IF( Found ) EXIT
END DO
END FUNCTION ListGetLogicalAnyEquation
SUBROUTINE CreateListForSaving( Model, List, ShowVariables, ClearList, &
UseGenericKeyword )
IMPLICIT NONE
TYPE(Model_t) :: Model
TYPE(ValueList_t), POINTER :: List
LOGICAL :: ShowVariables
LOGICAL, OPTIONAL :: ClearList
LOGICAL, OPTIONAL :: UseGenericKeyword
INTEGER :: i,j,k,l,LoopDim, VarDim,FullDim,DOFs,dim,Comp
TYPE(Variable_t), POINTER :: Variables, Var, Var1
CHARACTER(LEN=2*MAX_NAME_LEN) :: VarName, VarStr, str
LOGICAL :: IsVector, Set, GotIt, ComponentVector, ThisOnly, IsIndex, &
EnforceVectors, UseGeneric, DisplacementV
INTEGER :: Nvector, Nscalar
TYPE(ValueList_t), POINTER :: Params
Params => Model % Solver % Values
Variables => Model % Mesh % Variables
IF( .NOT. ASSOCIATED( Variables ) ) THEN
CALL Warn('CreateListForSaving','Mesh does not include any variables!')
RETURN
END IF
UseGeneric = .FALSE.
IF( PRESENT( UseGenericKeyword ) ) THEN
UseGeneric = UseGenericKeyword
END IF
IF( PRESENT( ClearList ) ) THEN
IF( ClearList ) THEN
IF( UseGeneric ) THEN
DO i=1,999
WRITE(VarStr,'(A,I0)') 'Variable ',i
IF( ListCheckPresent( List, VarStr ) ) THEN
CALL ListRemove( List, VarStr )
ELSE
EXIT
END IF
END DO
ELSE
DO i=1,999
WRITE(VarStr,'(A,I0)') 'Scalar Field ',i
IF( ListCheckPresent( List, VarStr ) ) THEN
CALL ListRemove( List, VarStr )
ELSE
EXIT
END IF
END DO
DO i=1,999
WRITE(VarStr,'(A,I0)') 'Vector Field ',i
IF( ListCheckPresent( List, VarStr ) ) THEN
CALL ListRemove( List, VarStr )
ELSE
EXIT
END IF
WRITE(VarStr,'(A,I0,A)') 'Vector Field ',i,' Complement'
IF( ListCheckPresent( List, VarStr ) ) THEN
CALL ListRemove( List, VarStr )
END IF
END DO
END IF
END IF
END IF
IF( UseGeneric ) THEN
IF( ListCheckPresent( List,'Variable 1' ) ) THEN
CALL Info('CreateListForSaving','Variable 1 exists, creating no list!',Level=10)
RETURN
END IF
ELSE
IF( ListCheckPresent( List,'Scalar Field 1' ) ) THEN
CALL Info('CreateListForSaving','Scalar Field 1 exists, creating no list!',Level=10)
RETURN
END IF
IF( ListCheckPresent( List,'Vector Field 1' ) ) THEN
CALL Info('CreateListForSaving','Vector Field 1 exists, creating no list!',Level=10)
RETURN
END IF
END IF
Nscalar = 0
Nvector = 0
ThisOnly = .NOT. ListGetLogical( Params,'Interpolate Fields',GotIt)
dim = Model % Mesh % MeshDim
EnforceVectors = ListGetLogical( Params,'Enforce Vectors',GotIt)
IF(.NOT. GotIt ) EnforceVectors = .TRUE.
Var => Variables
DisplacementV = .FALSE.
DO WHILE( ASSOCIATED( Var ) )
IF( Var % Name == 'displacement' ) DisplacementV = .TRUE.
Var => Var % Next
END DO
Var => Variables
DO WHILE( ASSOCIATED( Var ) )
IF ( .NOT. Var % Output ) THEN
Var => Var % Next
CYCLE
END IF
IF ( SIZE( Var % Values ) == Var % DOFs ) THEN
Var => Var % Next
CYCLE
END IF
IF( Var % TYPE == Variable_global ) THEN
Var => Var % Next
CYCLE
ELSE IF( Var % TYPE == Variable_on_gauss_points ) THEN
CONTINUE
ELSE IF( Var % TYPE == Variable_on_elements ) THEN
CONTINUE
END IF
IF(.NOT. ASSOCIATED( Var % Perm ) ) THEN
IF( Var % TYPE == Variable_on_nodes ) THEN
IF( SIZE( Var % Values ) /= Var % Dofs * Model % Mesh % NumberOfNodes ) THEN
Var => Var % Next
CYCLE
END IF
ELSE IF( Var % TYPE == Variable_on_nodes_on_elements ) THEN
IF( SIZE( Var % Values ) /= Var % Dofs * Model % Mesh % NumberOfBulkElements ) THEN
Var => Var % Next
CYCLE
END IF
END IF
END IF
VarDim = Var % Dofs
IsVector = (VarDim > 1)
Set = .FALSE.
WRITE(VarName,'(A)') TRIM(Var % Name)
SELECT CASE(Var % Name)
CASE( 'coordinate 1','coordinate 2','coordinate 3' )
CASE( 'mesh update' )
Set = .TRUE.
IF(.NOT. UseGeneric ) THEN
Var1 => Variables
DO WHILE( ASSOCIATED( Var1 ) )
IF ( TRIM(Var1 % Name) == 'displacement' ) EXIT
Var1 => Var1 % Next
END DO
IF ( ASSOCIATED( Var1 ) ) Set = .FALSE.
END IF
CASE('mesh update 1','mesh update 2', 'mesh update 3' )
CASE( 'displacement' )
Set = .TRUE.
IF(.NOT. UseGeneric ) THEN
Var1 => Variables
DO WHILE( ASSOCIATED( Var1 ) )
IF ( TRIM(Var1 % Name) == 'mesh update' ) EXIT
Var1 => Var1 % Next
END DO
IF ( ASSOCIATED( Var1 ) ) THEN
WRITE(VarStr,'(A,I0,A)') 'Vector Field ',Nvector+1,' Complement'
CALL ListAddString( List ,TRIM(VarStr),'mesh update')
END IF
END IF
CASE DEFAULT
IF ( VarDim == 1 ) THEN
Set = .TRUE.
str = ' '
j = LEN_TRIM(Var % Name)
DO i=1,j
str(i:i) = Var % Name(i:i)
END DO
IsIndex = .FALSE.
Comp = 0
k = INDEX( str(:j),' ',BACK=.TRUE.)
IF( k > 0 ) THEN
IsIndex = ( VERIFY( str(k:j),' 0123456789') == 0 )
IF( IsIndex ) READ( str(k:j), * ) Comp
END IF
GotIt = .FALSE.
IF( IsIndex ) THEN
Var1 => VariableGet(Variables,TRIM(str(1:k)),ThisOnly)
IF( ASSOCIATED( Var1 ) ) THEN
GotIt = .TRUE.
IsVector = ( Var1 % Dofs == Dim .OR. Var1 % Dofs == 3 )
Set = ( Comp == 1 .OR. .NOT. IsVector )
END IF
END IF
IF( EnforceVectors .AND. .NOT. GotIt ) THEN
IF( Comp == 1 ) THEN
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(dim),ThisOnly)
IF( ASSOCIATED(Var1)) THEN
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(4),ThisOnly)
IsVector = .NOT. ASSOCIATED(Var1)
END IF
ELSE IF( Comp == 2 .OR. Comp == 3 ) THEN
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' 1',ThisOnly)
IF( ASSOCIATED( Var1 ) ) THEN
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(4),ThisOnly)
Set = ASSOCIATED( Var1 )
IF( .NOT. Set ) THEN
IF( Comp == 2 .AND. dim == 3 ) THEN
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(dim),ThisOnly)
Set = .NOT. ASSOCIATED( Var1 )
END IF
END IF
END IF
END IF
END IF
IF( Set ) THEN
IF(IsVector) WRITE(VarName,'(A)') TRIM(str(1:j-2))
IF(VarName == 'displacement' .AND. DisplacementV ) Set = .FALSE.
END IF
END IF
END SELECT
IF( Set ) THEN
IF( UseGeneric ) THEN
Nscalar = Nscalar + 1
WRITE(VarStr,'(A,I0)') 'Variable ',Nscalar
ELSE IF( IsVector ) THEN
Nvector = Nvector + 1
WRITE(VarStr,'(A,I0)') 'Vector Field ',Nvector
ELSE
Nscalar = Nscalar + 1
WRITE(VarStr,'(A,I0)') 'Scalar Field ',Nscalar
END IF
CALL ListAddString( List,TRIM(VarStr),TRIM(VarName) )
END IF
Var => Var % Next
END DO
IF( ShowVariables ) THEN
CALL Info('CreateListForSaving','Field Variables for Saving')
IF( UseGeneric ) THEN
DO i=1,Nscalar
WRITE(VarStr,'(A,I0)') 'Variable ',i
VarName = ListGetString( List, VarStr,GotIt )
IF( GotIt ) THEN
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
CALL Info('CreateListForSaving',Message,Level=6)
END IF
END DO
ELSE
DO i=1,Nscalar
WRITE(VarStr,'(A,I0)') 'Scalar Field ',i
VarName = ListGetString( List, VarStr,GotIt )
IF( GotIt ) THEN
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
CALL Info('CreateListForSaving',Message,Level=6)
END IF
END DO
DO i=1,Nvector
WRITE(VarStr,'(A,I0)') 'Vector Field ',i
VarName = ListGetString( List, VarStr,GotIt )
IF( GotIt ) THEN
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
CALL Info('CreateListForSaving',Message,Level=6)
END IF
END DO
DO i=1,Nvector
WRITE(VarStr,'(A,I0,A)') 'Vector Field ',i,' Complement'
VarName = ListGetString( List, VarStr, GotIt )
IF( GotIt ) THEN
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
CALL Info('CreateListForSaving',Message,Level=6)
END IF
END DO
END IF
END IF
END SUBROUTINE CreateListForSaving
SUBROUTINE ResetTimer(TimerName)
CHARACTER(*) :: TimerName
REAL(KIND=dp) :: ct, rt
LOGICAL :: Found,FirstTime=.TRUE.
IF( FirstTime ) THEN
FirstTime=.FALSE.
TimerPassive = ListGetLogical( CurrentModel % Simulation,'Timer Passive',Found)
TimerCumulative = ListGetLogical( CurrentModel % Simulation,'Timer Cumulative',Found)
TimerRealTime = ListGetLogical( CurrentModel % Simulation,'Timer Real Time',Found)
TimerCPUTime = ListGetLogical( CurrentModel % Simulation,'Timer CPU Time',Found)
IF( .NOT. (TimerRealTime .OR. TimerCPUTime ) ) TimerRealTime = .TRUE.
TimerPrefix = ListGetString( CurrentModel % Simulation,'Timer Prefix',Found )
IF( .NOT. Found ) THEN
IF( ListGetLogical( CurrentModel % Simulation,'Timer Results',Found ) ) THEN
TimerPrefix = 'res:'
ELSE
TimerPrefix = 'timer:'
END IF
END IF
END IF
IF( TimerPassive ) RETURN
IF( TimerCPUTime ) THEN
ct = CPUTime()
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' cpu time',ct )
END IF
IF( TimerRealTime ) THEN
rt = RealTime()
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' real time',rt )
END IF
IF( TimerCumulative ) THEN
IF( TimerCPUTime ) THEN
IF( .NOT. ListCheckPresent( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time') ) THEN
CALL ListAddConstReal( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',0.0_dp )
END IF
END IF
IF( TimerRealTime ) THEN
IF( .NOT. ListCheckPresent( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time') ) THEN
CALL ListAddConstReal( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',0.0_dp )
END IF
END IF
END IF
END SUBROUTINE ResetTimer
SUBROUTINE DeleteTimer(TimerName)
CHARACTER(*) :: TimerName
IF( TimerPassive ) RETURN
IF( TimerCPUTime ) THEN
CALL ListRemove( TimerList, TRIM(TimerName)//' cpu time' )
END IF
IF( TimerRealTime ) THEN
CALL ListRemove( TimerList, TRIM(TimerName)//' real time' )
END IF
END SUBROUTINE DeleteTimer
SUBROUTINE CheckTimer(TimerName, Level, Delete, Reset)
CHARACTER(*) :: TimerName
INTEGER, OPTIONAL :: Level
LOGICAL, OPTIONAL :: Reset, Delete
REAL(KIND=dp) :: ct0,rt0,ct, rt, cumct, cumrt
LOGICAL :: Found
IF( TimerPassive ) RETURN
IF( TimerCPUTime ) THEN
ct0 = ListGetConstReal( TimerList,TRIM(TimerName)//' cpu time',Found)
IF( Found ) THEN
ct = CPUTime() - ct0
WRITE(Message,'(a,f10.4,a)') 'Elapsed CPU time: ',ct,' (s)'
CALL Info(TRIM(TimerName),Message,Level=Level)
END IF
END IF
IF( TimerRealTime ) THEN
rt0 = ListGetConstReal( TimerList,TRIM(TimerName)//' real time',Found)
IF( Found ) THEN
rt = RealTime() - rt0
WRITE(Message,'(a,f10.4,a)') 'Elapsed REAL time: ',rt,' (s)'
CALL Info(TRIM(TimerName),Message,Level=Level)
END IF
END IF
IF( TimerCPUTime ) THEN
IF( TimerCumulative ) THEN
cumct = ListGetConstReal(CurrentModel % Simulation,&
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',Found)
IF( Found ) THEN
ct = ct + cumct
WRITE(Message,'(a,f10.4,a)') 'Elapsed CPU time cumulative: ',ct,' (s)'
CALL Info(TRIM(TimerName),Message,Level=Level)
ELSE
CALL Warn('CheckTimer',&
'Requesting previous CPU time from non-existing timer: '//TRIM(TimerName) )
END IF
END IF
CALL ListAddConstReal(CurrentModel % Simulation,&
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',ct)
END IF
IF( TimerRealTime ) THEN
IF( TimerCumulative ) THEN
cumrt = ListGetConstReal(CurrentModel % Simulation,&
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',Found)
IF( Found ) THEN
rt = rt + cumrt
WRITE(Message,'(a,f10.4,a)') 'Elapsed real time cumulative: ',rt,' (s)'
CALL Info(TRIM(TimerName),Message,Level=Level)
ELSE
CALL Warn('CheckTimer',&
'Requesting previous real time from non-existing timer: '//TRIM(TimerName) )
END IF
END IF
CALL ListAddConstReal(CurrentModel % Simulation,&
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',rt)
END IF
IF( PRESENT( Reset ) ) THEN
IF( Reset ) THEN
IF( TimerCPUTime ) THEN
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' cpu time',ct )
END IF
IF( TimerRealTime ) THEN
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' real time',rt )
END IF
END IF
END IF
IF( PRESENT( Delete ) ) THEN
IF( Delete ) CALL DeleteTimer( TimerName )
END IF
END SUBROUTINE CheckTimer
FUNCTION ListGetAngularFrequency(ValueList,Found,UElement) RESULT(w)
REAL(KIND=dp) :: w
TYPE(ValueList_t), OPTIONAL, POINTER :: ValueList
LOGICAL, OPTIONAL :: Found
LOGICAL :: GotIt
TYPE(Element_t), TARGET :: UElement
TYPE(Element_t), POINTER :: Element
OPTIONAL :: UElement
INTEGER :: elem_id,eq_id,mat_id
IF( PRESENT( ValueList ) ) THEN
w = 2 * PI * ListGetCReal( ValueList,'Frequency',GotIt)
IF(.NOT. GotIt) w = ListGetCReal( ValueList,'Angular Frequency',GotIt)
ELSE
GotIt = .FALSE.
END IF
IF( .NOT. GotIt ) THEN
IF(PRESENT(UElement)) THEN
Element => UElement
eq_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Equation')
w = 2 * PI * ListGetCReal( &
CurrentModel % Equations(eq_id) % Values,'Frequency',GotIt)
IF(.NOT. GotIt) w = ListGetCReal( &
CurrentModel % Equations(eq_id) % Values,'Angular Frequency',GotIt)
END IF
END IF
IF( .NOT. GotIt ) THEN
IF(PRESENT(UElement)) THEN
Element => UElement
mat_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Material',GotIt)
IF( GotIt ) THEN
w = 2 * PI * ListGetCReal( &
CurrentModel % Materials(mat_id) % Values,'Frequency',GotIt)
IF(.NOT. GotIt) w = ListGetCReal( &
CurrentModel % Materials(mat_id) % Values,'Angular Frequency',GotIt)
END IF
END IF
END IF
IF(.NOT. GotIt) w = 2 * PI * ListGetCReal( &
CurrentModel % Simulation,'Frequency',GotIt)
IF(.NOT. GotIt ) w = ListGetCReal( &
CurrentModel % Simulation,'Angular Frequency',GotIt)
IF(.NOT. GotIt ) w = 2 * PI * ListGetCReal( &
CurrentModel % Solver % Values,'Frequency',GotIt)
IF(.NOT. GotIt ) w = ListGetCReal( &
CurrentModel % Solver % Values,'Angular Frequency',GotIt)
IF( .NOT. GotIt ) THEN
IF(.NOT. PRESENT(UElement)) THEN
elem_id = CurrentModel % Solver % ActiveElements(1)
Element => CurrentModel % Elements(elem_id)
eq_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Equation')
w = 2 * PI * ListGetCReal( &
CurrentModel % Equations(eq_id) % Values,'Frequency',GotIt)
IF(.NOT. GotIt) w = ListGetCReal( &
CurrentModel % Equations(eq_id) % Values,'Angular Frequency',GotIt)
END IF
END IF
IF( .NOT. GotIt ) THEN
IF(.NOT. PRESENT(UElement)) THEN
elem_id = CurrentModel % Solver % ActiveElements(1)
Element => CurrentModel % Elements(elem_id)
mat_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Material',GotIt)
IF(GotIt) THEN
w = 2 * PI * ListGetCReal( &
CurrentModel % Materials(mat_id) % Values,'Frequency',GotIt)
IF(.NOT. GotIt) w = ListGetCReal( &
CurrentModel % Materials(mat_id) % Values,'Angular Frequency',GotIt)
END IF
END IF
END IF
IF( PRESENT( Found ) ) THEN
Found = GotIt
ELSE IF(.NOT. GotIt ) THEN
CALL Warn('ListGetAngularFrequency','Angular frequency could not be determined!')
END IF
END FUNCTION ListGetAngularFrequency
FUNCTION ListGetSolverParams(Solver) RESULT(SolverParam)
TYPE(ValueList_t), POINTER :: SolverParam
TYPE(Solver_t), OPTIONAL :: Solver
IF ( PRESENT(Solver) ) THEN
SolverParam => Solver % Values
ELSE
SolverParam => CurrentModel % Solver % Values
END IF
END FUNCTION ListGetSolverParams
SUBROUTINE ElmerEvalLuaT(L, ptr, T, F, varcount)
TYPE(LuaState_t) :: L
TYPE(ValueListEntry_t), POINTER :: ptr
REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:)
REAL(KIND=C_DOUBLE), INTENT(OUT) :: F(:,:)
INTEGER :: VARCOUNT
integer :: lstat
#ifdef HAVE_LUA
L % tx(1:varcount) = T(1:varcount)
call lua_exec_fun(L, ptr % cvalue, 0, size(F,1)*size(F,2))
CALL lua_poptensor(L, F)
#else
CALL Fatal('ElmerEvalLuaT', 'Lua not compiled in.')
#endif
END SUBROUTINE ElmerEvalLuaT
SUBROUTINE ElmerEvalLuaV(L, ptr, T, F, varcount)
TYPE(LuaState_t) :: L
TYPE(ValueListEntry_t), POINTER :: ptr
REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:)
REAL(KIND=C_DOUBLE), INTENT(INOUT) :: F(:)
INTEGER :: VARCOUNT
integer :: lstat
#ifdef HAVE_LUA
L % tx(1:varcount) = T(1:varcount)
call lua_exec_fun(L, ptr % cvalue, 0, size(F,1))
CALL lua_popvector(L, F)
#else
CALL Fatal('ElmerEvalLuaV', 'Lua not compiled in.')
#endif
END SUBROUTINE ElmerEvalLuaV
SUBROUTINE ElmerEvalLuaS(L, ptr, T, F, varcount)
TYPE(LuaState_t) :: L
TYPE(ValueListEntry_t), POINTER :: ptr
REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:)
REAL(KIND=C_DOUBLE), INTENT(OUT) :: F
INTEGER :: VARCOUNT
integer :: lstat
#ifdef HAVE_LUA
L % tx(1:varcount) = T(1:varcount)
call lua_exec_fun(L, ptr % cvalue, 0, 1)
F = lua_popnumber(LuaState)
#else
CALL Fatal('ElmerEvalLuaV', 'Lua not compiled in.')
#endif
END SUBROUTINE ElmerEvalLuaS
#if defined DEVEL_LISTCOUNTER || defined DEVEL_LISTUSAGE
SUBROUTINE ReportListCounters( Model, ReportMode )
TYPE(Model_t) :: Model
INTEGER :: ReportMode
CHARACTER(LEN=MAX_NAME_LEN) :: dirname,filename
INTEGER :: i, totcount, nelem, ReportUnit
LOGICAL :: Unused, GotFile
IF(ReportMode == 1 ) THEN
GOTO 100
END IF
filename = ListGetString( Model % Simulation,'List Counter File',GotFile )
IF(.NOT. GotFile ) filename = '../listcounter.dat'
IF( GotFile ) THEN
CALL Info('ReportListCounters','Saving ListGet operations counts')
ReportUnit = 10
OPEN( 10,File=filename,STATUS='UNKNOWN',POSITION='APPEND' )
CALL GETCWD(dirname)
WRITE( ReportUnit,'(A)') 'Working directory: '//TRIM(dirname)
nelem = Model % Mesh % NumberOfBulkElements
WRITE( ReportUnit,'(T4,A)') 'Number of elements: '//I2S(nelem)
WRITE( ReportUnit,'(T4,A)') 'Number of nodes: '//I2S(Model % Mesh % NumberOfNodes)
ELSE
ReportUnit = 6
END IF
Unused = .TRUE.
totcount = 0
100 IF( ReportMode == 1 ) THEN
CONTINUE
ELSE IF( Unused ) THEN
WRITE( ReportUnit,'(T4,A)') 'Unused keywords:'
ELSE
WRITE( ReportUnit,'(T4,A)') 'Used keywords:'
END IF
CALL ReportList('Simulation', Model % Simulation, Unused )
CALL ReportList('Constants', Model % Constants, Unused )
DO i=1,Model % NumberOfEquations
CALL ReportList('Equation '//I2S(i), Model % Equations(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfComponents
CALL ReportList('Component '//I2S(i), Model % Components(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfBodyForces
CALL ReportList('Body Force '//I2S(i), Model % BodyForces(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfICs
CALL ReportList('Initial Condition '//I2S(i), Model % ICs(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfBCs
CALL ReportList('Boundary Condition '//I2S(i), Model % BCs(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfMaterials
CALL ReportList('Material '//I2S(i), Model % Materials(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfBoundaries
CALL ReportList('Boundary '//I2S(i), Model % Boundaries(i) % Values, Unused )
END DO
DO i=1,Model % NumberOfSolvers
CALL ReportList('Solver '//I2S(i), Model % Solvers(i) % Values, Unused )
END DO
IF( ReportMode == 3 ) THEN
IF( Unused ) THEN
Unused = .FALSE.
GOTO 100
END IF
CALL Info('ReportListCounters','List operations total count:'//I2S(totcount))
END IF
IF (ReportMode /= 1) THEN
IF( GotFile ) CLOSE(ReportUnit)
END IF
CONTAINS
SUBROUTINE ReportList( SectionName, List, Unused )
TYPE(ValueList_t), POINTER :: List
CHARACTER(LEN=*) :: SectionName
LOGICAL :: Unused
TYPE(ValueListEntry_t), POINTER :: ptr
INTEGER :: n, m
IF(.NOT.ASSOCIATED(List)) RETURN
Ptr => List % Head
DO WHILE( ASSOCIATED(ptr) )
n = ptr % NameLen
m = ptr % Counter
IF(ReportMode == 1 ) THEN
ptr % Counter = -1
ELSE IF(ReportMode == 2 .AND. m == -1 ) THEN
IF( ptr % Name == 'name' ) THEN
CONTINUE
ELSE
WRITE( ReportUnit,'(T8,A,T30,A)') TRIM(SectionName),ptr % Name(1:n)
END IF
ELSE IF( ReportMode == 3 ) THEN
IF( Unused .AND. m == 0 ) THEN
WRITE( ReportUnit,'(T8,A,T30,A)') TRIM(SectionName),ptr % Name(1:n)
ELSE IF(.NOT. Unused .AND. m > 0 ) THEN
WRITE( ReportUnit,'(T8,A,T30,I0,T40,A)') TRIM(SectionName),m,ptr % Name(1:n)
totcount = totcount + m
END IF
END IF
ptr => ptr % Next
END DO
END SUBROUTINE ReportList
END SUBROUTINE ReportListCounters
#else
SUBROUTINE ReportListCounters( Model )
TYPE(Model_t) :: Model
CALL Info('ReportListCounter','List counters are not activated!')
END SUBROUTINE ReportListCounters
#endif
END MODULE Lists