Book a Demo!
CoCalc Logo Icon
StoreFeaturesDocsShareSupportNewsAboutPoliciesSign UpSign In
ElmerCSC
GitHub Repository: ElmerCSC/elmerfem
Path: blob/devel/fem/src/Lists.F90
3203 views
1
!/*****************************************************************************/
2
! *
3
! * Elmer, A Finite Element Software for Multiphysical Problems
4
! *
5
! * Copyright 1st April 1995 - , CSC - IT Center for Science Ltd., Finland
6
! *
7
! * This library is free software; you can redistribute it and/or
8
! * modify it under the terms of the GNU Lesser General Public
9
! * License as published by the Free Software Foundation; either
10
! * version 2.1 of the License, or (at your option) any later version.
11
! *
12
! * This library is distributed in the hope that it will be useful,
13
! * but WITHOUT ANY WARRANTY; without even the implied warranty of
14
! * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
! * Lesser General Public License for more details.
16
! *
17
! * You should have received a copy of the GNU Lesser General Public
18
! * License along with this library (in file ../LGPL-2.1); if not, write
19
! * to the Free Software Foundation, Inc., 51 Franklin Street,
20
! * Fifth Floor, Boston, MA 02110-1301 USA
21
! *
22
! *****************************************************************************/
23
!
24
!/******************************************************************************
25
! *
26
! * Authors: Juha Ruokolainen
27
! * Email: [email protected]
28
! * Web: http://www.csc.fi/elmer
29
! * Address: CSC - IT Center for Science Ltd.
30
! * Keilaranta 14
31
! * 02101 Espoo, Finland
32
! *
33
! * Original Date: 02 Jun 1997
34
! *
35
! *****************************************************************************/
36
37
!> \ingroup ElmerLib
38
!> \{
39
40
!------------------------------------------------------------------------------
41
!> List handling utilities. In Elmer all the keywords are saved to a list,
42
!> and later accessed from it repeatedly. Therefore these subroutines are
43
!> essential in Elmer programming.
44
!------------------------------------------------------------------------------
45
#include "../config.h"
46
47
MODULE Lists
48
49
USE GeneralUtils
50
51
IMPLICIT NONE
52
53
INTEGER, PARAMETER :: LIST_TYPE_LOGICAL = 1
54
INTEGER, PARAMETER :: LIST_TYPE_STRING = 2
55
INTEGER, PARAMETER :: LIST_TYPE_INTEGER = 3
56
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR = 4
57
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_SCALAR = 5
58
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR_STR = 6
59
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_SCALAR_STR = 7
60
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR_PROC = 8
61
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_TENSOR = 9
62
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_TENSOR = 10
63
INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_TENSOR_STR = 11
64
INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_TENSOR_STR = 12
65
66
INTEGER, PARAMETER :: SECTION_TYPE_BODY = 1
67
INTEGER, PARAMETER :: SECTION_TYPE_MATERIAL = 2
68
INTEGER, PARAMETER :: SECTION_TYPE_BF = 3
69
INTEGER, PARAMETER :: SECTION_TYPE_IC = 4
70
INTEGER, PARAMETER :: SECTION_TYPE_BC = 5
71
INTEGER, PARAMETER :: SECTION_TYPE_COMPONENT = 6
72
INTEGER, PARAMETER :: SECTION_TYPE_SIMULATION = 7
73
INTEGER, PARAMETER :: SECTION_TYPE_CONSTANTS = 8
74
INTEGER, PARAMETER :: SECTION_TYPE_EQUATION = 9
75
76
77
INTEGER, PARAMETER :: MAX_FNC = 32
78
79
interface ElmerEvalLua
80
module procedure ElmerEvalLuaS, ElmerEvalLuaT, ElmerEvalLuaV
81
end INTERFACE
82
83
TYPE String_stack_t
84
CHARACTER(:), ALLOCATABLE :: Name
85
TYPE(String_stack_t), POINTER :: Next => Null()
86
END TYPE String_stack_t
87
88
CHARACTER(:), ALLOCATABLE, SAVE, PRIVATE :: Namespace
89
!$OMP THREADPRIVATE(NameSpace)
90
91
TYPE(String_stack_t), SAVE, PRIVATE, POINTER :: Namespace_stack => Null()
92
!$OMP THREADPRIVATE(NameSpace_stack)
93
94
CHARACTER(:), ALLOCATABLE, SAVE, PRIVATE :: ActiveListName
95
!$OMP THREADPRIVATE(ActiveListName)
96
97
TYPE(String_stack_t), SAVE, PRIVATE, POINTER :: Activename_stack => Null()
98
!$OMP THREADPRIVATE(Activename_stack)
99
100
TYPE(ValueList_t), POINTER, SAVE, PRIVATE :: TimerList => NULL()
101
LOGICAL, SAVE, PRIVATE :: TimerPassive, TimerCumulative, TimerRealTime, TimerCPUTime
102
CHARACTER(LEN=MAX_NAME_LEN), SAVE, PRIVATE :: TimerPrefix
103
104
105
LOGICAL, PRIVATE :: DoNamespaceCheck = .FALSE.
106
107
CONTAINS
108
109
110
! MATC utilities to get scalar,vector & array results from given expression
111
! in input string variable.
112
!---------------------------------------------------------------------------
113
SUBROUTINE SetGetMatcParams(nparams,params,resul)
114
INTEGER :: nparams
115
REAL(KIND=dp) :: params(:)
116
CHARACTER(*), OPTIONAL :: resul
117
118
INTEGER :: i,j,l
119
CHARACTER(LEN=1024) :: pcmd,res
120
121
IF(nparams==0) THEN
122
pcmd = "tx=0"
123
ELSE
124
#if 0
125
WRITE(pcmd,*) [(params(i),i=1,nparams)]
126
#else
127
! cray ftn output from above can be somewhat convoluted, do this instead
128
j = 1
129
DO i=1,nparams
130
WRITE(pcmd(j:), *) params(i)
131
DO WHILE(pcmd(j:j) == ' '); j=j+1; END DO
132
DO WHILE(pcmd(j:j) /= ' '); j=j+1; END DO
133
IF(pcmd(j-1:j-1)=='.') pcmd(j-1:j-1) = ' '
134
j = j + 1
135
END DO
136
#endif
137
IF(PRESENT(resul)) THEN
138
pcmd = TRIM(resul)//'='//TRIM(pcmd)
139
ELSE
140
pcmd = "tx="//TRIM(pcmd)
141
END IF
142
END IF
143
l = Matc(pcmd,res)
144
END SUBROUTINE SetGetMatcParams
145
146
147
FUNCTION GetMatcRealArray(cmd,n,m,nparams,params,resul) RESULT(g)
148
REAL(KIND=dp), ALLOCATABLE :: g(:,:)
149
CHARACTER(*) :: cmd
150
INTEGER :: n,m
151
INTEGER, OPTIONAL :: nparams
152
CHARACTER(*), OPTIONAL :: resul
153
REAL(KIND=dp), OPTIONAL :: params(:)
154
155
INTEGER :: i,j,l
156
CHARACTER(LEN=MAX_NAME_LEN) :: res
157
158
IF (PRESENT(nparams).AND.PRESENT(params))THEN
159
CALL SetGetMatcParams(nparams,params,resul)
160
END IF
161
l = Matc(cmd,res)
162
ALLOCATE(g(n,m))
163
READ(res(1:l),*) ((g(i,j),j=1,m),i=1,n)
164
END FUNCTION GetMatcRealArray
165
166
167
FUNCTION GetMatcRealVector(cmd,n,nparams,params,resul) RESULT(g)
168
REAL(KIND=dp), ALLOCATABLE :: g(:)
169
CHARACTER(*) :: cmd
170
INTEGER :: n,m
171
INTEGER, OPTIONAL :: nparams
172
CHARACTER(*), OPTIONAL :: resul
173
REAL(KIND=dp), OPTIONAL :: params(:)
174
175
INTEGER :: i,j,l
176
CHARACTER(LEN=MAX_NAME_LEN) :: res
177
178
IF (PRESENT(nparams).AND.PRESENT(params))THEN
179
CALL SetGetMatcParams(nparams,params,resul)
180
END IF
181
l = Matc(cmd,res)
182
ALLOCATE(g(n))
183
READ(res(1:l),*) (g(i),i=1,n)
184
END FUNCTION GetMatcRealVector
185
186
187
FUNCTION GetMatcReal(cmd,nparams,params,resul) RESULT(g)
188
CHARACTER(*) :: cmd
189
REAL(KIND=dp) :: g
190
INTEGER, OPTIONAL :: nparams
191
CHARACTER(*), OPTIONAL :: resul
192
REAL(KIND=dp), OPTIONAL :: params(:)
193
194
CHARACTER(LEN=MAX_NAME_LEN) :: pcmd, res
195
INTEGER :: i,l
196
197
IF (PRESENT(nparams).AND.PRESENT(params))THEN
198
CALL SetGetMatcParams(nparams,params,resul)
199
END IF
200
l = Matc(cmd,res)
201
READ(res(1:l), *) g
202
END FUNCTION GetMatcReal
203
!------------------------------------------------------------------------------
204
205
206
!> Tag the active degrees of freedom and number them in order of appearance.
207
!------------------------------------------------------------------------------
208
FUNCTION InitialPermutation( Perm,Model,Solver,Mesh, &
209
Equation,DGSolver,GlobalBubbles ) RESULT(k)
210
!------------------------------------------------------------------------------
211
USE PElementMaps
212
USE SParIterGlobals
213
TYPE(Model_t) :: Model
214
TYPE(Mesh_t) :: Mesh
215
TYPE(Solver_t), TARGET :: Solver
216
INTEGER :: Perm(:)
217
CHARACTER(LEN=*) :: Equation
218
LOGICAL, OPTIONAL :: DGSolver, GlobalBubbles
219
!------------------------------------------------------------------------------
220
INTEGER i,j,l,t,n,m,e,k,k1, MaxNDOFs, MaxEDOFs, MaxFDOFs, BDOFs, ndofs, el_id
221
INTEGER :: NodalIndexOffset, EdgeIndexOffset, FaceIndexOffset, Indexes(128)
222
INTEGER, POINTER :: Def_Dofs(:)
223
INTEGER, ALLOCATABLE :: EdgeDOFs(:), FaceDOFs(:)
224
LOGICAL :: FoundDG, DG, DB, GB, Bubbles, Found, Radiation, Parallel
225
TYPE(Element_t),POINTER :: Element, Edge, Face
226
CHARACTER(*), PARAMETER :: Caller = 'InitialPermutation'
227
!------------------------------------------------------------------------------
228
Perm = 0
229
k = 0
230
MaxEDOFs = Mesh % MaxEdgeDOFs
231
MaxFDOFs = Mesh % MaxFaceDOFs
232
MaxNDOFs = Mesh % MaxNDOFs
233
NodalIndexOffset = MaxNDOFs * Mesh % NumberOfNodes
234
EdgeIndexOffset = MaxEDOFs * Mesh % NumberOfEdges
235
FaceIndexOffset = MaxFDOFs * Mesh % NumberOfFaces
236
237
GB = .FALSE.
238
IF ( PRESENT(GlobalBubbles) ) GB=GlobalBubbles
239
240
DG = .FALSE.
241
IF ( PRESENT(DGSolver) ) DG=DGSolver
242
FoundDG = .FALSE.
243
244
IF( DG ) THEN
245
DB = ListGetLogical( Solver % Values,'DG Reduced Basis',Found )
246
ELSE
247
DB = .FALSE.
248
END IF
249
250
! Discontinuous bodies need special body-wise numbering
251
IF ( DB ) THEN
252
BLOCK
253
INTEGER, ALLOCATABLE :: NodeIndex(:)
254
INTEGER :: body_id, MaxGroup, group0, group
255
INTEGER, POINTER :: DgMap(:), DgMaster(:), DgSlave(:)
256
LOGICAL :: GotDgMap, GotMaster, GotSlave
257
!------------------------------------------------------------------------------
258
259
DgMap => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Mapping',GotDgMap )
260
DgMaster => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Master Bodies',GotMaster )
261
DgSlave => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Slave Bodies',GotSlave )
262
263
IF( GotDgMap ) THEN
264
IF( SIZE( DgMap ) /= Model % NumberOfBodies ) THEN
265
CALL Fatal(Caller,'Invalid size of > Dg Reduced Basis Mapping <')
266
END IF
267
MaxGroup = MAXVAL( DgMap )
268
ELSE IF( GotMaster ) THEN
269
MaxGroup = 2
270
ELSE
271
MaxGroup = Model % NumberOfBodies
272
END IF
273
274
ALLOCATE( NodeIndex( Mesh % NumberOfNodes ) )
275
276
DO group0 = 1, MaxGroup
277
278
! If we have master-slave lists then nullify the slave nodes at the master
279
! interface since we want new indexes here.
280
IF( GotSlave .AND. group0 == 2 ) THEN
281
DO t=1,Mesh % NumberOfBulkElements
282
Element => Mesh % Elements(t)
283
group = Element % BodyId
284
IF( ANY( DgSlave == group ) ) THEN
285
NodeIndex( Element % NodeIndexes ) = 0
286
END IF
287
END DO
288
ELSE
289
! In generic case nullify all indexes already set
290
NodeIndex = 0
291
END IF
292
293
k1 = k
294
295
CALL Info(Caller,&
296
'Group '//I2S(group0)//' starts from index '//I2S(k1),Level=10)
297
298
DO t=1,Mesh % NumberOfBulkElements
299
Element => Mesh % Elements(t)
300
301
group = Element % BodyId
302
303
IF( GotMaster ) THEN
304
IF( group0 == 1 ) THEN
305
! First loop number dofs in "master bodies" only
306
IF( .NOT. ANY( DgMaster == group ) ) CYCLE
307
ELSE
308
! Second loop number dofs in all bodies except "master bodies"
309
IF( ANY( DgMaster == group ) ) CYCLE
310
END IF
311
ELSE IF( GotDgMap ) THEN
312
group = DgMap( group )
313
IF( group0 /= group ) CYCLE
314
ELSE
315
IF( group0 /= group ) CYCLE
316
END IF
317
318
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
319
FoundDG = FoundDG .OR. Element % DGDOFs > 0
320
DO i=1,Element % DGDOFs
321
j = Element % NodeIndexes(i)
322
IF( NodeIndex(j) == 0 ) THEN
323
k = k + 1
324
NodeIndex(j) = k
325
END IF
326
Perm( Element % DGIndexes(i) ) = NodeIndex(j)
327
END DO
328
END IF
329
END DO
330
331
IF( k > k1 ) THEN
332
CALL Info( Caller,'Group '//I2S(group0)//&
333
' has '//I2S(k-k1)//' db dofs',Level=15)
334
END IF
335
END DO
336
337
CALL Info(Caller,'Numbered '//I2S(k)//&
338
' db nodes from bulk hits',Level=15)
339
340
IF ( FoundDG ) THEN
341
GOTO 10
342
! RETURN ! Discontinuous bodies !!!
343
END IF
344
END BLOCK
345
END IF
346
347
348
IF ( DG ) THEN
349
DO t=1,Mesh % NumberOfEdges
350
n = 0
351
Element => Mesh % Edges(t) % BoundaryInfo % Left
352
IF ( ASSOCIATED( Element ) ) THEN
353
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
354
FoundDG = FoundDG .OR. Element % DGDOFs > 0
355
DO j=1,Element % DGDOFs
356
n = n + 1
357
Indexes(n) = Element % DGIndexes(j)
358
END DO
359
END IF
360
END IF
361
362
Element => Mesh % Edges(t) % BoundaryInfo % Right
363
IF ( ASSOCIATED( Element ) ) THEN
364
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
365
FoundDG = FoundDG .OR. Element % DGDOFs > 0
366
DO j=1,Element % DGDOFs
367
n = n + 1
368
Indexes(n) = Element % DGIndexes(j)
369
END DO
370
END IF
371
END IF
372
373
DO i=1,n
374
j = Indexes(i)
375
IF ( Perm(j) == 0 ) THEN
376
k = k + 1
377
Perm(j) = k
378
END IF
379
END DO
380
END DO
381
382
CALL Info(Caller,'Numbered '//I2S(k)//&
383
' nodes from face hits',Level=15)
384
k1 = k
385
386
387
DO t=1,Mesh % NumberOfFaces
388
n = 0
389
Element => Mesh % Faces(t) % BoundaryInfo % Left
390
IF ( ASSOCIATED( Element ) ) THEN
391
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
392
FoundDG = FoundDG .OR. Element % DGDOFs > 0
393
DO j=1,Element % DGDOFs
394
n = n + 1
395
Indexes(n) = Element % DGIndexes(j)
396
END DO
397
END IF
398
END IF
399
400
Element => Mesh % Faces(t) % BoundaryInfo % Right
401
IF ( ASSOCIATED( Element ) ) THEN
402
IF ( CheckElementEquation(Model,Element,Equation) ) THEN
403
FoundDG = FoundDG .OR. Element % DGDOFs > 0
404
DO j=1,Element % DGDOFs
405
n = n + 1
406
Indexes(n) = Element % DGIndexes(j)
407
END DO
408
END IF
409
END IF
410
411
DO i=1,n
412
j = Indexes(i)
413
IF ( Perm(j) == 0 ) THEN
414
k = k + 1
415
Perm(j) = k
416
END IF
417
END DO
418
END DO
419
420
CALL Info(Caller,'Numbered '//I2S(k-k1)//&
421
' nodes from bulk hits',Level=15)
422
423
IF ( FoundDG ) THEN
424
GOTO 10
425
! RETURN ! Discontinuous galerkin !!!
426
END IF
427
END IF
428
429
! In the case of p-elements two neighbouring elements may have different
430
! degrees of approximation, find out the highest order associated with
431
! a particular edge or face:
432
!
433
IF ( ANY(Solver % Def_Dofs(:,:,6)>=1) ) THEN
434
IF ( Mesh % NumberOFEdges>0 ) THEN
435
ALLOCATE(EdgeDOFs(Mesh % NumberOfEdges))
436
EdgeDOFs=0;
437
END IF
438
439
IF ( Mesh % NumberOFFaces>0 ) THEN
440
ALLOCATE(FaceDOFs(Mesh % NumberOfFaces))
441
FaceDOFs=0;
442
END IF
443
444
n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements
445
t = 1
446
DO WHILE( t <= n )
447
DO WHILE( t<=n )
448
Element => Mesh % Elements(t)
449
IF ( CheckElementEquation( Model, Element, Equation ) ) EXIT
450
t = t + 1
451
END DO
452
IF ( t>n ) EXIT
453
454
el_id = Element % TYPE % ElementCode / 100
455
456
Def_Dofs => Solver % Def_Dofs(el_id,Element % BodyId,:)
457
IF ( ASSOCIATED(Element % EdgeIndexes) ) THEN
458
IF(Element % Type % ElementCode >= 300) THEN
459
DO i=1,Element % TYPE % NumberOfEdges
460
j = Element % EdgeIndexes(i)
461
EdgeDOFs(j)=MAX(EdgeDOFs(j),getEdgeDOFs(Element,Def_Dofs(6)))
462
END DO
463
END IF
464
END IF
465
466
IF ( ASSOCIATED(Element % FaceIndexes) ) THEN
467
IF(Element % Type % ElementCode >= 500) THEN
468
DO i=1,Element % TYPE % NumberOfFaces
469
j = Element % FaceIndexes(i)
470
FaceDOFs(j)=MAX(FaceDOFs(j),getFaceDOFs(Element,Def_Dofs(6),i, &
471
Mesh % Faces(j)) )
472
END DO
473
END IF
474
END IF
475
t=t+1
476
END DO
477
END IF
478
479
480
n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements
481
t = 1
482
DO WHILE( t <= n )
483
484
DO WHILE( t<=n )
485
Element => Mesh % Elements(t)
486
IF ( CheckElementEquation( Model, Element, Equation ) ) EXIT
487
t = t + 1
488
END DO
489
490
IF ( t > n ) EXIT
491
492
el_id = Element % TYPE % ElementCode / 100
493
Def_Dofs => Solver % Def_Dofs(el_id,Element % BodyId,:)
494
495
ndofs = Def_Dofs(1)
496
IF (ndofs > 0) THEN
497
DO i=1,Element % TYPE % NumberOfNodes
498
DO j=1,ndofs
499
l = MaxNDOFs * (Element % NodeIndexes(i)-1) + j
500
IF ( Perm(l) == 0 ) THEN
501
k = k + 1
502
Perm(l) = k
503
END IF
504
END DO
505
END DO
506
END IF
507
508
IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN
509
DO i=1,Element % TYPE % NumberOfEdges
510
Edge => Mesh % Edges( Element % EdgeIndexes(i) )
511
IF(Element % Type % ElementCode==Edge % Type % ElementCode.AND..NOT.GB) CYCLE
512
513
ndofs = 0
514
IF ( Def_Dofs(2) >= 0) THEN
515
ndofs = Def_Dofs(2)
516
ELSE IF (Def_Dofs(6)>1) THEN
517
ndofs = EdgeDOFs(Element % EdgeIndexes(i))
518
END IF
519
520
DO e=1,ndofs
521
j = NodalIndexOffset + MaxEDOFs*(Element % EdgeIndexes(i)-1) + e
522
IF ( Perm(j) == 0 ) THEN
523
k = k + 1
524
Perm(j) = k
525
END IF
526
END DO
527
END DO
528
END IF
529
530
IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN
531
DO i=1,Element % TYPE % NumberOfFaces
532
Face => Mesh % Faces( Element % FaceIndexes(i) )
533
IF(Element % Type % ElementCode==Face % Type % ElementCode.AND..NOT.GB) CYCLE
534
535
l = MAX(0,Def_Dofs(3))
536
j = Face % TYPE % ElementCode/100
537
538
IF(l==0) THEN
539
!
540
! NOTE: This depends on what dofs have been introduced
541
! by using the construct "-quad_face b: ..." and
542
! "-tri_face b: ..."
543
!
544
IF (ASSOCIATED(Face % BoundaryInfo % Left)) THEN
545
e = Face % BoundaryInfo % Left % BodyId
546
l = MAX(0,Solver % Def_Dofs(j+6,e,5))
547
END IF
548
IF (ASSOCIATED(Face % BoundaryInfo % Right)) THEN
549
e = Face % BoundaryInfo % Right % BodyId
550
l = MAX(l,Solver % Def_Dofs(j+6,e,5))
551
END IF
552
END IF
553
554
ndofs = 0
555
IF (l > 0) THEN
556
ndofs = l
557
ELSE IF (Def_Dofs(6)>1) THEN
558
ndofs = FaceDOFs(Element % FaceIndexes(i))
559
END IF
560
561
DO e=1,ndofs
562
j = NodalIndexOffset + EdgeIndexOffset + &
563
MaxFDOFs*(Element % FaceIndexes(i)-1) + e
564
IF ( Perm(j) == 0 ) THEN
565
k = k + 1
566
Perm(j) = k
567
END IF
568
END DO
569
END DO
570
END IF
571
572
IF ( GB .AND. ASSOCIATED(Element % BubbleIndexes) ) THEN
573
ndofs = 0
574
BDOFs = Def_Dofs(5)
575
j = Def_Dofs(6)
576
IF (BDOFs >= 0 .OR. j >= 1) THEN
577
! Apparently an "Element" command has been given so we use
578
! the given definition
579
IF (j > 1) ndofs = GetBubbleDOFs(Element, j)
580
ndofs = MAX(BDOFs, ndofs)
581
ELSE
582
! Apparently no "Element" command has been given which should
583
! activate the use of bubbles. Then the only way to activate the use of
584
! bubbles seems to be "Bubbles" command. If this is not present, we
585
! see no reason to add the indexes for bubble DOFs
586
Bubbles = ListGetLogical(Solver % Values, 'Bubbles', Found )
587
! The following is not a right way to obtain the bubble count
588
! in order to support solverwise definitions
589
IF (Bubbles) ndofs = SIZE(Element % BubbleIndexes)
590
END IF
591
592
DO i=1,ndofs
593
j = NodalIndexOffset + EdgeIndexOffset + &
594
FaceIndexOffset + Element % BubbleIndexes(i)
595
IF ( Perm(j) == 0 ) THEN
596
k = k + 1
597
Perm(j) = k
598
END IF
599
END DO
600
END IF
601
602
t = t + 1
603
END DO
604
605
Radiation = ListGetLogical( Solver % Values, 'Radiation Solver', Found )
606
IF ( Radiation ) THEN
607
Parallel = ParEnv % PEs>1
608
t = Mesh % NumberOfBulkElements + 1
609
n = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements
610
DO WHILE( t<= n )
611
Element => Mesh % Elements(t)
612
IF ( RadiationCheck(Element) ) THEN
613
DO i=1,Element % TYPE % NumberOfNodes
614
j = Element % NodeIndexes(i)
615
IF ( Perm(j) == 0 ) THEN
616
k = k + 1
617
Perm(j) = k
618
END IF
619
END DO
620
END IF
621
t = t + 1
622
END DO
623
END IF
624
625
t = Mesh % NumberOfBulkElements + 1
626
n = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements
627
DO WHILE( t<= n )
628
Element => Mesh % Elements(t)
629
IF ( Element % TYPE % ElementCode == 102 ) THEN
630
DO i=1,Element % TYPE % NumberOfNodes
631
j = Element % NodeIndexes(i)
632
IF ( Perm(j) == 0 ) THEN
633
k = k + 1
634
Perm(j) = k
635
END IF
636
END DO
637
END IF
638
t = t + 1
639
END DO
640
641
! Here we create the initial permutation such that the conforming dofs are eliminated.
642
IF( ListGetLogical( Solver % Values,'Apply Conforming BCs',Found ) ) THEN
643
BLOCK
644
INTEGER, POINTER :: TmpPerm(:)
645
LOGICAL, POINTER :: TmpFlip(:)
646
647
IF(.NOT. ASSOCIATED( Mesh % PeriodicPerm ) ) THEN
648
CALL Warn(Caller,'Conforming BC is requested but not generated!')
649
ELSE
650
Solver % PeriodicFlipActive = .FALSE.
651
n = SIZE( Mesh % PeriodicPerm )
652
m = SIZE( Perm )
653
654
IF( n < m ) THEN
655
CALL Info(Caller,'Increasing size of periodic tables from '&
656
//I2S(n)//' to '//I2S(SIZE(Perm))//'!',Level=7)
657
ALLOCATE( TmpPerm(SIZE(Perm)) )
658
TmpPerm = 0
659
TmpPerm(1:n) = Mesh % PeriodicPerm(1:n)
660
DEALLOCATE(Mesh % PeriodicPerm)
661
Mesh % PeriodicPerm => TmpPerm
662
663
IF(ASSOCIATED(Mesh % PeriodicFlip ) ) THEN
664
ALLOCATE( TmpFlip(SIZE(Perm)) )
665
TmpFlip = .FALSE.
666
TmpFlip(1:n) = Mesh % PeriodicFlip(1:n)
667
DEALLOCATE(Mesh % PeriodicFlip)
668
Mesh % PeriodicFlip => TmpFlip
669
END IF
670
END IF
671
672
n = 0
673
IF( ASSOCIATED( Mesh % PeriodicPerm ) ) THEN
674
! Set the eliminated dofs to zero and renumber
675
WHERE( Mesh % PeriodicPerm(1:m) > 0 ) Perm = -Perm
676
677
k = 0
678
DO i=1,m
679
IF( Perm(i) > 0 ) THEN
680
k = k + 1
681
Perm(i) = k
682
END IF
683
END DO
684
685
DO i=1,m
686
j = Mesh % PeriodicPerm(i)
687
IF( j > 0 ) THEN
688
IF( Perm(i) /= 0 ) THEN
689
Perm(i) = Perm(j)
690
IF(Mesh % PeriodicFlip(i)) n = n + 1
691
END IF
692
END IF
693
END DO
694
695
Solver % PeriodicFlipActive = ( n > 0 )
696
CALL Info(Caller,'Number of periodic flips in the field: '//I2S(n),Level=8)
697
END IF
698
END IF
699
END BLOCK
700
END IF
701
702
IF ( ALLOCATED(EdgeDOFs) ) DEALLOCATE(EdgeDOFs)
703
IF ( ALLOCATED(FaceDOFs) ) DEALLOCATE(FaceDOFs)
704
705
10 CONTINUE
706
707
!------------------------------------------------------------------------------
708
END FUNCTION InitialPermutation
709
!------------------------------------------------------------------------------
710
711
712
!---------------------------------------------------------------------------
713
FUNCTION RadiationCheck(Element) RESULT(L)
714
!---------------------------------------------------------------------------
715
LOGICAL :: L, Found
716
717
INTEGER :: t
718
719
TYPE(Element_t), POINTER :: Element
720
TYPE(ValueList_t), POINTER :: BC
721
CHARACTER(:), ALLOCATABLE :: RadiationFlag
722
723
L = .FALSE.
724
IF ( Element % Type % ElementCode<=1 ) RETURN
725
726
t = Element % BoundaryInfo % Constraint
727
IF(t<=0 .OR. t>SIZE(CurrentModel % BCs)) RETURN
728
729
BC => CurrentModel % BCs(t) % Values
730
RadiationFlag = ListGetString( BC, 'Radiation', Found )
731
IF (RadiationFlag=='diffuse gray' .OR. ListGetLogical(BC,'Radiator BC',Found)) L=.TRUE.
732
!---------------------------------------------------------------------------
733
END FUNCTION RadiationCheck
734
!---------------------------------------------------------------------------
735
736
737
!---------------------------------------------------------------------------
738
!> Check if given element belongs to a body for which given equation
739
!> should be solved.
740
!---------------------------------------------------------------------------
741
FUNCTION CheckElementEquation( Model,Element,Equation ) RESULT(Flag)
742
TYPE(Element_t), POINTER :: Element
743
TYPE(Model_t) :: Model
744
CHARACTER(LEN=*) :: Equation
745
CHARACTER(:), ALLOCATABLE :: PrevEquation
746
747
LOGICAL :: Flag,Found,PrevFlag
748
749
INTEGER :: k,body_id,prev_body_id = -1
750
751
SAVE Prev_body_id, PrevEquation, PrevFlag
752
!$OMP THREADPRIVATE(Prev_body_id, PrevEquation, PrevFlag)
753
754
body_id = Element % BodyId
755
756
IF( body_id == prev_body_id) THEN
757
IF (Equation == PrevEquation) THEN
758
Flag = PrevFlag
759
RETURN
760
END IF
761
END IF
762
763
prev_body_id = body_id
764
PrevEquation = Equation
765
766
Flag = .FALSE.
767
IF ( body_id > 0 .AND. body_id <= Model % NumberOfBodies ) THEN
768
k = ListGetInteger( Model % Bodies(body_id) % Values, 'Equation', Found, &
769
minv=1, maxv=Model % NumberOFEquations )
770
IF ( k > 0 ) THEN
771
Flag = ListGetLogical(Model % Equations(k) % Values,Equation,Found)
772
END IF
773
END IF
774
PrevFlag = Flag
775
776
!---------------------------------------------------------------------------
777
END FUNCTION CheckElementEquation
778
!---------------------------------------------------------------------------
779
780
781
!------------------------------------------------------------------------------
782
!> Changes the string to all lower case to allow string comparison.
783
!------------------------------------------------------------------------------
784
FUNCTION StringToLowerCase( to,from,same_len ) RESULT(n)
785
!------------------------------------------------------------------------------
786
CHARACTER(LEN=*), INTENT(in) :: from
787
CHARACTER(LEN=*), INTENT(out) :: to
788
LOGICAL, OPTIONAL, INTENT(in) :: same_len
789
!------------------------------------------------------------------------------
790
INTEGER :: n
791
INTEGER :: i,j,nlen
792
INTEGER, PARAMETER :: A=ICHAR('A'),Z=ICHAR('Z'),U2L=ICHAR('a')-ICHAR('A')
793
794
n = LEN(to)
795
IF (.NOT.PRESENT(same_len)) THEN
796
DO i=LEN(from),1,-1
797
IF ( from(i:i) /= ' ' ) EXIT
798
END DO
799
IF ( n>i ) THEN
800
to(i+1:n) = ' '
801
n=i
802
END IF
803
END IF
804
805
nlen = n
806
DO i=1,nlen
807
j = ICHAR( from(i:i) )
808
IF ( j >= A .AND. j <= Z ) THEN
809
to(i:i) = CHAR(j+U2L)
810
ELSE
811
to(i:i) = from(i:i)
812
IF ( to(i:i)=='[') n=i-1
813
END IF
814
END DO
815
END FUNCTION StringToLowerCase
816
!------------------------------------------------------------------------------
817
818
819
!------------------------------------------------------------------------------
820
!> Inserts totally legit variable to variable list.
821
!------------------------------------------------------------------------------
822
SUBROUTINE VariableAppend( Variables,NewVar)
823
!------------------------------------------------------------------------------
824
TYPE(Variable_t), POINTER :: Variables
825
TYPE(Variable_t), POINTER :: NewVar
826
!------------------------------------------------------------------------------
827
LOGICAL :: stat
828
TYPE(Variable_t), POINTER :: ptr,ptr1
829
LOGICAL :: Hit
830
INTEGER :: n,n1
831
CHARACTER(*), PARAMETER :: Caller = 'VariableAppend'
832
!------------------------------------------------------------------------------
833
834
835
CALL Info(Caller,'Inserting variable > '//TRIM(NewVar % Name)//&
836
' < of size '//I2S(SIZE(NewVar % Values)),Level=15)
837
838
IF ( .NOT.ASSOCIATED(NewVar) ) THEN
839
CALL Warn(Caller,'Cannot insert null variable to list!')
840
RETURN
841
END IF
842
843
IF ( .NOT.ASSOCIATED(Variables) ) THEN
844
CALL Warn(Caller,'Cannot insert variable to empty list!')
845
RETURN
846
END IF
847
848
n1 = LEN_TRIM( NewVar % Name )
849
850
851
Hit = .FALSE.
852
ptr => Variables
853
DO WHILE( ASSOCIATED( ptr ) )
854
n = LEN_TRIM( ptr % Name )
855
IF ( n == n1 ) THEN
856
IF ( ptr % Name(1:n) == NewVar % Name(1:n) ) THEN
857
Hit = .TRUE.
858
EXIT
859
END IF
860
END IF
861
ptr1 => ptr
862
ptr => ptr % Next
863
END DO
864
865
IF( Hit ) THEN
866
CALL Info(Caller,'Found variable in list: '//TRIM(NewVar % Name))
867
ELSE
868
CALL Info(Caller,'Append existing variable to end of list: '//TRIM(NewVar % Name))
869
ptr1 % Next => NewVar
870
NewVar % Next => NULL()
871
END IF
872
873
END SUBROUTINE VariableAppend
874
!------------------------------------------------------------------------------
875
876
877
878
!------------------------------------------------------------------------------
879
!> Adds a new variable to the list of variables.
880
!> The structures need to be allocated externally beforehand.
881
!------------------------------------------------------------------------------
882
SUBROUTINE VariableAdd( Variables,Mesh,Solver,Name,DOFs,Values,&
883
Perm,Output,Secondary,TYPE )
884
!------------------------------------------------------------------------------
885
TYPE(Variable_t), POINTER :: Variables
886
TYPE(Mesh_t), TARGET :: Mesh
887
TYPE(Solver_t), TARGET, OPTIONAL :: Solver
888
CHARACTER(LEN=*) :: Name
889
INTEGER :: DOFs
890
REAL(KIND=dp), POINTER :: Values(:)
891
INTEGER, OPTIONAL, POINTER :: Perm(:)
892
LOGICAL, OPTIONAL :: Output
893
LOGICAL, OPTIONAL :: Secondary
894
INTEGER, OPTIONAL :: TYPE
895
!------------------------------------------------------------------------------
896
LOGICAL :: stat
897
TYPE(Variable_t), POINTER :: ptr,ptr1,ptr2
898
TYPE(Solver_t), POINTER :: VSolver
899
!------------------------------------------------------------------------------
900
901
IF(ASSOCIATED(Values)) THEN
902
CALL Info('VariableAdd','Adding variable > '//TRIM(Name)//&
903
' < of size '//I2S(SIZE(Values)),Level=15)
904
ELSE
905
CALL Info('VariableAdd','Adding variable > '//TRIM(Name), Level=15)
906
END IF
907
908
NULLIFY(VSolver)
909
IF (PRESENT(Solver)) VSolver => Solver
910
911
IF ( .NOT.ASSOCIATED(Variables) ) THEN
912
ALLOCATE(Variables)
913
ptr => Variables
914
ELSE
915
ALLOCATE( ptr )
916
END IF
917
918
ALLOCATE(CHARACTER(LEN_TRIM(Name))::ptr % Name)
919
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
920
921
IF ( .NOT. ASSOCIATED(ptr, Variables) ) THEN
922
ptr1 => Variables
923
ptr2 => Variables
924
DO WHILE( ASSOCIATED( ptr1 ) )
925
IF ( ptr % Name == ptr1 % Name ) THEN
926
DEALLOCATE( ptr )
927
RETURN
928
END IF
929
ptr2 => ptr1
930
ptr1 => ptr1 % Next
931
END DO
932
ptr2 % Next => ptr
933
END IF
934
ptr % Next => NULL()
935
936
ptr % DOFs = DOFs
937
IF ( PRESENT( Perm ) ) THEN
938
ptr % Perm => Perm
939
ELSE
940
ptr % Perm => NULL()
941
END IF
942
ptr % Norm = 0.0d0
943
ptr % PrevNorm = 0.0d0
944
ptr % Values => Values
945
NULLIFY( ptr % PrevValues )
946
NULLIFY( ptr % EigenValues, ptr % EigenVectors )
947
948
ptr % NonlinChange = 0.0_dp
949
ptr % SteadyChange = 0.0_dp
950
ptr % NonlinValues => NULL()
951
ptr % SteadyValues => NULL()
952
ptr % NonlinIter = 0
953
954
ptr % Solver => VSolver
955
ptr % PrimaryMesh => Mesh
956
957
ptr % Valid = .TRUE.
958
ptr % Output = .TRUE.
959
ptr % Secondary = .FALSE.
960
ptr % ValuesChanged = .TRUE.
961
962
! Converged information undefined = -1, not = 0, yes = 1
963
ptr % NonlinConverged = -1
964
ptr % SteadyConverged = -1
965
966
IF ( PRESENT( Secondary ) ) THEN
967
ptr % Secondary = Secondary
968
END IF
969
970
IF ( PRESENT( TYPE ) ) THEN
971
ptr % TYPE = TYPE
972
ELSE
973
IF(.NOT. PRESENT(Perm) .AND. ASSOCIATED(Values)) THEN
974
IF(SIZE(Values) == DOFs) ptr % Type = Variable_global
975
END IF
976
END IF
977
978
IF ( PRESENT( Output ) ) ptr % Output = Output
979
980
981
!------------------------------------------------------------------------------
982
END SUBROUTINE VariableAdd
983
!------------------------------------------------------------------------------
984
985
986
!------------------------------------------------------------------------------
987
SUBROUTINE ReleaseVariableList( VariableList )
988
!------------------------------------------------------------------------------
989
USE SpariterGlobals
990
TYPE(Variable_t), POINTER :: VariableList
991
!------------------------------------------------------------------------------
992
REAL(KIND=dp), POINTER :: Ptr(:)
993
LOGICAL :: GotValues
994
INTEGER :: i, n, m
995
TYPE(Variable_t), POINTER :: Var, Var1
996
!------------------------------------------------------------------------------
997
998
Var => VariableList
999
DO WHILE( ASSOCIATED( Var ) )
1000
1001
! This is used to skip variables such as time, timestep, timestep size etc.
1002
IF (ASSOCIATED(Var % Values) ) THEN
1003
IF( SIZE( Var % Values ) == Var % DOFs ) THEN
1004
Var => Var % Next
1005
CYCLE
1006
END IF
1007
END IF
1008
1009
SELECT CASE( Var % Name )
1010
CASE( 'coordinate 1', 'coordinate 2', 'coordinate 3' )
1011
Var => Var % Next
1012
CYCLE
1013
END SELECT
1014
1015
IF( InfoActive(30) ) THEN
1016
CALL Info('ReleaseVariableList','Trying to release variable: '//TRIM(Var % Name))
1017
END IF
1018
1019
IF( Var % Secondary ) THEN
1020
Var => Var % Next
1021
CYCLE
1022
END IF
1023
1024
IF (Var % DOFs > 1) THEN
1025
Var => Var % Next
1026
CYCLE
1027
END IF
1028
!
1029
! Check that the variable is actually allocated,
1030
! not pointer to some other variables memory:
1031
! ----------------------------------------------
1032
1033
GotValues = .TRUE.
1034
Var1 => VariableList
1035
DO WHILE( ASSOCIATED( Var1 ) )
1036
IF (.NOT.ASSOCIATED(Var,Var1)) THEN
1037
IF ( ASSOCIATED(Var1 % Values) ) THEN
1038
DO i=1,Var1 % DOFs
1039
ptr => Var1 % Values(i::Var1 % DOFs)
1040
IF ( ASSOCIATED(Var % Values,ptr) ) THEN
1041
GotValues = .FALSE.
1042
EXIT
1043
END IF
1044
END DO
1045
END IF
1046
END IF
1047
IF (.NOT. GotValues) EXIT
1048
Var1 => Var1 % Next
1049
END DO
1050
1051
IF (ASSOCIATED(Var % Values)) THEN
1052
IF(SIZE(Var % Values)<=0) GotValues = .FALSE.
1053
END IF
1054
1055
IF (ASSOCIATED(Var % Perm)) THEN
1056
Var1 => VariableList
1057
DO WHILE(ASSOCIATED(Var1))
1058
IF (.NOT.ASSOCIATED(Var,Var1)) THEN
1059
IF (ASSOCIATED(Var % Perm,Var1 % Perm)) &
1060
Var1 % Perm => NULL()
1061
END IF
1062
Var1 => Var1 % Next
1063
END DO
1064
1065
IF(SIZE(Var % Perm)>0) THEN
1066
DEALLOCATE( Var % Perm)
1067
ELSE
1068
GotValues = .FALSE.
1069
END IF
1070
END IF
1071
1072
IF ( GotValues ) THEN
1073
CALL DeallocateVariableEntries()
1074
END IF
1075
NULLIFY( Var % EigenVectors, Var % EigenValues )
1076
NULLIFY( Var % Values, Var % PrevValues, Var % Perm )
1077
NULLIFY( Var % SteadyValues, Var % NonlinValues )
1078
1079
Var => Var % Next
1080
END DO
1081
1082
Var => VariableList
1083
DO WHILE( ASSOCIATED( Var ) )
1084
IF ( Var % Secondary ) THEN
1085
Var => Var % Next
1086
CYCLE
1087
END IF
1088
1089
IF ( ASSOCIATED( Var % Perm ) ) THEN
1090
Var1 => VariableList
1091
DO WHILE(ASSOCIATED(Var1))
1092
IF (.NOT.ASSOCIATED(Var,Var1)) THEN
1093
IF (ASSOCIATED(Var % Perm,Var1 % Perm)) THEN
1094
Var1 % Perm => NULL()
1095
END IF
1096
END IF
1097
Var1 => Var1 % Next
1098
END DO
1099
IF (SIZE(Var % Perm)>0) THEN
1100
DEALLOCATE( Var % Perm )
1101
END IF
1102
END IF
1103
1104
IF ( Var % DOFs > 1 ) THEN
1105
CALL DeallocateVariableEntries()
1106
END IF
1107
1108
NULLIFY( Var % EigenVectors, Var % EigenValues )
1109
NULLIFY( Var % Values, Var % PrevValues, Var % Perm )
1110
NULLIFY( Var % SteadyValues, Var % NonlinValues )
1111
1112
Var => Var % Next
1113
END DO
1114
1115
1116
! Deallocate mesh variable list:
1117
! ------------------------------
1118
Var => VariableList
1119
DO WHILE( ASSOCIATED( Var ) )
1120
Var1 => Var % Next
1121
DEALLOCATE( Var )
1122
Var => Var1
1123
END DO
1124
1125
CONTAINS
1126
1127
SUBROUTINE DeallocateVariableEntries()
1128
1129
IF ( ASSOCIATED( Var % Values ) ) &
1130
DEALLOCATE( Var % Values )
1131
1132
IF ( ASSOCIATED( Var % PrevValues ) ) &
1133
DEALLOCATE( Var % PrevValues )
1134
1135
IF ( ASSOCIATED( Var % EigenValues ) ) &
1136
DEALLOCATE( Var % EigenValues )
1137
1138
IF ( ASSOCIATED( Var % EigenVectors ) ) &
1139
DEALLOCATE( Var % EigenVectors )
1140
1141
IF ( ASSOCIATED( Var % SteadyValues ) ) &
1142
DEALLOCATE( Var % SteadyValues )
1143
1144
IF ( ASSOCIATED( Var % NonlinValues ) ) &
1145
DEALLOCATE( Var % NonlinValues )
1146
1147
IF( ASSOCIATED( Var % ConstraintModesIndeces ) ) &
1148
DEALLOCATE( Var % ConstraintModesIndeces )
1149
1150
IF( ASSOCIATED( Var % ConstraintModes ) ) &
1151
DEALLOCATE( Var % ConstraintModes )
1152
1153
IF( ASSOCIATED( Var % UpperLimitActive ) ) &
1154
DEALLOCATE( Var % UpperLimitActive )
1155
1156
IF( ASSOCIATED( Var % LowerLimitActive ) ) &
1157
DEALLOCATE( Var % LowerLimitActive )
1158
1159
IF( ASSOCIATED( Var % IpTable ) ) &
1160
DEALLOCATE( Var % IpTable )
1161
1162
IF( ASSOCIATED( Var % CValues ) ) &
1163
DEALLOCATE( Var % CValues )
1164
1165
IF( ASSOCIATED( Var % PValues ) ) &
1166
DEALLOCATE( Var % PValues )
1167
1168
END SUBROUTINE DeallocateVariableEntries
1169
1170
!------------------------------------------------------------------------------
1171
END SUBROUTINE ReleaseVariableList
1172
!------------------------------------------------------------------------------
1173
1174
1175
!------------------------------------------------------------------------------
1176
!> Deletes a variable (by name) from list of variables
1177
!------------------------------------------------------------------------------
1178
SUBROUTINE VariableRemove(Variables, NameIn, WarnMiss)
1179
1180
IMPLICIT NONE
1181
!-----------------------------------------------
1182
TYPE(Variable_t), POINTER :: Variables
1183
CHARACTER(LEN=*) :: NameIn
1184
LOGICAL, OPTIONAL :: WarnMiss
1185
!-----------------------------------------------
1186
TYPE(Variable_t), POINTER :: Var, Prev, RmVar
1187
CHARACTER(LEN=LEN_TRIM(NameIn)) :: Name
1188
LOGICAL :: GotIt, WarnMissing
1189
INTEGER :: k
1190
1191
GotIt = .FALSE.
1192
IF(PRESENT(WarnMiss)) THEN
1193
WarnMissing = WarnMiss
1194
ELSE
1195
WarnMissing = .TRUE.
1196
END IF
1197
1198
Var => Variables
1199
Prev => NULL()
1200
k = StringToLowerCase(Name, NameIn,.TRUE.)
1201
1202
WRITE(Message,'(a,a)') "Removing variable: ",Name(1:k)
1203
CALL Info("VariableRemove",Message, Level=10)
1204
1205
!Find variable by name, and hook up % Next appropriately
1206
DO WHILE(ASSOCIATED(Var))
1207
IF( Var % NameLen == k ) THEN
1208
IF(Var % Name(1:k) == Name(1:k)) THEN
1209
GotIt = .TRUE.
1210
RmVar => Var
1211
IF(ASSOCIATED(Prev)) THEN
1212
!Link up variables either side of removed var
1213
Prev % Next => Var % Next
1214
ELSE
1215
!If this was the first variable, we point Variables
1216
!at the next one...
1217
Variables => Var % Next
1218
END IF
1219
EXIT
1220
END IF
1221
END IF
1222
Prev => Var
1223
Var => Prev % Next
1224
END DO
1225
1226
IF(.NOT. GotIt) THEN
1227
IF(WarnMissing) CALL Warn("VariableRemove","Couldn't find the variable, returning...")
1228
RETURN
1229
END IF
1230
1231
RmVar % Next => NULL()
1232
1233
!cycle other variables to check for Perm association
1234
IF (ASSOCIATED(RmVar % Perm)) THEN
1235
Var => Variables
1236
DO WHILE(ASSOCIATED(Var))
1237
IF(ASSOCIATED(RmVar, Var)) &
1238
CALL Fatal("VariableRemove", "Programming Error - Variable appears twice in list?")
1239
IF (ASSOCIATED(Var % Perm,RmVar % Perm)) THEN
1240
RmVar % Perm => NULL()
1241
EXIT
1242
END IF
1243
Var => Var % Next
1244
END DO
1245
1246
!ASSOCIATION between zero-length arrays cannot be tested
1247
!so nullify it anyway, just to be safe. Technically results
1248
!in a memory leak (of size zero??)
1249
IF(SIZE(RmVar % Perm) == 0) RmVar % Perm => NULL()
1250
END IF
1251
1252
1253
1254
!ReleaseVariableList was intended to deallocate an entire list of variables,
1255
!but by nullifying RmVar % Next, we have effectively isolated RmVar in
1256
!its own variable list.
1257
CALL ReleaseVariableList( RmVar )
1258
!------------------------------------------------------------------------------
1259
END SUBROUTINE VariableRemove
1260
!------------------------------------------------------------------------------
1261
1262
1263
1264
!------------------------------------------------------------------------------
1265
!> For vectors the individual components are added also to the list
1266
!> of variables. This routine makes the addition of vectors less laborious.
1267
!> Also allocates the field values if not given in the parameter list.
1268
!------------------------------------------------------------------------------
1269
SUBROUTINE VariableAddVector( Variables,Mesh,Solver,Name,DOFs,Values,&
1270
Perm,Output,Secondary,VarType,Global,InitValue,IpPoints,varsuffix)
1271
!------------------------------------------------------------------------------
1272
TYPE(Variable_t), POINTER :: Variables
1273
TYPE(Mesh_t), TARGET :: Mesh
1274
TYPE(Solver_t), TARGET, OPTIONAL :: Solver
1275
CHARACTER(LEN=*) :: Name
1276
INTEGER, OPTIONAL :: DOFs
1277
REAL(KIND=dp), OPTIONAL, POINTER :: Values(:)
1278
LOGICAL, OPTIONAL :: Output
1279
INTEGER, OPTIONAL, POINTER :: Perm(:)
1280
LOGICAL, OPTIONAL :: Secondary
1281
INTEGER, OPTIONAL :: VarType
1282
LOGICAL, OPTIONAL :: Global
1283
REAL(KIND=dp), OPTIONAL :: InitValue
1284
LOGICAL, OPTIONAL :: IpPoints
1285
CHARACTER(LEN=*), OPTIONAL :: VarSuffix
1286
!------------------------------------------------------------------------------
1287
CHARACTER(:), ALLOCATABLE :: tmpname
1288
REAL(KIND=dp), POINTER :: Component(:), TmpValues(:)
1289
INTEGER :: i,nsize, ndofs, FieldType
1290
LOGICAL :: IsPerm, IsGlobal, IsIPPoints
1291
!------------------------------------------------------------------------------
1292
1293
IF( PRESENT( DOFs ) ) THEN
1294
ndofs = Dofs
1295
ELSE
1296
ndofs = 1
1297
END IF
1298
1299
IsPerm = .FALSE.
1300
IsGlobal = .FALSE.
1301
IsIPPoints = .FALSE.
1302
1303
IsPerm = PRESENT( Perm )
1304
IF( PRESENT( Global ) ) IsGlobal = Global
1305
IF( PRESENT( IPPoints ) ) IsIPPoints = IPPoints
1306
1307
IF( PRESENT( VarType ) ) THEN
1308
FieldType = VarType
1309
ELSE
1310
FieldType = variable_on_nodes
1311
END IF
1312
1313
1314
1315
CALL Info('VariableAddVector','Adding variable > '//TRIM(Name)//' < with '&
1316
//I2S(ndofs)//' components',Level=15)
1317
1318
IF(PRESENT(Values)) THEN
1319
TmpValues => Values
1320
ELSE
1321
IF( IsPerm ) THEN
1322
nsize = MAXVAL( Perm )
1323
ELSE IF( IsGlobal ) THEN
1324
nsize = 1
1325
ELSE IF( IsIpPoints ) THEN
1326
IF( .NOT. PRESENT( Solver ) ) THEN
1327
CALL Fatal('VariableAddVector','Integration point variable needs a Solver!')
1328
END IF
1329
IF( .NOT. ASSOCIATED( Solver % IPTable ) ) THEN
1330
CALL Fatal('VariableAddVector','Integration point variable needs an IpTable')
1331
END IF
1332
nsize = Solver % IPTable % IPCount
1333
ELSE
1334
nsize = Mesh % NumberOfNodes
1335
END IF
1336
CALL Info('VariableAddVector','Allocating field of size: '//I2S(nsize),Level=12)
1337
1338
NULLIFY(TmpValues)
1339
ALLOCATE(TmpValues(ndofs*nsize))
1340
IF(.NOT. PRESENT(InitValue) ) THEN
1341
TmpValues = 0.0_dp
1342
END IF
1343
END IF
1344
1345
IF( PRESENT( InitValue ) ) THEN
1346
TmpValues = InitValue
1347
END IF
1348
1349
IF( nDOFs > 1 ) THEN
1350
DO i=1,nDOFs
1351
tmpname = ComponentName(Name,i)
1352
IF(PRESENT(VarSuffix)) tmpname = TRIM(tmpname)//' '//TRIM(VarSuffix)
1353
Component => TmpValues(i::nDOFs)
1354
CALL VariableAdd( Variables,Mesh,Solver,TmpName,1,Component,&
1355
Perm,Output,.TRUE.,VarType)
1356
END DO
1357
END IF
1358
1359
tmpname = TRIM(Name)
1360
IF(PRESENT(VarSuffix)) THEN
1361
tmpname = TRIM(tmpname)//' '//TRIM(VarSuffix)
1362
END IF
1363
1364
CALL VariableAdd( Variables,Mesh,Solver,tmpname,nDOFs,TmpValues,&
1365
Perm,Output,Secondary,VarType)
1366
1367
!------------------------------------------------------------------------------
1368
END SUBROUTINE VariableAddVector
1369
!------------------------------------------------------------------------------
1370
1371
1372
!------------------------------------------------------------------------------
1373
FUNCTION MeshProjector( Mesh1, Mesh2, &
1374
UseQuadrantTree, Trans ) RESULT( ProjectorMatrix )
1375
!------------------------------------------------------------------------------
1376
TYPE(Mesh_t) :: Mesh1, Mesh2
1377
LOGICAL, OPTIONAL :: UseQuadrantTree,Trans
1378
TYPE(Matrix_t), POINTER :: ProjectorMatrix
1379
!------------------------------------------------------------------------------
1380
TYPE(Projector_t), POINTER :: Projector
1381
!------------------------------------------------------------------------------
1382
INTERFACE
1383
SUBROUTINE InterpolateMeshToMeshQ( OldMesh, NewMesh, OldVariables, NewVariables, &
1384
UseQuadrantTree, Projector, MaskName, FoundNodes, NewMaskPerm, KeepUnfoundNodes )
1385
USE Types
1386
TYPE(Variable_t), POINTER, OPTIONAL :: OldVariables, NewVariables
1387
TYPE(Mesh_t), TARGET :: OldMesh, NewMesh
1388
LOGICAL, OPTIONAL :: UseQuadrantTree,FoundNodes(:)
1389
CHARACTER(LEN=*),OPTIONAL :: MaskName
1390
TYPE(Projector_t), POINTER, OPTIONAL :: Projector
1391
INTEGER, OPTIONAL, POINTER :: NewMaskPerm(:)
1392
LOGICAL, OPTIONAL :: KeepUnfoundNodes
1393
END SUBROUTINE InterpolateMeshToMeshQ
1394
END INTERFACE
1395
1396
IF ( PRESENT(UseQuadrantTree) ) THEN
1397
CALL InterpolateMeshToMeshQ( Mesh1, Mesh2, &
1398
UseQuadrantTree=UseQuadrantTree, Projector=Projector )
1399
ELSE
1400
CALL InterpolateMeshToMeshQ( Mesh1, Mesh2, Projector=Projector )
1401
END IF
1402
1403
ProjectorMatrix => Projector % Matrix
1404
IF ( PRESENT(Trans) ) THEN
1405
IF ( Trans ) THEN
1406
ProjectorMatrix => Projector % TMatrix
1407
END IF
1408
END IF
1409
!------------------------------------------------------------------------------
1410
END FUNCTION MeshProjector
1411
!------------------------------------------------------------------------------
1412
1413
1414
!------------------------------------------------------------------------------
1415
!> Find a variable by its name from the list of variables.
1416
!> If it not to be found in the current mesh, interpolation between
1417
!> meshes is automatically requested for.
1418
!------------------------------------------------------------------------------
1419
RECURSIVE FUNCTION VariableGet( Variables, Name, ThisOnly, MaskName, UnfoundFatal, &
1420
DoInterp ) RESULT(Var)
1421
!------------------------------------------------------------------------------
1422
TYPE(Variable_t), POINTER :: Variables
1423
CHARACTER(LEN=*) :: Name
1424
LOGICAL, OPTIONAL :: ThisOnly
1425
CHARACTER(LEN=*),OPTIONAL :: MaskName
1426
LOGICAL, OPTIONAL :: UnfoundFatal, DoInterp
1427
!------------------------------------------------------------------------------
1428
TYPE(Mesh_t), POINTER :: Mesh
1429
TYPE(Projector_t), POINTER :: Projector
1430
TYPE(Variable_t), POINTER :: Var,PVar,Tmp,AidVar
1431
REAL(KIND=dp), POINTER :: Vals(:)
1432
INTEGER :: i,k,n, DOFs, MAXNDOFs
1433
LOGICAL :: Found, GlobalBubbles, UseProjector, HackMesh, ExecInterpolation
1434
CHARACTER(LEN=LEN_TRIM(Name)) :: str
1435
DOUBLE PRECISION :: t1
1436
CHARACTER(:), ALLOCATABLE :: tmpname
1437
!------------------------------------------------------------------------------
1438
INTERFACE
1439
SUBROUTINE InterpolateMeshToMesh( OldMesh, NewMesh, OldVariables, &
1440
NewVariables, UseQuadrantTree, Projector, MaskName, UnfoundNodes )
1441
USE Types
1442
TYPE(Variable_t), POINTER, OPTIONAL :: OldVariables, NewVariables
1443
TYPE(Mesh_t), TARGET :: OldMesh, NewMesh
1444
LOGICAL, OPTIONAL :: UseQuadrantTree
1445
LOGICAL, POINTER, OPTIONAL :: UnfoundNodes(:)
1446
CHARACTER(LEN=*),OPTIONAL :: MaskName
1447
TYPE(Projector_t), POINTER, OPTIONAL :: Projector
1448
END SUBROUTINE InterpolateMeshToMesh
1449
END INTERFACE
1450
!------------------------------------------------------------------------------
1451
1452
1453
ExecInterpolation = .TRUE.
1454
IF(PRESENT(DoInterp)) ExecInterpolation = DoInterp
1455
1456
k = StringToLowerCase( str,Name,.TRUE. )
1457
1458
Tmp => Variables
1459
DO WHILE( ASSOCIATED(tmp) )
1460
IF ( tmp % NameLen == k ) THEN
1461
IF ( tmp % Name(1:k) == str(1:k) ) THEN
1462
IF ( Tmp % Valid ) THEN
1463
Var => Tmp
1464
RETURN
1465
END IF
1466
EXIT
1467
END IF
1468
END IF
1469
tmp => tmp % Next
1470
END DO
1471
Var => Tmp
1472
1473
!------------------------------------------------------------------------------
1474
IF ( PRESENT(ThisOnly) ) THEN
1475
IF ( ThisOnly ) THEN
1476
IF ( PRESENT(UnfoundFatal) ) THEN
1477
IF ( UnfoundFatal ) THEN
1478
CALL Fatal("VariableGet","Failed to find variable "//TRIM(Name))
1479
END IF
1480
END IF
1481
RETURN
1482
END IF
1483
END IF
1484
1485
!------------------------------------------------------------------------------
1486
NULLIFY( PVar )
1487
Mesh => CurrentModel % Meshes
1488
DO WHILE( ASSOCIATED( Mesh ) )
1489
IF ( .NOT.ASSOCIATED( Variables, Mesh % Variables ) ) THEN
1490
PVar => VariableGet( Mesh % Variables, Name, ThisOnly=.TRUE. )
1491
IF ( ASSOCIATED( PVar ) ) THEN
1492
IF ( ASSOCIATED( Mesh, PVar % PrimaryMesh ) ) THEN
1493
EXIT
1494
END IF
1495
END IF
1496
END IF
1497
Mesh => Mesh % Next
1498
END DO
1499
1500
IF (.NOT.ASSOCIATED( PVar ) ) THEN
1501
IF ( PRESENT(UnfoundFatal) ) THEN
1502
IF ( UnfoundFatal ) THEN
1503
CALL Fatal("VariableGet","Failed to find or interpolate variable: "//TRIM(Name))
1504
END IF
1505
END IF
1506
RETURN
1507
END IF
1508
1509
! If the variable is of type "global" do not do all the stupid hazzle to interpolate it.
1510
IF( pVar % TYPE == Variable_global ) THEN
1511
IF(.NOT. ASSOCIATED(Var)) THEN
1512
ALLOCATE(Var)
1513
END IF
1514
IF(.NOT. ASSOCIATED(Var % Values)) THEN
1515
ALLOCATE(Var % Values(SIZE(pVar % Values)))
1516
Var % Values = pVar % Values
1517
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1518
PVar % Name, PVar % DOFs, Var % Values, &
1519
Output = PVar % Output, TYPE = pVar % TYPE )
1520
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
1521
END IF
1522
Var % Values = pVar % Values
1523
RETURN
1524
END IF
1525
1526
!------------------------------------------------------------------------------
1527
IF ( .NOT.ASSOCIATED( Tmp ) ) THEN
1528
GlobalBubbles = .FALSE.
1529
IF(ASSOCIATED(Pvar % Solver)) GlobalBubbles = Pvar % Solver % GlobalBubbles
1530
1531
Mesh => CurrentModel % Mesh
1532
IF (PVar % PrimaryMesh % MaxNDOFs /= Mesh % MaxNDOFs) THEN
1533
MaxNDOFs = Mesh % MaxNDOFs
1534
IF (PVar % PrimaryMesh % MaxNDOFs == 1) THEN
1535
! Try to tamper the mesh temporarily, so that the permutation will be created as if
1536
! one nodal field was present
1537
HackMesh = .TRUE.
1538
Mesh % MaxNDOFs = 1
1539
ELSE
1540
CALL Fatal('VariableGet', 'non-matching permutation occurs due to an element definition n:'//I2S(MaxNDOFs))
1541
END IF
1542
ELSE
1543
HackMesh = .FALSE.
1544
END IF
1545
1546
1547
DOFs = Mesh % NumberOfNodes
1548
DOFs = DOFs + Mesh % NumberOfEdges * Mesh % MaxEdgeDOFs
1549
DOFs = DOFs + Mesh % NumberOfFaces * Mesh % MaxFaceDOFs
1550
IF ( GlobalBubbles ) THEN
1551
DOFs = DOFs + CurrentModel % Mesh % MaxBDOFs * &
1552
CurrentModel % Mesh % NumberOfBulkElements
1553
END IF
1554
1555
ALLOCATE( Var )
1556
ALLOCATE( Var % Values(DOFs*Pvar % DOFs) )
1557
Var % Values = 0
1558
1559
NULLIFY( Var % Perm )
1560
IF (ASSOCIATED(PVar % Perm)) THEN
1561
ALLOCATE( Var % Perm(DOFs) )
1562
1563
n = InitialPermutation( Var % Perm, CurrentModel, PVar % Solver, &
1564
CurrentModel % Mesh, ListGetString(PVar % Solver % Values,'Equation'), &
1565
GlobalBubbles=GlobalBubbles )
1566
1567
IF ( n==0 ) n=CurrentModel % Mesh % NumberOfNodes
1568
IF ( n == CurrentModel % Mesh % NumberOfNodes ) THEN
1569
DO i=1,n
1570
Var % Perm(i) = i
1571
END DO
1572
END IF
1573
END IF
1574
1575
IF (HackMesh) CurrentModel % Mesh % MaxNDOFs = MaxNDOFs
1576
1577
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1578
PVar % Name, PVar % DOFs, Var % Values, Var % Perm, PVar % Output )
1579
1580
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
1581
1582
NULLIFY( Var % PrevValues )
1583
IF ( ASSOCIATED( PVar % PrevValues ) ) THEN
1584
ALLOCATE( Var % PrevValues( DOFs, SIZE(PVar % PrevValues,2) ) )
1585
Var % PrevValues = 0._dp
1586
END IF
1587
1588
IF ( PVar % Name(1:PVar % NameLen) == 'flow solution' ) THEN
1589
Vals => Var % Values( 1: SIZE(Var % Values) : PVar % DOFs )
1590
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1591
'Velocity 1', 1, Vals, Var % Perm, PVar % Output )
1592
1593
Tmp => VariableGet( Variables, 'Velocity 1', .TRUE. )
1594
NULLIFY( Tmp % PrevValues )
1595
IF ( ASSOCIATED( Var % PrevValues ) ) &
1596
Tmp % PrevValues => Var % PrevValues(1::PVar % DOFs,:)
1597
1598
Vals => Var % Values( 2: SIZE(Var % Values) : PVar % DOFs )
1599
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1600
'Velocity 2', 1, Vals, Var % Perm, PVar % Output )
1601
1602
Tmp => VariableGet( Variables, 'Velocity 2', .TRUE. )
1603
NULLIFY( Tmp % PrevValues )
1604
IF ( ASSOCIATED( Var % PrevValues ) ) &
1605
Tmp % PrevValues => Var % PrevValues(2::PVar % DOFs,:)
1606
1607
IF ( PVar % DOFs == 3 ) THEN
1608
Vals => Var % Values( 3 : SIZE(Var % Values) : PVar % DOFs )
1609
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1610
'Pressure', 1, Vals, Var % Perm, PVar % Output )
1611
ELSE
1612
Vals => Var % Values( 3: SIZE(Var % Values) : PVar % DOFs )
1613
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1614
'Velocity 3', 1, Vals, Var % Perm, PVar % Output )
1615
1616
Tmp => VariableGet( Variables, 'Velocity 3', .TRUE. )
1617
NULLIFY( Tmp % PrevValues )
1618
IF ( ASSOCIATED( Var % PrevValues ) ) &
1619
Tmp % PrevValues => Var % PrevValues(3::PVar % DOFs,:)
1620
1621
Vals => Var % Values( 4: SIZE(Var % Values) : PVar % DOFs )
1622
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1623
'Pressure', 1, Vals, Var % Perm, PVar % Output )
1624
END IF
1625
1626
Tmp => VariableGet( Variables, 'Pressure', .TRUE. )
1627
NULLIFY( Tmp % PrevValues )
1628
IF ( ASSOCIATED( Var % PrevValues ) ) &
1629
Tmp % PrevValues => Var % PrevValues(PVar % DOFs::PVar % DOFs,:)
1630
ELSE
1631
IF ( PVar % DOFs > 1 ) THEN
1632
DO i=1,PVar % DOFs
1633
Vals => Var % Values( i: SIZE(Var % Values) : PVar % DOFs )
1634
tmpname = ComponentName( PVar % Name, i )
1635
CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, &
1636
tmpname, 1, Vals, Var % Perm, PVar % Output )
1637
1638
Tmp => VariableGet( Variables, tmpname, .TRUE. )
1639
NULLIFY( Tmp % PrevValues )
1640
IF ( ASSOCIATED( Var % PrevValues ) ) &
1641
Tmp % PrevValues => Var % PrevValues(i::PVar % DOFs,:)
1642
END DO
1643
END IF
1644
END IF
1645
1646
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
1647
END IF
1648
1649
IF(.NOT.ExecInterpolation) RETURN
1650
!------------------------------------------------------------------------------
1651
! Build a temporary variable list of variables to be interpolated
1652
!------------------------------------------------------------------------------
1653
ALLOCATE( Tmp )
1654
Tmp = PVar
1655
Var => Tmp
1656
NULLIFY( Var % Next )
1657
1658
IF ( PVar % Name(1:PVar % NameLen) == 'flow solution' ) THEN
1659
ALLOCATE( Var % Next )
1660
Var => Var % Next
1661
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 1' )
1662
1663
ALLOCATE( Var % Next )
1664
Var => Var % Next
1665
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 2' )
1666
1667
IF ( PVar % DOFs == 4 ) THEN
1668
ALLOCATE( Var % Next )
1669
Var => Var % Next
1670
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 3' )
1671
END IF
1672
1673
ALLOCATE( Var % Next )
1674
Var => Var % Next
1675
Var = VariableGet( PVar % PrimaryMesh % Variables, 'Pressure' )
1676
NULLIFY( Var % Next )
1677
Var => Tmp
1678
ELSE IF ( PVar % DOFs > 1 ) THEN
1679
DO i=1,PVar % DOFs
1680
ALLOCATE( Var % Next )
1681
tmpname = ComponentName( PVar % Name, i )
1682
Var % Next = VariableGet( PVar % PrimaryMesh % Variables, tmpname )
1683
Var => Var % Next
1684
END DO
1685
NULLIFY( Var % Next )
1686
Var => Tmp
1687
END IF
1688
1689
!------------------------------------------------------------------------------
1690
! interpolation call
1691
!------------------------------------------------------------------------------
1692
t1 = CPUTime()
1693
1694
UseProjector = ListGetLogical(CurrentModel % Simulation,'Use Mesh Projector',Found)
1695
IF( .NOT. Found ) UseProjector = .TRUE.
1696
1697
IF( PRESENT( MaskName ) ) THEN
1698
CALL Info('VariableGet','Performing masked on-the-fly interpolation',Level=15)
1699
CALL InterpolateMeshToMesh( PVar % PrimaryMesh, &
1700
CurrentModel % Mesh, Var, Variables, MaskName=MaskName )
1701
ELSE IF( UseProjector ) THEN
1702
CALL Info('VariableGet','Performing interpolation with projector',Level=15)
1703
CALL InterpolateMeshToMesh( PVar % PrimaryMesh, &
1704
CurrentModel % Mesh, Var, Variables, Projector=Projector )
1705
ELSE
1706
CALL Info('VariableGet','Performing on-the-fly interpolation',Level=15)
1707
AidVar => VariableGet( CurrentModel % Mesh % Variables, Name, ThisOnly = .TRUE. )
1708
IF( ASSOCIATED( AidVar ) ) THEN
1709
AidVar % Values = 0.0_dp
1710
END IF
1711
CALL InterpolateMeshToMesh( PVar % PrimaryMesh, &
1712
CurrentModel % Mesh, Var, Variables )
1713
END IF
1714
1715
IF( InfoActive( 20 ) ) THEN
1716
AidVar => VariableGet( CurrentModel % Mesh % Variables, Name, ThisOnly = .TRUE. )
1717
PRINT *,'Interpolation range:',TRIM(AidVar % Name),MINVAL(AidVar % Values),MAXVAL( AidVar % Values)
1718
END IF
1719
1720
WRITE( Message,'(A,ES12.3)' ) 'Interpolation time for > '//TRIM(Name)//' < :', CPUTime()-t1
1721
CALL Info( 'VariableGet', Message, Level=7 )
1722
1723
!------------------------------------------------------------------------------
1724
! free the temporary list
1725
!------------------------------------------------------------------------------
1726
DO WHILE( ASSOCIATED( Tmp ) )
1727
Var => Tmp % Next
1728
DEALLOCATE( Tmp )
1729
Tmp => Var
1730
END DO
1731
!------------------------------------------------------------------------------
1732
Var => VariableGet( Variables, Name, ThisOnly=.TRUE. )
1733
Var % Valid = .TRUE.
1734
Var % ValuesChanged = .TRUE.
1735
1736
IF ( Var % Name(1:Var % NameLen) == 'flow solution' ) THEN
1737
Tmp => VariableGet( Variables, 'Velocity 1', ThisOnly=.TRUE. )
1738
IF ( ASSOCIATED(Tmp) ) THEN
1739
Tmp % Valid = .TRUE.
1740
Tmp % ValuesChanged = .TRUE.
1741
END IF
1742
1743
Tmp => VariableGet( Variables, 'Velocity 2', ThisOnly=.TRUE. )
1744
IF ( ASSOCIATED(Tmp) ) THEN
1745
Tmp % Valid = .TRUE.
1746
Tmp % ValuesChanged = .TRUE.
1747
END IF
1748
1749
IF ( Var % DOFs == 4 ) THEN
1750
Tmp => VariableGet( Variables, 'Velocity 3', ThisOnly=.TRUE. )
1751
IF ( ASSOCIATED(Tmp) ) THEN
1752
Tmp % Valid = .TRUE.
1753
Tmp % ValuesChanged = .TRUE.
1754
END IF
1755
END IF
1756
1757
Tmp => VariableGet( Variables, 'Pressure', ThisOnly=.TRUE. )
1758
IF ( ASSOCIATED(Tmp) ) THEN
1759
Tmp % Valid = .TRUE.
1760
Tmp % ValuesChanged = .TRUE.
1761
END IF
1762
ELSE IF ( Var % DOFs > 1 ) THEN
1763
DO i = 1,Var % DOFs
1764
tmpname = ComponentName( Var % Name, i )
1765
Tmp => VariableGet( Variables, tmpname, ThisOnly=.TRUE. )
1766
IF ( ASSOCIATED(Tmp) ) THEN
1767
Tmp % Valid = .TRUE.
1768
Tmp % ValuesChanged = .TRUE.
1769
END IF
1770
END DO
1771
END IF
1772
!------------------------------------------------------------------------------
1773
END FUNCTION VariableGet
1774
!------------------------------------------------------------------------------
1775
1776
1777
!------------------------------------------------------------------------------
1778
FUNCTION ListHead(list) RESULT(head)
1779
!------------------------------------------------------------------------------
1780
TYPE(ValueList_t) :: List
1781
TYPE(ValueListEntry_t), POINTER :: Head
1782
!------------------------------------------------------------------------------
1783
head => List % Head
1784
!------------------------------------------------------------------------------
1785
END FUNCTION ListHead
1786
!------------------------------------------------------------------------------
1787
1788
!------------------------------------------------------------------------------
1789
FUNCTION ListEmpty(list) RESULT(l)
1790
!------------------------------------------------------------------------------
1791
LOGICAL :: L
1792
TYPE(ValueList_t) :: list
1793
!------------------------------------------------------------------------------
1794
L = .NOT.ASSOCIATED(list % head)
1795
!------------------------------------------------------------------------------
1796
END FUNCTION ListEmpty
1797
!------------------------------------------------------------------------------
1798
1799
1800
!------------------------------------------------------------------------------
1801
!> Allocates a new value list.
1802
!------------------------------------------------------------------------------
1803
FUNCTION ListAllocate() RESULT(ptr)
1804
!------------------------------------------------------------------------------
1805
TYPE(ValueList_t), POINTER :: ptr
1806
ALLOCATE( ptr )
1807
ptr % Head => Null()
1808
!------------------------------------------------------------------------------
1809
END FUNCTION ListAllocate
1810
!------------------------------------------------------------------------------
1811
1812
!------------------------------------------------------------------------------
1813
!> Allocates a new value list.
1814
!------------------------------------------------------------------------------
1815
FUNCTION ListEntryAllocate() RESULT(ptr)
1816
!------------------------------------------------------------------------------
1817
TYPE(ValueListEntry_t), POINTER :: ptr
1818
1819
ALLOCATE( ptr )
1820
ptr % PROCEDURE = 0
1821
ptr % TYPE = 0
1822
ptr % NameLen = 0
1823
ptr % LValue = .FALSE.
1824
NULLIFY( ptr % CubicCoeff )
1825
NULLIFY( ptr % Cumulative )
1826
NULLIFY( ptr % Next )
1827
NULLIFY( ptr % FValues )
1828
NULLIFY( ptr % TValues )
1829
NULLIFY( ptr % IValues )
1830
!------------------------------------------------------------------------------
1831
END FUNCTION ListEntryAllocate
1832
!------------------------------------------------------------------------------
1833
1834
1835
!------------------------------------------------------------------------------
1836
!> Deletes a value list.
1837
!------------------------------------------------------------------------------
1838
SUBROUTINE ListDelete( ptr )
1839
!------------------------------------------------------------------------------
1840
TYPE(ValueListEntry_t), POINTER :: ptr
1841
1842
IF ( ASSOCIATED(ptr % CubicCoeff) ) DEALLOCATE(ptr % CubicCoeff)
1843
IF ( ASSOCIATED(ptr % Cumulative) ) DEALLOCATE(ptr % Cumulative)
1844
IF ( ASSOCIATED(ptr % FValues) ) DEALLOCATE(ptr % FValues)
1845
IF ( ASSOCIATED(ptr % TValues) ) DEALLOCATE(ptr % TValues)
1846
IF ( ASSOCIATED(ptr % IValues) ) DEALLOCATE(ptr % IValues)
1847
DEALLOCATE( ptr )
1848
!------------------------------------------------------------------------------
1849
END SUBROUTINE ListDelete
1850
!------------------------------------------------------------------------------
1851
1852
1853
!------------------------------------------------------------------------------
1854
!> Removes an entry from the list by its name.
1855
!------------------------------------------------------------------------------
1856
SUBROUTINE ListRemove( List, Name )
1857
!------------------------------------------------------------------------------
1858
TYPE(ValueList_t) :: List
1859
CHARACTER(LEN=*) :: Name
1860
!------------------------------------------------------------------------------
1861
CHARACTER(LEN=LEN_TRIM(Name)) :: str
1862
INTEGER :: k
1863
LOGICAL :: Found
1864
TYPE(ValueListEntry_t), POINTER :: ptr, prev
1865
!------------------------------------------------------------------------------
1866
IF ( ASSOCIATED(List % Head) ) THEN
1867
k = StringToLowerCase( str,Name,.TRUE. )
1868
ptr => List % Head
1869
Prev => ptr
1870
DO WHILE( ASSOCIATED(ptr) )
1871
IF ( ptr % NameLen == k) THEN
1872
IF(ptr % Name(1:k) == str(1:k) ) THEN
1873
IF ( ASSOCIATED(ptr,List % Head) ) THEN
1874
List % Head => ptr % Next
1875
Prev => List % Head
1876
ELSE
1877
Prev % Next => ptr % Next
1878
END IF
1879
CALL ListDelete(ptr)
1880
EXIT
1881
END IF
1882
END IF
1883
Prev => ptr
1884
ptr => ptr % Next
1885
END DO
1886
END IF
1887
!------------------------------------------------------------------------------
1888
END SUBROUTINE ListRemove
1889
!------------------------------------------------------------------------------
1890
1891
1892
!------------------------------------------------------------------------------
1893
!> Adds an entry to the list by its name and returns a handle to the new entry. If the entry is
1894
!> already existing return the existing one.
1895
!------------------------------------------------------------------------------
1896
FUNCTION ListAdd( List, Name ) RESULT(NEW)
1897
!------------------------------------------------------------------------------
1898
TYPE(ValueList_t), POINTER :: List
1899
CHARACTER(LEN=*) :: Name
1900
TYPE(ValueListEntry_t), POINTER :: new
1901
!------------------------------------------------------------------------------
1902
CHARACTER(LEN=LEN_TRIM(Name)) :: str
1903
INTEGER :: k
1904
LOGICAL :: Found
1905
TYPE(ValueListEntry_t), POINTER :: ptr, prev
1906
!------------------------------------------------------------------------------
1907
Prev => NULL()
1908
Found = .FALSE.
1909
1910
IF(.NOT.ASSOCIATED(List)) List => ListAllocate()
1911
New => ListEntryAllocate()
1912
1913
IF ( ASSOCIATED(List % Head) ) THEN
1914
k = StringToLowerCase( str,Name,.TRUE. )
1915
ptr => List % Head
1916
NULLIFY( prev )
1917
DO WHILE( ASSOCIATED(ptr) )
1918
Found = ptr % NameLen == k
1919
IF(Found) Found = ptr % Name(1:k) == str(1:k)
1920
IF(Found) EXIT
1921
1922
Prev => Ptr
1923
Ptr => Ptr % Next
1924
END DO
1925
1926
IF ( Found ) THEN
1927
New % Next => ptr % Next
1928
IF ( ASSOCIATED( prev ) ) THEN
1929
Prev % Next => New
1930
ELSE
1931
List % Head => New
1932
END IF
1933
CALL ListDelete( Ptr )
1934
ELSE
1935
IF ( ASSOCIATED(prev) ) THEN
1936
prev % next => NEW
1937
ELSE
1938
NEW % Next => List % Head % Next
1939
List % Head % Next => NEW
1940
END IF
1941
END IF
1942
ELSE
1943
List % Head => NEW
1944
END IF
1945
1946
#ifdef DEVEL_LISTCOUNTER
1947
! IF( ASSOCIATED( new ) ) new % Counter = new % Counter + 1
1948
#endif
1949
1950
1951
!------------------------------------------------------------------------------
1952
END FUNCTION ListAdd
1953
!------------------------------------------------------------------------------
1954
1955
1956
!------------------------------------------------------------------------------
1957
!> Sets a namespace string that is used in all list get commands
1958
!> to check for an entry with the namespace, and then continuing to check the one without.
1959
!------------------------------------------------------------------------------
1960
SUBROUTINE ListSetNamespace(str)
1961
!------------------------------------------------------------------------------
1962
CHARACTER(LEN=*) :: str
1963
!------------------------------------------------------------------------------
1964
CHARACTER(LEN=LEN_TRIM(str)) :: str_lcase
1965
!------------------------------------------------------------------------------
1966
INTEGER :: n
1967
!------------------------------------------------------------------------------
1968
n = StringToLowerCase( str_lcase,str,.TRUE. )
1969
1970
CALL Info('ListSetNamespace','Setting namespace to: '//TRIM(str_lcase),Level=15)
1971
1972
NameSpace = str_lcase
1973
!------------------------------------------------------------------------------
1974
END SUBROUTINE ListSetNamespace
1975
!------------------------------------------------------------------------------
1976
1977
!------------------------------------------------------------------------------
1978
!> Returns the active namespace.
1979
!------------------------------------------------------------------------------
1980
FUNCTION ListGetNamespace(str) RESULT(l)
1981
!------------------------------------------------------------------------------
1982
LOGICAL :: l
1983
CHARACTER(:), ALLOCATABLE :: str
1984
!------------------------------------------------------------------------------
1985
IF (ALLOCATED(Namespace)) THEN
1986
l = .TRUE.
1987
str = Namespace
1988
ELSE
1989
l = .FALSE.
1990
END IF
1991
!------------------------------------------------------------------------------
1992
END FUNCTION ListGetNamespace
1993
!------------------------------------------------------------------------------
1994
1995
!------------------------------------------------------------------------------
1996
SUBROUTINE ListPushNamespace(str)
1997
!------------------------------------------------------------------------------
1998
CHARACTER(LEN=*) :: str
1999
!------------------------------------------------------------------------------
2000
LOGICAL :: L
2001
CHARACTER(:), ALLOCATABLE :: tstr
2002
TYPE(String_stack_t), POINTER :: stack
2003
!------------------------------------------------------------------------------
2004
2005
CALL Info('ListPushNameSpace','Adding name space: '//TRIM(str),Level=12)
2006
2007
ALLOCATE(stack)
2008
L = ListGetNameSpace(tstr)
2009
IF(ALLOCATED(tstr)) THEN
2010
stack % name = tstr
2011
ELSE
2012
stack % name = ''
2013
END IF
2014
stack % next => Namespace_stack
2015
Namespace_stack => stack
2016
CALL ListSetNamespace(str)
2017
!------------------------------------------------------------------------------
2018
END SUBROUTINE ListPushNamespace
2019
!------------------------------------------------------------------------------
2020
2021
!------------------------------------------------------------------------------
2022
SUBROUTINE ListPopNamespace( str0 )
2023
!------------------------------------------------------------------------------
2024
CHARACTER(LEN=*), OPTIONAL :: str0
2025
TYPE(String_stack_t), POINTER :: stack
2026
2027
2028
IF(ASSOCIATED(Namespace_stack)) THEN
2029
2030
! This is an optional part aimed to help to code correctly the name stack.
2031
! If one gives the namespace to be popped a Fatal will result if it is a
2032
! wrong namespace.
2033
IF( PRESENT( str0 ) ) THEN
2034
IF( str0 /= Namespace ) THEN
2035
CALL Fatal('ListPopNamespace','Wrong namespace to pop: '&
2036
//TRIM(str0)//' vs '//TRIM(Namespace))
2037
END IF
2038
END IF
2039
2040
Namespace = Namespace_stack % name
2041
2042
CALL Info('ListPopNameSpace','Deleting entry from name space: '&
2043
//TRIM(Namespace),Level=12)
2044
2045
stack => Namespace_stack
2046
Namespace_stack => stack % Next
2047
DEALLOCATE(stack)
2048
ELSE
2049
CALL Info('ListPopNameSpace','No namespace entry to delete',Level=20)
2050
END IF
2051
!------------------------------------------------------------------------------
2052
END SUBROUTINE ListPopNamespace
2053
!------------------------------------------------------------------------------
2054
2055
!------------------------------------------------------------------------------
2056
SUBROUTINE ListPushActivename(str)
2057
!------------------------------------------------------------------------------
2058
CHARACTER(LEN=*) :: str
2059
!------------------------------------------------------------------------------
2060
LOGICAL :: L
2061
TYPE(String_stack_t), POINTER :: stack
2062
!------------------------------------------------------------------------------
2063
ALLOCATE(stack)
2064
stack % name = ListGetActiveName()
2065
stack % next => Activename_stack
2066
Activename_stack => stack
2067
ActiveListName = str
2068
!------------------------------------------------------------------------------
2069
END SUBROUTINE ListPushActiveName
2070
!------------------------------------------------------------------------------
2071
2072
!------------------------------------------------------------------------------
2073
SUBROUTINE ListPopActiveName()
2074
!------------------------------------------------------------------------------
2075
TYPE(String_stack_t), POINTER :: stack
2076
!------------------------------------------------------------------------------
2077
IF(ASSOCIATED(Activename_stack)) THEN
2078
ActiveListName = Activename_stack % name
2079
stack => Activename_stack
2080
Activename_stack => stack % Next
2081
DEALLOCATE(stack)
2082
END IF
2083
!------------------------------------------------------------------------------
2084
END SUBROUTINE ListPopActiveName
2085
!------------------------------------------------------------------------------
2086
2087
!------------------------------------------------------------------------------
2088
FUNCTION ListGetActiveName() RESULT(str)
2089
!------------------------------------------------------------------------------
2090
CHARACTER(:), ALLOCATABLE :: str
2091
!------------------------------------------------------------------------------
2092
IF (ALLOCATED(ActiveListName)) THEN
2093
str = ActiveListName
2094
ELSE
2095
str = ''
2096
END IF
2097
!------------------------------------------------------------------------------
2098
END FUNCTION ListGetActiveName
2099
!------------------------------------------------------------------------------
2100
2101
!------------------------------------------------------------------------------
2102
SUBROUTINE SetNamespaceCheck(L)
2103
!------------------------------------------------------------------------------
2104
LOGICAL :: L
2105
!------------------------------------------------------------------------------
2106
DoNamespaceCheck = L
2107
!------------------------------------------------------------------------------
2108
END SUBROUTINE SetNamespaceCheck
2109
!------------------------------------------------------------------------------
2110
2111
!------------------------------------------------------------------------------
2112
FUNCTION GetNamespaceCheck() RESULT(L)
2113
!------------------------------------------------------------------------------
2114
LOGICAL :: L
2115
!------------------------------------------------------------------------------
2116
L = DoNameSpaceCheck
2117
!------------------------------------------------------------------------------
2118
END FUNCTION GetNamespaceCheck
2119
!------------------------------------------------------------------------------
2120
2121
!------------------------------------------------------------------------------
2122
!> Finds an entry in the list by its name and returns a handle to it.
2123
!------------------------------------------------------------------------------
2124
FUNCTION ListFind( list, name, Found ) RESULT(ptr)
2125
!------------------------------------------------------------------------------
2126
TYPE(ValueListEntry_t), POINTER :: ptr
2127
TYPE(ValueList_t), POINTER :: List
2128
CHARACTER(LEN=*) :: name
2129
LOGICAL, OPTIONAL :: Found
2130
!------------------------------------------------------------------------------
2131
TYPE(String_stack_t), POINTER :: stack
2132
CHARACTER(:), ALLOCATABLE :: stra
2133
CHARACTER(:), ALLOCATABLE :: strn
2134
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2135
!------------------------------------------------------------------------------
2136
INTEGER :: k, k1, n
2137
2138
IF(PRESENT(Found)) Found = .FALSE.
2139
ptr => NULL()
2140
IF(.NOT.ASSOCIATED(List)) RETURN
2141
2142
k = StringToLowerCase( str,Name,.TRUE. )
2143
2144
IF( ListGetnamespace(strn) ) THEN
2145
stack => Namespace_stack
2146
DO WHILE(.TRUE.)
2147
2148
stra = trim(strn)
2149
strn = stra //' '//str(1:k)
2150
2151
k1 = LEN(strn)
2152
ptr => List % Head
2153
DO WHILE( ASSOCIATED(ptr) )
2154
n = ptr % NameLen
2155
IF ( n==k1 ) THEN
2156
IF ( ptr % Name(1:n) == strn ) EXIT
2157
END IF
2158
ptr => ptr % Next
2159
END DO
2160
IF(.NOT.DoNamespaceCheck) EXIT
2161
2162
IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT
2163
IF(stack % name=='') EXIT
2164
strn = stack % name
2165
stack => stack % next
2166
END DO
2167
END IF
2168
2169
IF ( .NOT. ASSOCIATED(ptr) ) THEN
2170
Ptr => List % Head
2171
DO WHILE( ASSOCIATED(ptr) )
2172
n = ptr % NameLen
2173
IF ( n==k ) THEN
2174
IF ( ptr % Name(1:n) == str(1:n) ) EXIT
2175
END IF
2176
ptr => ptr % Next
2177
END DO
2178
END IF
2179
2180
#ifdef DEVEL_LISTCOUNTER
2181
IF( ASSOCIATED( ptr ) ) THEN
2182
ptr % Counter = ptr % Counter + 1
2183
END IF
2184
#endif
2185
#ifdef DEVEL_LISTUSAGE
2186
IF( ASSOCIATED( ptr ) ) THEN
2187
ptr % Counter = 1
2188
END IF
2189
#endif
2190
2191
IF ( PRESENT(Found) ) THEN
2192
Found = ASSOCIATED(ptr)
2193
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
2194
CALL Warn( 'ListFind', ' ' )
2195
WRITE(Message,*) 'Requested property: ', '[',TRIM(Name),'], not found'
2196
CALL Warn( 'ListFind', Message )
2197
CALL Warn( 'ListFind', ' ' )
2198
END IF
2199
!------------------------------------------------------------------------------
2200
END FUNCTION ListFind
2201
!------------------------------------------------------------------------------
2202
2203
2204
!------------------------------------------------------------------------------
2205
!> Finds an entry in the list by its name and returns a handle to it.
2206
!------------------------------------------------------------------------------
2207
SUBROUTINE ListRename( list, name, name2, Found )
2208
!------------------------------------------------------------------------------
2209
TYPE(ValueList_t), POINTER :: List
2210
CHARACTER(LEN=*) :: name, name2
2211
LOGICAL, OPTIONAL :: Found
2212
!------------------------------------------------------------------------------
2213
TYPE(ValueListEntry_t), POINTER :: ptr
2214
CHARACTER(:), ALLOCATABLE :: strn
2215
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2216
CHARACTER(LEN=LEN_TRIM(Name2)) :: str2
2217
INTEGER :: k, k2, n
2218
2219
IF(PRESENT(Found)) Found = .FALSE.
2220
2221
ptr => NULL()
2222
IF(.NOT.ASSOCIATED(List)) RETURN
2223
2224
k = StringToLowerCase( str,Name,.TRUE. )
2225
2226
Ptr => List % Head
2227
DO WHILE( ASSOCIATED(ptr) )
2228
n = ptr % NameLen
2229
IF ( n==k ) THEN
2230
IF ( ptr % Name(1:n) == str(1:n) ) EXIT
2231
END IF
2232
ptr => ptr % Next
2233
END DO
2234
2235
IF( ASSOCIATED( ptr ) ) THEN
2236
k2 = StringToLowerCase( str2,Name2,.TRUE. )
2237
ptr % Name = str2(1:k2)
2238
ptr % NameLen = k2
2239
!PRINT *,'renaming >'//str(1:k)//'< to >'//str2(1:k2)//'<', k, k2
2240
END IF
2241
2242
IF ( PRESENT(Found) ) THEN
2243
Found = ASSOCIATED(ptr)
2244
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
2245
CALL Warn( 'ListRename', ' ' )
2246
WRITE(Message,*) 'Requested property: ', '[',TRIM(Name),'], not found'
2247
CALL Warn( 'ListRename', Message )
2248
CALL Warn( 'ListRename', ' ' )
2249
END IF
2250
!------------------------------------------------------------------------------
2251
END SUBROUTINE ListRename
2252
!------------------------------------------------------------------------------
2253
2254
2255
!------------------------------------------------------------------------------
2256
!> Rename all given keywords in BC section.
2257
!------------------------------------------------------------------------------
2258
SUBROUTINE ListRenameAllBC( Model, Name, Name2 )
2259
!------------------------------------------------------------------------------
2260
TYPE(Model_t) :: Model
2261
CHARACTER(LEN=*) :: Name, Name2
2262
LOGICAL :: Found
2263
INTEGER :: bc, n
2264
2265
n = 0
2266
DO bc = 1,Model % NumberOfBCs
2267
CALL ListRename( Model % BCs(bc) % Values, Name, Name2, Found )
2268
IF( Found ) n = n + 1
2269
END DO
2270
IF( n > 0 ) CALL Info('ListRenameAllBCs',&
2271
'"'//TRIM(Name)//'" renamed to "'//TRIM(Name2)//'" on '//I2S(n)//' BCs',Level=6)
2272
2273
!------------------------------------------------------------------------------
2274
END SUBROUTINE ListRenameAllBC
2275
!------------------------------------------------------------------------------
2276
2277
!------------------------------------------------------------------------------
2278
!> Rename all given keywords in body force section.
2279
!------------------------------------------------------------------------------
2280
SUBROUTINE ListRenameAllBodyForce( Model, Name, Name2 )
2281
!------------------------------------------------------------------------------
2282
TYPE(Model_t) :: Model
2283
CHARACTER(LEN=*) :: Name, Name2
2284
LOGICAL :: Found
2285
INTEGER :: bc, n
2286
2287
n = 0
2288
DO bc = 1,Model % NumberOfBodyForces
2289
CALL ListRename( Model % BodyForces(bc) % Values, Name, Name2, Found )
2290
IF( Found ) n = n + 1
2291
END DO
2292
IF( n > 0 ) CALL Info('ListRenameAllBodyForces',&
2293
'"'//TRIM(Name)//'" renamed to "'//TRIM(Name2)//'" on '//I2S(n)//' BCs',Level=6)
2294
2295
!------------------------------------------------------------------------------
2296
END SUBROUTINE ListRenameAllBodyForce
2297
!------------------------------------------------------------------------------
2298
2299
2300
!------------------------------------------------------------------------------
2301
!> Just checks if a entry is present in the list.
2302
!------------------------------------------------------------------------------
2303
FUNCTION ListCheckPresent( List,Name ) RESULT(Found)
2304
!------------------------------------------------------------------------------
2305
TYPE(ValueList_t), POINTER :: List
2306
CHARACTER(LEN=*) :: Name
2307
LOGICAL :: Found
2308
!------------------------------------------------------------------------------
2309
TYPE(ValueListEntry_t), POINTER :: ptr
2310
!------------------------------------------------------------------------------
2311
ptr => ListFind(List,Name,Found)
2312
!------------------------------------------------------------------------------
2313
END FUNCTION ListCheckPresent
2314
!------------------------------------------------------------------------------
2315
2316
2317
!-----------------------------------------------------------------------------
2318
!> Finds an entry in the list by its name and returns a handle to it.
2319
!> This one just finds a keyword with the same start as specified by 'name'.
2320
!------------------------------------------------------------------------------
2321
FUNCTION ListFindPrefix( list, name, Found) RESULT(ptr)
2322
!------------------------------------------------------------------------------
2323
TYPE(ValueListEntry_t), POINTER :: ptr
2324
TYPE(ValueList_t), POINTER :: list
2325
CHARACTER(LEN=*) :: name
2326
LOGICAL, OPTIONAL :: Found
2327
!------------------------------------------------------------------------------
2328
TYPE(String_stack_t), POINTER :: stack
2329
CHARACTER(:), ALLOCATABLE :: strn,stra
2330
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2331
!------------------------------------------------------------------------------
2332
INTEGER :: k, k1, n, m
2333
2334
ptr => NULL()
2335
IF(.NOT.ASSOCIATED(List)) RETURN
2336
2337
k = StringToLowerCase( str,Name,.TRUE. )
2338
IF ( ListGetNamespace(strn) ) THEN
2339
stack => Namespace_stack
2340
DO WHILE(.TRUE.)
2341
stra = trim(strn)
2342
strn = stra //' '//str(1:k)
2343
2344
k1 = LEN(strn)
2345
ptr => List % Head
2346
DO WHILE( ASSOCIATED(ptr) )
2347
n = ptr % NameLen
2348
IF ( n >= k1 ) THEN
2349
IF ( ptr % Name(1:k1) == strn ) EXIT
2350
END IF
2351
ptr => ptr % Next
2352
END DO
2353
IF(.NOT.DoNamespaceCheck) EXIT
2354
2355
IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT
2356
IF(stack % name=='') EXIT
2357
strn = stack % name
2358
stack => stack % next
2359
END DO
2360
END IF
2361
2362
IF ( .NOT. ASSOCIATED(ptr) ) THEN
2363
Ptr => List % Head
2364
DO WHILE( ASSOCIATED(ptr) )
2365
n = ptr % NameLen
2366
IF ( n >= k ) THEN
2367
IF ( ptr % Name(1:k) == str(1:k) ) EXIT
2368
END IF
2369
ptr => ptr % Next
2370
END DO
2371
END IF
2372
2373
IF ( PRESENT(Found) ) THEN
2374
Found = ASSOCIATED(ptr)
2375
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
2376
CALL Warn( 'ListFindPrefix', ' ' )
2377
WRITE(Message,*) 'Requested prefix: ', '[',TRIM(Name),'], not found'
2378
CALL Warn( 'ListFindPrefix', Message )
2379
CALL Warn( 'ListFindPrefix', ' ' )
2380
END IF
2381
!------------------------------------------------------------------------------
2382
END FUNCTION ListFindPrefix
2383
!------------------------------------------------------------------------------
2384
2385
2386
!------------------------------------------------------------------------------
2387
!> Finds an entry in the list by its name and returns a handle to it.
2388
!> This one just finds a keyword with the same end as specified by 'name'.
2389
!------------------------------------------------------------------------------
2390
FUNCTION ListFindSuffix( list, name, Found) RESULT(ptr)
2391
!------------------------------------------------------------------------------
2392
TYPE(ValueListEntry_t), POINTER :: ptr
2393
TYPE(ValueList_t), POINTER :: list
2394
CHARACTER(LEN=*) :: name
2395
LOGICAL, OPTIONAL :: Found
2396
!------------------------------------------------------------------------------
2397
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2398
!------------------------------------------------------------------------------
2399
INTEGER :: k, k1, n, m
2400
2401
ptr => Null()
2402
IF(.NOT.ASSOCIATED(List)) RETURN
2403
2404
k = StringToLowerCase( str,Name,.TRUE. )
2405
Ptr => List % Head
2406
DO WHILE( ASSOCIATED(ptr) )
2407
n = ptr % NameLen
2408
IF ( n >= k ) THEN
2409
IF ( ptr % Name(n-k+1:n) == str(1:k) ) EXIT
2410
END IF
2411
ptr => ptr % Next
2412
END DO
2413
2414
IF ( PRESENT(Found) ) THEN
2415
Found = ASSOCIATED(ptr)
2416
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
2417
CALL Warn( 'ListFindSuffix', ' ' )
2418
WRITE(Message,*) 'Requested suffix: ', '[',TRIM(Name),'], not found'
2419
CALL Warn( 'ListFindSuffix', Message )
2420
CALL Warn( 'ListFindSuffix', ' ' )
2421
END IF
2422
!------------------------------------------------------------------------------
2423
END FUNCTION ListFindSuffix
2424
!------------------------------------------------------------------------------
2425
2426
2427
2428
!------------------------------------------------------------------------------
2429
!> Check if the suffix exists in the list.
2430
!------------------------------------------------------------------------------
2431
FUNCTION ListCheckSuffix( List, Name ) RESULT(Found)
2432
!------------------------------------------------------------------------------
2433
TYPE(ValueList_t), POINTER :: List
2434
CHARACTER(LEN=*) :: Name
2435
LOGICAL :: Found
2436
TYPE(ValuelistEntry_t), POINTER :: ptr
2437
2438
ptr => ListFindSuffix( List, Name, Found )
2439
!------------------------------------------------------------------------------
2440
END FUNCTION ListCheckSuffix
2441
!------------------------------------------------------------------------------
2442
2443
2444
!------------------------------------------------------------------------------
2445
!> Check if the keyword is with the given suffix is present in any boundary condition.
2446
!------------------------------------------------------------------------------
2447
FUNCTION ListCheckSuffixAnyBC( Model, Name ) RESULT(Found)
2448
!------------------------------------------------------------------------------
2449
TYPE(Model_t) :: Model
2450
CHARACTER(LEN=*) :: Name
2451
LOGICAL :: Found
2452
INTEGER :: bc
2453
TYPE(ValuelistEntry_t), POINTER :: ptr
2454
2455
Found = .FALSE.
2456
DO bc = 1,Model % NumberOfBCs
2457
ptr => ListFindSuffix( Model % BCs(bc) % Values, Name, Found )
2458
IF( Found ) EXIT
2459
END DO
2460
!------------------------------------------------------------------------------
2461
END FUNCTION ListCheckSuffixAnyBC
2462
!------------------------------------------------------------------------------
2463
2464
!------------------------------------------------------------------------------
2465
!> Check if the keyword is with the given suffix is present in any body.
2466
!------------------------------------------------------------------------------
2467
FUNCTION ListCheckSuffixAnyBody( Model, Name ) RESULT(Found)
2468
!------------------------------------------------------------------------------
2469
TYPE(Model_t) :: Model
2470
CHARACTER(LEN=*) :: Name
2471
LOGICAL :: Found
2472
INTEGER :: body_id
2473
TYPE(ValuelistEntry_t), POINTER :: ptr
2474
2475
Found = .FALSE.
2476
DO body_id = 1,Model % NumberOfBodies
2477
ptr => ListFindSuffix( Model % Bodies(body_id) % Values, Name, Found )
2478
IF( Found ) EXIT
2479
END DO
2480
!------------------------------------------------------------------------------
2481
END FUNCTION ListCheckSuffixAnyBody
2482
!------------------------------------------------------------------------------
2483
2484
!------------------------------------------------------------------------------
2485
!> Check if the keyword is with the given suffix is present in any material.
2486
!------------------------------------------------------------------------------
2487
FUNCTION ListCheckSuffixAnyMaterial( Model, Name ) RESULT(Found)
2488
!------------------------------------------------------------------------------
2489
TYPE(Model_t) :: Model
2490
CHARACTER(LEN=*) :: Name
2491
LOGICAL :: Found
2492
INTEGER :: mat_id
2493
TYPE(ValuelistEntry_t), POINTER :: ptr
2494
2495
Found = .FALSE.
2496
DO mat_id = 1,Model % NumberOfMaterials
2497
ptr => ListFindSuffix( Model % Materials(mat_id) % Values, Name, Found )
2498
IF( Found ) EXIT
2499
END DO
2500
!------------------------------------------------------------------------------
2501
END FUNCTION ListCheckSuffixAnyMaterial
2502
!------------------------------------------------------------------------------
2503
2504
!------------------------------------------------------------------------------
2505
!> Check if the keyword is with the given suffix is present in any body force.
2506
!------------------------------------------------------------------------------
2507
FUNCTION ListCheckSuffixAnyBodyForce( Model, Name ) RESULT(Found)
2508
!------------------------------------------------------------------------------
2509
TYPE(Model_t) :: Model
2510
CHARACTER(LEN=*) :: Name
2511
LOGICAL :: Found
2512
INTEGER :: bf_id
2513
TYPE(ValuelistEntry_t), POINTER :: ptr
2514
2515
Found = .FALSE.
2516
DO bf_id = 1,Model % NumberOfBodyForces
2517
ptr => ListFindSuffix( Model % BodyForces(bf_id) % Values, Name, Found )
2518
IF( Found ) EXIT
2519
END DO
2520
!------------------------------------------------------------------------------
2521
END FUNCTION ListCheckSuffixAnyBodyForce
2522
!------------------------------------------------------------------------------
2523
2524
2525
!------------------------------------------------------------------------------
2526
!> Finds an entry related to vector keyword of type "name" or "name i", i=1,2,3.
2527
!> This could save time since it will detect at one sweep whether the keyword
2528
!> for a vector is given, and whether it is componentwise or not.
2529
!> There is a caveat since currently the "i" is not checked and possibly
2530
!> the user could mix the formats and the chosen one would be random.
2531
!------------------------------------------------------------------------------
2532
FUNCTION ListFindVectorPrefix( list, name, ComponentWise,Found ) RESULT(ptr)
2533
!------------------------------------------------------------------------------
2534
TYPE(ValueListEntry_t), POINTER :: ptr
2535
TYPE(ValueList_t), POINTER :: list
2536
CHARACTER(LEN=*) :: name
2537
LOGICAL :: ComponentWise
2538
LOGICAL, OPTIONAL :: Found
2539
!------------------------------------------------------------------------------
2540
TYPE(String_stack_t), POINTER :: stack
2541
CHARACTER(:), ALLOCATABLE :: strn
2542
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2543
!------------------------------------------------------------------------------
2544
INTEGER :: k, k1, n, m
2545
2546
ptr => NULL()
2547
IF(.NOT.ASSOCIATED(List)) RETURN
2548
2549
k = StringToLowerCase( str,Name,.TRUE. )
2550
2551
IF ( ListGetNamespace(strn) ) THEN
2552
stack => Namespace_stack
2553
DO WHILE(.TRUE.)
2554
strn = TRIM(strn) //' '//str(1:k)
2555
k1 = LEN(strn)
2556
ptr => List % Head
2557
DO WHILE( ASSOCIATED(ptr) )
2558
n = ptr % NameLen
2559
IF ( n == k1 ) THEN
2560
IF ( ptr % Name(1:k1) == strn ) THEN
2561
ComponentWise = .FALSE.
2562
EXIT
2563
END IF
2564
ELSE IF( n == k1 + 2 ) THEN
2565
IF ( ptr % Name(1:k1+1) == strn//' ' ) THEN
2566
ComponentWise = .TRUE.
2567
EXIT
2568
END IF
2569
END IF
2570
ptr => ptr % Next
2571
END DO
2572
IF(.NOT.DoNamespaceCheck) EXIT
2573
2574
IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT
2575
IF(stack % name=='') EXIT
2576
strn = stack % name
2577
stack => stack % next
2578
END DO
2579
END IF
2580
2581
IF ( .NOT. ASSOCIATED(ptr) ) THEN
2582
Ptr => List % Head
2583
DO WHILE( ASSOCIATED(ptr) )
2584
n = ptr % NameLen
2585
IF ( n == k ) THEN
2586
IF ( ptr % Name(1:k) == str(1:k) ) THEN
2587
ComponentWise = .FALSE.
2588
EXIT
2589
END IF
2590
ELSE IF( n == k + 2 ) THEN
2591
IF ( ptr % Name(1:k+1) == str(1:k)//' ' ) THEN
2592
ComponentWise = .TRUE.
2593
EXIT
2594
END IF
2595
END IF
2596
ptr => ptr % Next
2597
END DO
2598
END IF
2599
2600
IF ( PRESENT(Found) ) THEN
2601
Found = ASSOCIATED(ptr)
2602
ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN
2603
CALL Warn( 'ListFindVectorPrefix', ' ' )
2604
WRITE(Message,*) 'Requested vector prefix: ', '[',TRIM(Name),'], not found'
2605
CALL Warn( 'ListFindVectorPrefix', Message )
2606
CALL Warn( 'ListFindVectorPrefix', ' ' )
2607
END IF
2608
!------------------------------------------------------------------------------
2609
END FUNCTION ListFindVectorPrefix
2610
!------------------------------------------------------------------------------
2611
2612
2613
2614
!------------------------------------------------------------------------------
2615
!> Finds a keyword with the given basename and normalizes it with a
2616
!> constant coefficients for all future request of the keyword.
2617
!------------------------------------------------------------------------------
2618
SUBROUTINE ListSetCoefficients( list, name, coeff )
2619
!------------------------------------------------------------------------------
2620
TYPE(ValueList_t), POINTER :: list
2621
CHARACTER(LEN=*) :: name
2622
REAL(KIND=dp) :: coeff
2623
!------------------------------------------------------------------------------
2624
TYPE(ValueListEntry_t), POINTER :: ptr, ptr2
2625
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2626
INTEGER :: k, k1, n, n2, m
2627
2628
IF(.NOT.ASSOCIATED(List)) RETURN
2629
2630
k = StringToLowerCase( str,Name,.TRUE. )
2631
2632
Ptr => list % Head
2633
DO WHILE( ASSOCIATED(ptr) )
2634
IF( ptr % disttag ) THEN
2635
WRITE( Message,'(A,ES12.5)') 'Normalizing > '//&
2636
TRIM( ptr2 % Name )// ' < by ',Coeff
2637
CALL Info('ListSetCoefficients',Message,Level=7)
2638
ptr % Coeff = Coeff
2639
ptr => ptr % Next
2640
CYCLE
2641
END IF
2642
2643
n = ptr % NameLen
2644
IF ( n >= k ) THEN
2645
! Did we find a keyword which has the correct suffix?
2646
IF ( ptr % Name(n-k+1:n) == str(1:k) ) THEN
2647
Ptr2 => list % Head
2648
DO WHILE( ASSOCIATED(ptr2) )
2649
n2 = ptr2 % NameLen
2650
IF( n2 + k <= n ) THEN
2651
2652
! Did we find the corresponding keyword without the suffix?
2653
IF ( ptr2 % Name(1:n2) == ptr % Name(1:n2) ) THEN
2654
WRITE( Message,'(A,ES12.5)') 'Normalizing > '//&
2655
TRIM( ptr2 % Name )// ' < by ',Coeff
2656
CALL Info('ListSetCoefficients',Message,Level=7)
2657
ptr2 % Coeff = Coeff
2658
EXIT
2659
END IF
2660
2661
END IF
2662
ptr2 => ptr2 % Next
2663
END DO
2664
END IF
2665
END IF
2666
ptr => ptr % Next
2667
END DO
2668
!------------------------------------------------------------------------------
2669
END SUBROUTINE ListSetCoefficients
2670
!------------------------------------------------------------------------------
2671
2672
2673
!------------------------------------------------------------------------------
2674
!> Add a parameter tag to an existing keyword. By construction we know this
2675
!> should exist.
2676
!------------------------------------------------------------------------------
2677
SUBROUTINE ListParTagKeyword( List,Name,partag )
2678
!------------------------------------------------------------------------------
2679
TYPE(ValueList_t), POINTER :: List
2680
CHARACTER(LEN=*) :: Name
2681
INTEGER :: partag
2682
!------------------------------------------------------------------------------
2683
TYPE(ValueListEntry_t), POINTER :: ptr
2684
LOGICAL :: Found
2685
!------------------------------------------------------------------------------
2686
ptr => ListFind( List, Name, Found )
2687
IF(.NOT. Found) THEN
2688
CALL Fatal('ListParTagKeyword','Cannot add tag to non-existing keyword: '//TRIM(Name))
2689
END IF
2690
Ptr % partag = partag
2691
2692
END SUBROUTINE ListParTagKeyword
2693
!------------------------------------------------------------------------------
2694
2695
2696
!------------------------------------------------------------------------------
2697
!> Add tag to distribute value of existing keyword.
2698
!------------------------------------------------------------------------------
2699
SUBROUTINE ListDistTagKeyword( List,Name )
2700
!------------------------------------------------------------------------------
2701
TYPE(ValueList_t), POINTER :: List
2702
CHARACTER(LEN=*) :: Name
2703
!------------------------------------------------------------------------------
2704
TYPE(ValueListEntry_t), POINTER :: ptr
2705
LOGICAL :: Found
2706
!------------------------------------------------------------------------------
2707
ptr => ListFind( List, Name, Found )
2708
IF(.NOT. Found) THEN
2709
CALL Fatal('ListDistTagKeyword','Cannot add tag to non-existing keyword: '//TRIM(Name))
2710
END IF
2711
Ptr % disttag = .TRUE.
2712
2713
END SUBROUTINE ListDistTagKeyword
2714
!------------------------------------------------------------------------------
2715
2716
2717
!----------------------------------------------------------------
2718
!> Given a suffix tag keyword that have the keyword without the
2719
!> suffix. If the "tagwei" flag is True set the tag related to the
2720
!> weight computation, if it is False set integer tag related to parameter
2721
!> control.
2722
!----------------------------------------------------------------
2723
SUBROUTINE ListTagKeywords( Model, suffix, tagwei, Found )
2724
!----------------------------------------------------------------
2725
TYPE(Model_t) :: Model
2726
CHARACTER(LEN=*) :: suffix
2727
LOGICAL :: tagwei
2728
LOGICAL :: Found
2729
!----------------------------------------------------------------
2730
INTEGER :: i,cnt
2731
2732
CALL Info('ListTagKeywords','Setting weight for keywords!',Level=20)
2733
cnt = 0
2734
2735
CALL ListTagEntry(Model % Simulation, suffix, tagwei, cnt )
2736
CALL ListTagEntry(Model % Constants, suffix, tagwei, cnt )
2737
DO i=1,Model % NumberOfEquations
2738
CALL ListTagEntry(Model % Equations(i) % Values, suffix, tagwei, cnt )
2739
END DO
2740
DO i=1,Model % NumberOfComponents
2741
CALL ListTagEntry(Model % Components(i) % Values, suffix, tagwei, cnt )
2742
END DO
2743
DO i=1,Model % NumberOfBodyForces
2744
CALL ListTagEntry(Model % BodyForces(i) % Values, suffix, tagwei, cnt )
2745
END DO
2746
DO i=1,Model % NumberOfICs
2747
CALL ListTagEntry(Model % ICs(i) % Values, suffix, tagwei, cnt )
2748
END DO
2749
DO i=1,Model % NumberOfBCs
2750
CALL ListTagEntry(Model % BCs(i) % Values, suffix, tagwei, cnt )
2751
END DO
2752
DO i=1,Model % NumberOfMaterials
2753
CALL ListTagEntry(Model % Materials(i) % Values, suffix, tagwei, cnt )
2754
END DO
2755
DO i=1,Model % NumberOfBoundaries
2756
CALL ListTagEntry(Model % Boundaries(i) % Values, suffix, tagwei, cnt )
2757
END DO
2758
DO i=1,Model % NumberOfSolvers
2759
CALL ListTagEntry(Model % Solvers(i) % Values, suffix, tagwei, cnt )
2760
END DO
2761
2762
Found = ( cnt > 0 )
2763
2764
IF( Found ) THEN
2765
CALL Info('ListTagKeywords',&
2766
'Tagged '//I2S(cnt)//' parameters with suffix: '//TRIM(suffix),Level=7)
2767
ELSE
2768
CALL Info('ListTagKeywords','No parameters width suffix: '//TRIM(suffix),Level=20)
2769
END IF
2770
2771
CONTAINS
2772
2773
!------------------------------------------------------------------------------
2774
SUBROUTINE ListTagEntry( list, name, tagwei, cnt )
2775
!------------------------------------------------------------------------------
2776
TYPE(ValueList_t), POINTER :: list
2777
CHARACTER(LEN=*) :: name
2778
LOGICAL :: tagwei
2779
INTEGER :: cnt
2780
!------------------------------------------------------------------------------
2781
TYPE(ValueListEntry_t), POINTER :: ptr, ptr2
2782
CHARACTER(LEN=LEN_TRIM(Name)) :: str
2783
INTEGER :: k, k1, n, n2, m, partag
2784
2785
IF(.NOT.ASSOCIATED(List)) RETURN
2786
2787
m = 0
2788
k = StringToLowerCase( str,Name,.TRUE. )
2789
2790
Ptr => list % Head
2791
DO WHILE( ASSOCIATED(ptr) )
2792
n = ptr % NameLen
2793
IF ( n >= k ) THEN
2794
! Did we find a keyword which has the correct suffix?
2795
IF ( ptr % Name(n-k+1:n) == str(1:k) ) THEN
2796
Ptr2 => list % Head
2797
DO WHILE( ASSOCIATED(ptr2) )
2798
n2 = ptr2 % NameLen
2799
IF( n2 + k <= n ) THEN
2800
! Did we find the corresponding keyword without the suffix?
2801
IF ( ptr2 % Name(1:n2) == ptr % Name(1:n2) ) THEN
2802
IF( tagwei ) THEN
2803
ptr2 % disttag = ptr % Lvalue
2804
m = m + 1
2805
WRITE( Message,'(A)') 'Adding dist tag to "'//TRIM( ptr2 % Name )//'"'
2806
CALL Info('ListTagKeywords',Message,Level=15)
2807
ELSE
2808
partag = ptr % IValues(1)
2809
IF(partag<1) THEN
2810
CALL Warn('ListTagKeywords','Positive integer expected for parameter tag!')
2811
ELSE
2812
WRITE( Message,'(A)') 'Adding tag '//I2S(partag)//&
2813
' to "'//TRIM( ptr2 % Name )//'"'
2814
CALL Info('ListTagKeywords',Message,Level=15)
2815
ptr2 % partag = partag
2816
m = m + 1
2817
END IF
2818
END IF
2819
END IF
2820
END IF
2821
ptr2 => ptr2 % Next
2822
END DO
2823
END IF
2824
END IF
2825
ptr => ptr % Next
2826
END DO
2827
2828
IF( m > 0 ) THEN
2829
CALL Info('ListTagKeywords',&
2830
'Tagged '//I2S(m)//' parameters in list',Level=15)
2831
END IF
2832
cnt = cnt + m
2833
2834
END SUBROUTINE ListTagEntry
2835
2836
END SUBROUTINE ListTagKeywords
2837
2838
2839
2840
!----------------------------------------------------------------
2841
!> Given a suffix tag keyword that have the keyword without the
2842
!> suffix. If the "tagwei" flag is True set the tag related to the
2843
!> weight computation, if it is False set tag related to parameter
2844
!> control.
2845
!----------------------------------------------------------------
2846
FUNCTION ListTagCount( Model, tagwei ) RESULT ( cnt )
2847
!----------------------------------------------------------------
2848
TYPE(Model_t) :: Model
2849
LOGICAL :: tagwei
2850
INTEGER :: cnt
2851
!----------------------------------------------------------------
2852
INTEGER :: i
2853
2854
IF( tagwei ) THEN
2855
CALL Info('ListTagCount','Counting tags for keyword normalization!',Level=12)
2856
ELSE
2857
CALL Info('ListTagCount','Counting tags for keyword variation!',Level=12)
2858
END IF
2859
2860
! Only the following lists have been created for weights.
2861
! We could add more, but only lists that have elements associated to them.
2862
cnt = 0
2863
DO i=1,Model % NumberOfBCs
2864
CALL ListTagCnt(Model % BCs(i) % Values, tagwei, cnt )
2865
END DO
2866
DO i=1,Model % NumberOfMaterials
2867
CALL ListTagCnt(Model % Materials(i) % Values, tagwei, cnt )
2868
END DO
2869
DO i=1,Model % NumberOfBodyForces
2870
CALL ListTagCnt(Model % BodyForces(i) % Values, tagwei, cnt )
2871
END DO
2872
DO i=1,Model % NumberOfBodies
2873
CALL ListTagCnt(Model % Bodies(i) % Values, tagwei, cnt )
2874
END DO
2875
IF(tagwei) THEN
2876
IF(cnt>0) CALL Info('ListTagCount','Found number of normalized keywords: '//I2S(cnt),Level=6)
2877
RETURN
2878
END IF
2879
2880
CALL ListTagCnt(Model % Simulation, tagwei, cnt )
2881
CALL ListTagCnt(Model % Constants, tagwei, cnt )
2882
DO i=1,Model % NumberOfEquations
2883
CALL ListTagCnt(Model % Equations(i) % Values, tagwei, cnt )
2884
END DO
2885
DO i=1,Model % NumberOfComponents
2886
CALL ListTagCnt(Model % Components(i) % Values, tagwei, cnt )
2887
END DO
2888
DO i=1,Model % NumberOfICs
2889
CALL ListTagCnt(Model % ICs(i) % Values, tagwei, cnt )
2890
END DO
2891
DO i=1,Model % NumberOfBoundaries
2892
CALL ListTagCnt(Model % Boundaries(i) % Values, tagwei, cnt )
2893
END DO
2894
DO i=1,Model % NumberOfSolvers
2895
CALL ListTagCnt(Model % Solvers(i) % Values, tagwei, cnt )
2896
END DO
2897
2898
IF(cnt>0) CALL Info('ListTagCount','Found number of parameters: '//I2S(cnt),Level=6)
2899
2900
CONTAINS
2901
2902
!------------------------------------------------------------------------------
2903
SUBROUTINE ListTagCnt( list, tagwei, cnt )
2904
!------------------------------------------------------------------------------
2905
TYPE(ValueList_t), POINTER :: list
2906
LOGICAL :: tagwei
2907
INTEGER :: cnt
2908
!------------------------------------------------------------------------------
2909
TYPE(ValueListEntry_t), POINTER :: ptr
2910
INTEGER :: m
2911
2912
IF(.NOT.ASSOCIATED(List)) RETURN
2913
2914
m = 0
2915
2916
Ptr => list % Head
2917
DO WHILE( ASSOCIATED(ptr) )
2918
IF( tagwei ) THEN
2919
IF( ptr % disttag ) m = m + 1
2920
ELSE
2921
IF( ptr % partag > 0 ) m = m + 1
2922
END IF
2923
ptr => ptr % Next
2924
END DO
2925
2926
IF( m > 0 ) THEN
2927
CALL Info('ListTagParameters',&
2928
'Tagged number of parameters in list: '//I2S(m),Level=15)
2929
END IF
2930
cnt = cnt + m
2931
2932
END SUBROUTINE ListTagCnt
2933
2934
END FUNCTION ListTagCount
2935
2936
2937
!----------------------------------------------------------------
2938
!> Given any real keyword that is tagged to be a design parameter
2939
!> multiply it with the given coefficient. This assumes that the
2940
!> List operatiorsn use the "coeff" field to scale the real valued
2941
!> keywords. The intended use for this is to make it easier to
2942
!> variations for optimization, control and sensitivity analysis.
2943
!----------------------------------------------------------------
2944
SUBROUTINE ListSetParameters( Model, partag, val, mult, Found )
2945
!----------------------------------------------------------------
2946
TYPE(Model_t) :: Model
2947
INTEGER :: partag
2948
REAL(KIND=dp) :: val
2949
LOGICAL :: mult
2950
LOGICAL :: Found
2951
!----------------------------------------------------------------
2952
INTEGER :: i,cnt
2953
TYPE(Mesh_t), POINTER :: Mesh
2954
REAL(KIND=dp), POINTER :: Weights(:)
2955
2956
CALL Info('ListSetParameters',&
2957
'Setting variation to parameter: '//I2S(partag),Level=12)
2958
cnt = 0
2959
2960
Weights => NULL()
2961
Mesh => Model % Mesh
2962
2963
DO i=1,Model % NumberOfBodies
2964
Weights => Mesh % BodyWeight
2965
CALL ListSetTagged(Model % Bodies(i) % Values, partag, val, mult, cnt )
2966
END DO
2967
DO i=1,Model % NumberOfBodyForces
2968
Weights => Mesh % BodyForceWeight
2969
CALL ListSetTagged(Model % BodyForces(i) % Values, partag, val, mult, cnt )
2970
END DO
2971
DO i=1,Model % NumberOfBCs
2972
Weights => Mesh % BCWeight
2973
CALL ListSetTagged(Model % BCs(i) % Values, partag, val, mult, cnt )
2974
END DO
2975
DO i=1,Model % NumberOfMaterials
2976
Weights => Mesh % MaterialWeight
2977
CALL ListSetTagged(Model % Materials(i) % Values, partag, val, mult, cnt )
2978
END DO
2979
2980
IF( partag > 0 ) THEN
2981
CALL ListSetTagged(Model % Simulation, partag, val, mult, cnt )
2982
CALL ListSetTagged(Model % Constants, partag, val, mult, cnt )
2983
DO i=1,Model % NumberOfEquations
2984
CALL ListSetTagged(Model % Equations(i) % Values, partag, val, mult, cnt )
2985
END DO
2986
DO i=1,Model % NumberOfComponents
2987
CALL ListSetTagged(Model % Components(i) % Values, partag, val, mult, cnt )
2988
END DO
2989
DO i=1,Model % NumberOfICs
2990
CALL ListSetTagged(Model % ICs(i) % Values, partag, val, mult, cnt )
2991
END DO
2992
DO i=1,Model % NumberOfBoundaries
2993
CALL ListSetTagged(Model % Boundaries(i) % Values, partag, val, mult, cnt )
2994
END DO
2995
DO i=1,Model % NumberOfSolvers
2996
CALL ListSetTagged(Model % Solvers(i) % Values, partag, val, mult, cnt )
2997
END DO
2998
END IF
2999
3000
10 Found = ( cnt > 0 )
3001
3002
IF( Found ) THEN
3003
CALL Info('ListSetParameters',&
3004
'Scaled number of parameters: '//I2S(cnt),Level=6)
3005
ELSE
3006
CALL Warn('ListSetParameters','No parameters were altered!')
3007
END IF
3008
3009
CONTAINS
3010
3011
SUBROUTINE ListSetTagged(list, partag, val, mult, cnt)
3012
TYPE(ValueList_t), POINTER :: list
3013
INTEGER :: partag
3014
REAL(KIND=dp) :: val
3015
LOGICAL :: mult
3016
INTEGER :: cnt
3017
3018
TYPE(ValueListEntry_t), POINTER :: ptr
3019
3020
IF(.NOT.ASSOCIATED(List)) RETURN
3021
3022
ptr => List % Head
3023
DO WHILE( ASSOCIATED(ptr) )
3024
IF( partag == 0 ) THEN
3025
IF( ptr % disttag ) THEN
3026
IF(ASSOCIATED(Weights)) THEN
3027
IF( Weights(i) > TINY(Weights(i)) ) THEN
3028
ptr % coeff = 1.0_dp / Weights(i)
3029
cnt = cnt + 1
3030
WRITE( Message,'(A,ES12.3)') 'Scaling parameter "'//TRIM(ptr % name)//'" with:',ptr % coeff
3031
CALL Info('ListSetParameters',Message,Level=15)
3032
ELSE
3033
CALL Warn('ListSetParameters','Refusing division with zero!')
3034
END IF
3035
END IF
3036
END IF
3037
ELSE IF(partag == ptr % partag ) THEN
3038
IF( mult ) THEN
3039
ptr % coeff = val * ptr % coeff
3040
ELSE
3041
ptr % coeff = val
3042
END IF
3043
cnt = cnt + 1
3044
END IF
3045
ptr => ptr % Next
3046
END DO
3047
END SUBROUTINE ListSetTagged
3048
3049
END SUBROUTINE ListSetParameters
3050
!-----------------------------------------------------------------------------------
3051
3052
3053
!----------------------------------------------------------------
3054
!> Echo parameters for debugging purposes.
3055
!> For now only supports constants...
3056
!----------------------------------------------------------------
3057
SUBROUTINE ListEchoKeywords( Model )
3058
!----------------------------------------------------------------
3059
TYPE(Model_t) :: Model
3060
!----------------------------------------------------------------
3061
INTEGER :: i,cnt
3062
3063
CALL Info('ListEchoKeywords','Echoing parameters for debgging purposes')
3064
3065
CALL EchoList(Model % Simulation, 0, 'simulation' )
3066
CALL EchoList(Model % Constants, 0, 'constants' )
3067
DO i=1,Model % NumberOfEquations
3068
CALL EchoList(Model % Equations(i) % Values, i, 'equation' )
3069
END DO
3070
DO i=1,Model % NumberOfBodies
3071
CALL EchoList(Model % Bodies(i) % Values, i, 'body' )
3072
END DO
3073
DO i=1,Model % NumberOfBoundaries
3074
CALL EchoList(Model % Boundaries(i) % Values, i, 'boundary' )
3075
END DO
3076
DO i=1,Model % NumberOfBodyForces
3077
CALL EchoList(Model % BodyForces(i) % Values, i, 'body force' )
3078
END DO
3079
DO i=1,Model % NumberOfBCs
3080
CALL EchoList(Model % BCs(i) % Values, i, 'boundary condition' )
3081
END DO
3082
DO i=1,Model % NumberOfMaterials
3083
CALL EchoList(Model % Materials(i) % Values, i, 'material' )
3084
END DO
3085
DO i=1,Model % NumberOfComponents
3086
CALL EchoList(Model % Components(i) % Values, i, 'component' )
3087
END DO
3088
DO i=1,Model % NumberOfICs
3089
CALL EchoList(Model % ICs(i) % Values, i, 'initial condition' )
3090
END DO
3091
DO i=1,Model % NumberOfSolvers
3092
CALL EchoList(Model % Solvers(i) % Values, i, 'solver ' )
3093
END DO
3094
3095
CONTAINS
3096
3097
SUBROUTINE EchoList(list, i, section )
3098
TYPE(ValueList_t), POINTER :: list
3099
INTEGER :: i
3100
CHARACTER(LEN=*) :: section
3101
CHARACTER(LEN=MAX_NAME_LEN) :: str
3102
3103
TYPE(ValueListEntry_t), POINTER :: ptr
3104
3105
IF(.NOT.ASSOCIATED(List)) RETURN
3106
3107
ptr => List % Head
3108
DO WHILE( ASSOCIATED(ptr) )
3109
SELECT CASE(ptr % TYPE)
3110
CASE( LIST_TYPE_CONSTANT_SCALAR )
3111
WRITE(str,'(A,ES12.3)') 'Real ',ptr % Coeff * ptr % Fvalues(1,1,1)
3112
3113
CASE( LIST_TYPE_LOGICAL )
3114
IF( ptr % LValue ) THEN
3115
str = 'Logical True'
3116
ELSE
3117
str = 'Logical False'
3118
END IF
3119
CASE( LIST_TYPE_INTEGER )
3120
str = 'Integer '//I2S(ptr % Ivalues(1))
3121
3122
CASE DEFAULT
3123
ptr => ptr % Next
3124
CYCLE
3125
END SELECT
3126
3127
IF( i==0 ) THEN
3128
WRITE(*,'(A)') TRIM(Section)//' :: '//TRIM(ptr % Name)//' '//TRIM(str)
3129
ELSE
3130
WRITE(*,'(A)') TRIM(Section)//' '//I2S(i)//' :: '//TRIM(ptr % name)//' '//TRIM(str)
3131
END IF
3132
ptr => ptr % Next
3133
END DO
3134
3135
END SUBROUTINE EchoList
3136
3137
END SUBROUTINE ListEchoKeywords
3138
!-----------------------------------------------------------------------------------
3139
3140
3141
!-----------------------------------------------------------------------------------
3142
!> Copies an entry from 'ptr' to an entry in *different* list with the same content.
3143
!-----------------------------------------------------------------------------------
3144
SUBROUTINE ListCopyItem( ptr, list, name )
3145
3146
TYPE(ValueListEntry_t), POINTER :: ptr
3147
TYPE(ValueList_t), POINTER :: list
3148
CHARACTER(LEN=*), OPTIONAL :: name
3149
!------------------------------------------------------------------------------
3150
INTEGER :: i,j,k
3151
TYPE(ValueListEntry_t), POINTER :: ptrb, ptrnext
3152
3153
IF( PRESENT( name ) ) THEN
3154
ptrb => ListAdd( List, Name )
3155
ELSE
3156
ptrb => ListAdd( List, ptr % Name )
3157
END IF
3158
3159
3160
ptrnext => ptrb % next
3161
ptrb = ptr
3162
3163
ptrb % tvalues => null()
3164
if(associated(ptr % tvalues)) then
3165
allocate( ptrb % tvalues(size(ptr % tvalues)) )
3166
ptrb % tvalues = ptr % tvalues
3167
end if
3168
3169
ptrb % fvalues => null()
3170
if(associated(ptr % fvalues)) then
3171
i = size(ptr % fvalues,1)
3172
j = size(ptr % fvalues,2)
3173
k = size(ptr % fvalues,3)
3174
allocate( ptrb % fvalues(i,j,k) )
3175
ptrb % fvalues = ptr % fvalues
3176
end if
3177
3178
ptrb % ivalues => null()
3179
if(associated(ptr % ivalues)) then
3180
allocate( ptrb % ivalues(size(ptr % ivalues)) )
3181
ptrb % ivalues = ptr % ivalues
3182
end if
3183
3184
ptrb % cumulative => null()
3185
if(associated(ptr % cumulative)) then
3186
allocate( ptrb % cumulative(size(ptr % cumulative)) )
3187
ptrb % cumulative = ptr % cumulative
3188
end if
3189
ptrb % next => ptrnext
3190
3191
! If name is given then we have to revert the stuff from previous lines
3192
IF( PRESENT( name ) ) THEN
3193
ptrb % Name = name
3194
ptrb % Namelen = lentrim( name )
3195
END IF
3196
3197
#ifdef DEVEL_LISTCOUNTER
3198
IF( ASSOCIATED( ptr ) ) THEN
3199
ptr % Counter = ptr % Counter + 1
3200
END IF
3201
#endif
3202
#ifdef DEVEL_LISTUSAGE
3203
IF( ASSOCIATED( ptr ) ) THEN
3204
ptr % Counter = 1
3205
END IF
3206
#endif
3207
3208
END SUBROUTINE ListCopyItem
3209
3210
3211
!> Checks two lists for a given keyword. If it is given then
3212
!> copy it as it is to the 2nd list.
3213
!------------------------------------------------------------------------------
3214
SUBROUTINE ListCompareAndCopy( list, listb, name, Found, remove, nooverwrite)
3215
!------------------------------------------------------------------------------
3216
TYPE(ValueList_t), POINTER :: list, listb
3217
CHARACTER(LEN=*) :: name
3218
LOGICAL, OPTIONAL :: Found
3219
LOGICAL, OPTIONAL :: remove
3220
LOGICAL, OPTIONAL :: nooverwrite
3221
!------------------------------------------------------------------------------
3222
TYPE(ValueListEntry_t), POINTER :: ptr
3223
CHARACTER(LEN=LEN_TRIM(Name)) :: str
3224
INTEGER :: k, n
3225
3226
k = StringToLowerCase( str,Name,.TRUE. )
3227
IF(PRESENT(Found)) Found = .FALSE.
3228
3229
IF(PRESENT(nooverwrite)) THEN
3230
IF(nooverwrite) THEN
3231
IF( ListCheckPresent( listb, str ) ) RETURN
3232
END IF
3233
END IF
3234
3235
! Find the keyword from the 1st list
3236
Ptr => List % Head
3237
DO WHILE( ASSOCIATED(ptr) )
3238
n = ptr % NameLen
3239
IF ( n==k ) THEN
3240
IF ( ptr % Name(1:n) == str(1:n) ) EXIT
3241
END IF
3242
ptr => ptr % Next
3243
END DO
3244
3245
IF(.NOT. ASSOCIATED( ptr ) ) RETURN
3246
3247
! Add the same entry to the 2nd list
3248
CALL ListCopyItem( ptr, listb )
3249
IF(PRESENT(Found)) Found = .TRUE.
3250
3251
IF( PRESENT(remove) ) THEN
3252
IF( remove ) CALL ListRemove( list, name)
3253
END IF
3254
3255
3256
END SUBROUTINE ListCompareAndCopy
3257
3258
3259
!> Goes through one list and checks whether it includes any keywords with give prefix.
3260
!> All keywords found are copied to the 2nd list without the prefix.
3261
!------------------------------------------------------------------------------
3262
SUBROUTINE ListCopyPrefixedKeywords( list, listb, prefix )
3263
!------------------------------------------------------------------------------
3264
TYPE(ValueList_t), POINTER :: list, listb
3265
CHARACTER(LEN=*) :: prefix
3266
!------------------------------------------------------------------------------
3267
TYPE(ValueListEntry_t), POINTER :: ptr
3268
CHARACTER(LEN=LEN_TRIM(prefix)) :: str
3269
INTEGER :: k, l, n, ncopy
3270
3271
k = StringToLowerCase( str,prefix,.TRUE. )
3272
ncopy = 0
3273
3274
! Find the keyword from the 1st list
3275
Ptr => List % Head
3276
DO WHILE( ASSOCIATED(ptr) )
3277
n = ptr % NameLen
3278
IF( n > k ) THEN
3279
IF( ptr % Name(1:k) == str(1:k) ) THEN
3280
l = k+1
3281
! Remove the extra blanco after prefix if present
3282
! Here we just assume one possible blanco as that is most often the case
3283
IF( ptr % Name(l:l) == ' ') l = l+1
3284
CALL Info('ListCopyPrefixedKeywords',&
3285
'Prefix: '//TRIM(prefix)// ' Keyword: '//TRIM(ptr % Name(l:n)),Level=12)
3286
CALL ListCopyItem( ptr, listb, ptr % Name(l:n) )
3287
ncopy = ncopy + 1
3288
END IF
3289
END IF
3290
ptr => ptr % Next
3291
END DO
3292
3293
IF( ncopy > 0 ) THEN
3294
CALL Info('ListCopyPrefixedKeywords',&
3295
'Copied '//I2S(ncopy)//' keywords with prefix: '//TRIM(prefix),Level=6)
3296
END IF
3297
3298
END SUBROUTINE ListCopyPrefixedKeywords
3299
3300
3301
!> Goes through one list and copies all keywords to a second list.
3302
!------------------------------------------------------------------------------
3303
SUBROUTINE ListCopyAllKeywords( list, listb )
3304
!------------------------------------------------------------------------------
3305
TYPE(ValueList_t), POINTER :: list, listb
3306
!------------------------------------------------------------------------------
3307
TYPE(ValueListEntry_t), POINTER :: ptr
3308
INTEGER :: ncopy
3309
3310
ncopy = 0
3311
3312
! Find the keyword from the 1st list
3313
Ptr => List % Head
3314
DO WHILE( ASSOCIATED(ptr) )
3315
CALL ListCopyItem( ptr, listb, ptr % Name )
3316
ncopy = ncopy + 1
3317
ptr => ptr % Next
3318
END DO
3319
3320
IF( ncopy > 0 ) THEN
3321
CALL Info('ListCopyAllKeywords',&
3322
'Copied '//I2S(ncopy)//' keywords to new list',Level=6)
3323
END IF
3324
3325
END SUBROUTINE ListCopyAllKeywords
3326
3327
3328
!------------------------------------------------------------------------------
3329
!> Check that obsolete keyword is not used instead of the new one.
3330
!------------------------------------------------------------------------------
3331
SUBROUTINE ListObsoleteWarn( List,OldName,NewName )
3332
!------------------------------------------------------------------------------
3333
TYPE(ValueList_t), POINTER :: List
3334
CHARACTER(LEN=*) :: OldName,NewName
3335
!------------------------------------------------------------------------------
3336
LOGICAL :: Found
3337
TYPE(ValueListEntry_t), POINTER :: ptr
3338
!------------------------------------------------------------------------------
3339
ptr => ListFind(List,OldName,Found)
3340
IF( Found ) THEN
3341
CALL Warn('ListFatalObsolete',&
3342
'Use keyword "'//TRIM(NewName)//'" instead of "'//TRIM(OldName)//'"')
3343
END IF
3344
!------------------------------------------------------------------------------
3345
END SUBROUTINE ListObsoleteWarn
3346
!------------------------------------------------------------------------------
3347
3348
!------------------------------------------------------------------------------
3349
!> Check that obsolete keyword is not used instead of the new one.
3350
!------------------------------------------------------------------------------
3351
SUBROUTINE ListObsoleteFatal( List,OldName,NewName )
3352
!------------------------------------------------------------------------------
3353
TYPE(ValueList_t), POINTER :: List
3354
CHARACTER(LEN=*) :: OldName,NewName
3355
!------------------------------------------------------------------------------
3356
LOGICAL :: Found
3357
TYPE(ValueListEntry_t), POINTER :: ptr
3358
!------------------------------------------------------------------------------
3359
ptr => ListFind(List,OldName,Found)
3360
IF( Found ) THEN
3361
CALL Fatal('ListFatalObsolete',&
3362
'Use keyword "'//TRIM(NewName)//'" instead of "'//TRIM(OldName)//'"')
3363
END IF
3364
!------------------------------------------------------------------------------
3365
END SUBROUTINE ListObsoleteFatal
3366
!------------------------------------------------------------------------------
3367
3368
3369
3370
!------------------------------------------------------------------------------
3371
!> Just checks if there is a untreated keyword in the routine in the list.
3372
!> In case there is return a warning.
3373
!------------------------------------------------------------------------------
3374
SUBROUTINE ListUntreatedWarn( List, Name, Caller )
3375
!------------------------------------------------------------------------------
3376
TYPE(ValueList_t), POINTER :: List
3377
CHARACTER(LEN=*) :: Name
3378
CHARACTER(LEN=*), OPTIONAL :: Caller
3379
!------------------------------------------------------------------------------
3380
IF( ListCheckPresent( List, Name ) ) THEN
3381
IF( PRESENT( Caller ) ) THEN
3382
CALL Warn(Caller,'Untreated keyword may cause problems: '//TRIM(Name))
3383
ELSE
3384
CALL Warn('ListUntreatedWarn','Untreated keyword may cause problems: '//TRIM(Name))
3385
END IF
3386
END IF
3387
!------------------------------------------------------------------------------
3388
END SUBROUTINE ListUntreatedWarn
3389
!------------------------------------------------------------------------------
3390
3391
!------------------------------------------------------------------------------
3392
!> Just checks if there is a untreated keyword in the routine in the list.
3393
!> In case there is return a Fatal.
3394
!------------------------------------------------------------------------------
3395
SUBROUTINE ListUntreatedFatal( List, Name, Caller )
3396
!------------------------------------------------------------------------------
3397
TYPE(ValueList_t), POINTER :: List
3398
CHARACTER(LEN=*) :: Name
3399
CHARACTER(LEN=*), OPTIONAL :: Caller
3400
!------------------------------------------------------------------------------
3401
IF( ListCheckPresent( List, Name ) ) THEN
3402
IF( PRESENT( Caller ) ) THEN
3403
CALL Fatal(Caller,'Untreated keyword: '//TRIM(Name))
3404
ELSE
3405
CALL Fatal('ListUntreatedFatal','Untreated keyword: '//TRIM(Name))
3406
END IF
3407
END IF
3408
!------------------------------------------------------------------------------
3409
END SUBROUTINE ListUntreatedFatal
3410
!------------------------------------------------------------------------------
3411
3412
!------------------------------------------------------------------------------
3413
!> Just checks if a prefix is present in the list.
3414
!------------------------------------------------------------------------------
3415
FUNCTION ListCheckPrefix( List,Name ) RESULT(Found)
3416
!------------------------------------------------------------------------------
3417
TYPE(ValueList_t), POINTER :: List
3418
CHARACTER(LEN=*) :: Name
3419
LOGICAL :: Found
3420
!------------------------------------------------------------------------------
3421
TYPE(ValueListEntry_t), POINTER :: ptr
3422
!------------------------------------------------------------------------------
3423
ptr => ListFindPrefix(List,Name,Found)
3424
!------------------------------------------------------------------------------
3425
END FUNCTION ListCheckPrefix
3426
!------------------------------------------------------------------------------
3427
3428
!------------------------------------------------------------------------------
3429
!> Check if the keyword is with the given prefix is present in any boundary condition.
3430
!------------------------------------------------------------------------------
3431
FUNCTION ListCheckPrefixAnyBC( Model, Name ) RESULT(Found)
3432
!------------------------------------------------------------------------------
3433
TYPE(Model_t) :: Model
3434
CHARACTER(LEN=*) :: Name
3435
LOGICAL :: Found
3436
INTEGER :: bc
3437
TYPE(ValuelistEntry_t), POINTER :: ptr
3438
3439
Found = .FALSE.
3440
DO bc = 1,Model % NumberOfBCs
3441
ptr => ListFindPrefix( Model % BCs(bc) % Values, Name, Found )
3442
IF( Found ) EXIT
3443
END DO
3444
!------------------------------------------------------------------------------
3445
END FUNCTION ListCheckPrefixAnyBC
3446
!------------------------------------------------------------------------------
3447
3448
!------------------------------------------------------------------------------
3449
!> Check if the keyword is with the given prefix is present in any body.
3450
!------------------------------------------------------------------------------
3451
FUNCTION ListCheckPrefixAnyBody( Model, Name ) RESULT(Found)
3452
!------------------------------------------------------------------------------
3453
TYPE(Model_t) :: Model
3454
CHARACTER(LEN=*) :: Name
3455
LOGICAL :: Found
3456
INTEGER :: body_id
3457
TYPE(ValuelistEntry_t), POINTER :: ptr
3458
3459
Found = .FALSE.
3460
DO body_id = 1,Model % NumberOfBodies
3461
ptr => ListFindPrefix( Model % Bodies(body_id) % Values, Name, Found )
3462
IF( Found ) EXIT
3463
END DO
3464
!------------------------------------------------------------------------------
3465
END FUNCTION ListCheckPrefixAnyBody
3466
!------------------------------------------------------------------------------
3467
3468
!------------------------------------------------------------------------------
3469
!> Check if the keyword is with the given prefix is present in any material.
3470
!------------------------------------------------------------------------------
3471
FUNCTION ListCheckPrefixAnyMaterial( Model, Name ) RESULT(Found)
3472
!------------------------------------------------------------------------------
3473
TYPE(Model_t) :: Model
3474
CHARACTER(LEN=*) :: Name
3475
LOGICAL :: Found
3476
INTEGER :: mat_id
3477
TYPE(ValuelistEntry_t), POINTER :: ptr
3478
3479
Found = .FALSE.
3480
DO mat_id = 1,Model % NumberOfMaterials
3481
ptr => ListFindPrefix( Model % Materials(mat_id) % Values, Name, Found )
3482
IF( Found ) EXIT
3483
END DO
3484
!------------------------------------------------------------------------------
3485
END FUNCTION ListCheckPrefixAnyMaterial
3486
!------------------------------------------------------------------------------
3487
3488
!------------------------------------------------------------------------------
3489
!> Check if the keyword is with the given prefix is present in any body force.
3490
!------------------------------------------------------------------------------
3491
FUNCTION ListCheckPrefixAnyBodyForce( Model, Name ) RESULT(Found)
3492
!------------------------------------------------------------------------------
3493
TYPE(Model_t) :: Model
3494
CHARACTER(LEN=*) :: Name
3495
LOGICAL :: Found
3496
INTEGER :: bf_id
3497
TYPE(ValuelistEntry_t), POINTER :: ptr
3498
3499
Found = .FALSE.
3500
DO bf_id = 1,Model % NumberOfBodyForces
3501
ptr => ListFindPrefix( Model % BodyForces(bf_id) % Values, Name, Found )
3502
IF( Found ) EXIT
3503
END DO
3504
!------------------------------------------------------------------------------
3505
END FUNCTION ListCheckPrefixAnyBodyForce
3506
!------------------------------------------------------------------------------
3507
3508
3509
3510
!------------------------------------------------------------------------------
3511
!> Adds a string to the list.
3512
!------------------------------------------------------------------------------
3513
SUBROUTINE ListAddString( List,Name,CValue,CaseConversion )
3514
!------------------------------------------------------------------------------
3515
TYPE(ValueList_t), POINTER :: List
3516
CHARACTER(LEN=*) :: Name
3517
CHARACTER(LEN=*) :: CValue
3518
LOGICAL, OPTIONAL :: CaseConversion
3519
!------------------------------------------------------------------------------
3520
INTEGER :: n
3521
LOGICAL :: DoCase
3522
TYPE(ValueListEntry_t), POINTER :: ptr
3523
!------------------------------------------------------------------------------
3524
ptr => ListAdd( List, Name )
3525
3526
DoCase = .TRUE.
3527
IF ( PRESENT(CaseConversion) ) DoCase = CaseConversion
3528
3529
n = LEN_TRIM(Cvalue)
3530
IF(ALLOCATED(ptr % Cvalue)) DEALLOCATE(ptr % Cvalue)
3531
ALLOCATE(CHARACTER(n)::ptr % Cvalue)
3532
IF ( DoCase ) THEN
3533
n = StringToLowerCase( ptr % CValue,CValue )
3534
ELSE
3535
n = MIN( MAX_NAME_LEN,LEN(CValue) )
3536
ptr % CValue = TRIM(Cvalue)
3537
END IF
3538
3539
ptr % TYPE = LIST_TYPE_STRING
3540
n = LEN_TRIM(Name)
3541
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3542
ALLOCATE(CHARACTER(n)::ptr % Name)
3543
ptr % NameLen = StringToLowerCase( Ptr % Name,Name )
3544
!------------------------------------------------------------------------------
3545
END SUBROUTINE ListAddString
3546
!------------------------------------------------------------------------------
3547
3548
3549
!------------------------------------------------------------------------------
3550
!> Adds a logical entry to the list.
3551
!------------------------------------------------------------------------------
3552
SUBROUTINE ListAddLogical( List,Name,LValue )
3553
!------------------------------------------------------------------------------
3554
TYPE(ValueList_t), POINTER :: List
3555
CHARACTER(LEN=*) :: Name
3556
LOGICAL :: LValue
3557
!------------------------------------------------------------------------------
3558
INTEGER :: n
3559
TYPE(ValueListEntry_t), POINTER :: ptr
3560
!------------------------------------------------------------------------------
3561
ptr => ListAdd( List, Name )
3562
Ptr % LValue = LValue
3563
Ptr % TYPE = LIST_TYPE_LOGICAL
3564
3565
n = LEN_TRIM(Name)
3566
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3567
ALLOCATE(CHARACTER(n)::ptr % Name)
3568
Ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3569
END SUBROUTINE ListAddLogical
3570
!------------------------------------------------------------------------------
3571
3572
3573
!------------------------------------------------------------------------------
3574
!> Adds an integer to the list.
3575
!------------------------------------------------------------------------------
3576
SUBROUTINE ListAddInteger( List,Name,IValue,Proc )
3577
!------------------------------------------------------------------------------
3578
TYPE(ValueList_t), POINTER :: List
3579
CHARACTER(LEN=*) :: Name
3580
INTEGER :: IValue
3581
INTEGER(Kind=AddrInt), OPTIONAL :: Proc
3582
!------------------------------------------------------------------------------
3583
INTEGER :: n
3584
TYPE(ValueListEntry_t), POINTER :: ptr
3585
!------------------------------------------------------------------------------
3586
ptr => ListAdd( List, Name )
3587
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
3588
3589
ALLOCATE( ptr % IValues(1) )
3590
ptr % IValues(1) = IValue
3591
ptr % TYPE = LIST_TYPE_INTEGER
3592
3593
n = LEN_TRIM(Name)
3594
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3595
ALLOCATE(CHARACTER(n)::ptr % Name)
3596
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3597
END SUBROUTINE ListAddInteger
3598
!------------------------------------------------------------------------------
3599
3600
3601
!------------------------------------------------------------------------------
3602
!> Adds an integer array to the list.
3603
!------------------------------------------------------------------------------
3604
SUBROUTINE ListAddIntegerArray( List,Name,Nv,IValues,Proc )
3605
!------------------------------------------------------------------------------
3606
TYPE(ValueList_t), POINTER :: List
3607
CHARACTER(LEN=*) :: Name
3608
INTEGER :: Nv
3609
INTEGER :: IValues(Nv)
3610
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
3611
!------------------------------------------------------------------------------
3612
INTEGER :: n
3613
TYPE(ValueListEntry_t), POINTER :: ptr
3614
!------------------------------------------------------------------------------
3615
ptr => ListAdd( List, Name )
3616
3617
ALLOCATE( ptr % IValues(Nv) )
3618
3619
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
3620
3621
ptr % TYPE = LIST_TYPE_INTEGER
3622
ptr % IValues(1:nv) = IValues(1:nv)
3623
3624
n = LEN_TRIM(Name)
3625
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3626
ALLOCATE(CHARACTER(n)::ptr % Name)
3627
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3628
END SUBROUTINE ListAddIntegerArray
3629
!------------------------------------------------------------------------------
3630
3631
!------------------------------------------------------------------------------
3632
!> Adds a constant real value to the list.
3633
!------------------------------------------------------------------------------
3634
SUBROUTINE ListAddConstReal( List,Name,FValue,Proc,CValue )
3635
!------------------------------------------------------------------------------
3636
TYPE(ValueList_t), POINTER :: List
3637
CHARACTER(LEN=*) :: Name
3638
CHARACTER(LEN=*), OPTIONAL :: Cvalue
3639
REAL(KIND=dp) :: FValue
3640
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
3641
!------------------------------------------------------------------------------
3642
INTEGER :: n
3643
TYPE(ValueListEntry_t), POINTER :: ptr
3644
!------------------------------------------------------------------------------
3645
ptr => ListAdd( List, Name )
3646
3647
NULLIFY( ptr % TValues )
3648
ALLOCATE( ptr % FValues(1,1,1) )
3649
3650
ptr % FValues = FValue
3651
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR
3652
3653
IF ( PRESENT(Proc) ) THEN
3654
ptr % PROCEDURE = Proc
3655
IF( Proc /= 0 ) THEN
3656
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_PROC
3657
END IF
3658
END IF
3659
3660
IF ( PRESENT( CValue ) ) THEN
3661
ptr % Cvalue = TRIM(CValue)
3662
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_STR
3663
END IF
3664
3665
n = LEN_TRIM(Name)
3666
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3667
ALLOCATE(CHARACTER(n)::ptr % Name)
3668
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3669
END SUBROUTINE ListAddConstReal
3670
!------------------------------------------------------------------------------
3671
3672
3673
!------------------------------------------------------------------------------
3674
!> Adds a linear dependency defined by a table of values, [x,y] to the list.
3675
!------------------------------------------------------------------------------
3676
SUBROUTINE ListAddDepReal(List,Name,DependName,N,TValues, &
3677
FValues,Proc,CValue,CubicTable, Monotone, Harmonic)
3678
!------------------------------------------------------------------------------
3679
TYPE(ValueList_t), POINTER :: List
3680
CHARACTER(LEN=*) :: Name,DependName
3681
CHARACTER(LEN=*), OPTIONAL :: Cvalue
3682
INTEGER :: N
3683
LOGICAL, OPTIONAL :: CubicTable, Monotone, Harmonic
3684
REAL(KIND=dp) :: FValues(N)
3685
REAL(KIND=dp) :: TValues(N)
3686
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
3687
!------------------------------------------------------------------------------
3688
INTEGER :: l
3689
TYPE(ValueListEntry_t), POINTER :: ptr
3690
!------------------------------------------------------------------------------
3691
ptr => ListAdd( List, Name )
3692
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
3693
3694
ALLOCATE( ptr % FValues(1,1,n),ptr % TValues(n) )
3695
3696
! The (x,y) table should be such that values of x are increasing in size
3697
IF( .NOT. CheckMonotone( n, TValues ) ) THEN
3698
CALL Fatal('ListAddDepReal',&
3699
'Values x in > '//TRIM(Name)//' < not monotonically ordered!')
3700
END IF
3701
3702
ptr % TValues = TValues(1:n)
3703
ptr % FValues(1,1,:) = FValues(1:n)
3704
ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR
3705
3706
IF(PRESENT(harmonic)) THEN
3707
IF(Harmonic) THEN
3708
CALL ConvertTableToHarmonic(n, ptr % TValues,ptr % Fvalues(1,1,:))
3709
END IF
3710
END IF
3711
3712
IF ( n>3 .AND. PRESENT(CubicTable)) THEN
3713
IF ( CubicTable ) THEN
3714
ALLOCATE(ptr % CubicCoeff(n))
3715
CALL CubicSpline(n,ptr % TValues,Ptr % Fvalues(1,1,:), &
3716
Ptr % CubicCoeff, Monotone )
3717
END IF
3718
END IF
3719
3720
ALLOCATE(ptr % Cumulative(n))
3721
CALL CumulativeIntegral(ptr % TValues, Ptr % FValues(1,1,:), &
3722
Ptr % CubicCoeff, Ptr % Cumulative )
3723
3724
l = LEN_TRIM(Name)
3725
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3726
ALLOCATE(CHARACTER(l)::ptr % Name)
3727
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3728
3729
l = LEN_TRIM(DependName)
3730
IF(ALLOCATED(ptr % DependName)) DEALLOCATE(ptr % DependName)
3731
ALLOCATE(CHARACTER(l)::ptr % DependName)
3732
ptr % DepNameLen = StringToLowerCase( ptr % DependName,DependName )
3733
3734
IF ( PRESENT( Cvalue ) ) THEN
3735
ptr % CValue = CValue
3736
ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR_STR
3737
END IF
3738
3739
END SUBROUTINE ListAddDepReal
3740
!------------------------------------------------------------------------------
3741
3742
3743
!------------------------------------------------------------------------------
3744
!> Adds a constant real valued array to the list.
3745
!------------------------------------------------------------------------------
3746
SUBROUTINE ListAddConstRealArray( List,Name,N,M,FValues,Proc,CValue )
3747
!------------------------------------------------------------------------------
3748
TYPE(ValueList_t), POINTER :: List
3749
CHARACTER(LEN=*) :: Name
3750
CHARACTER(LEN=*), OPTIONAL :: Cvalue
3751
INTEGER :: N,M
3752
REAL(KIND=dp) :: FValues(:,:)
3753
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
3754
!------------------------------------------------------------------------------
3755
INTEGER :: l
3756
TYPE(ValueListEntry_t), POINTER :: ptr
3757
!------------------------------------------------------------------------------
3758
ptr => ListAdd( List, Name )
3759
3760
NULLIFY( ptr % TValues )
3761
ALLOCATE( ptr % FValues(N,M,1) )
3762
3763
ptr % Fdim = 0
3764
IF( N > 1 ) ptr % Fdim = 1
3765
IF( M > 1 ) ptr % Fdim = ptr % Fdim + 1
3766
3767
IF( ptr % Fdim == 0 ) THEN
3768
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR
3769
ELSE
3770
ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR
3771
END IF
3772
ptr % FValues(1:n,1:m,1) = FValues(1:n,1:m)
3773
3774
IF ( PRESENT(Proc) ) THEN
3775
ptr % PROCEDURE = Proc
3776
END IF
3777
3778
IF ( PRESENT( Cvalue ) ) THEN
3779
ptr % CValue = CValue
3780
IF( ptr % Fdim == 0 ) THEN
3781
ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_STR
3782
ELSE
3783
ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR_STR
3784
END IF
3785
END IF
3786
3787
l = LEN_TRIM(Name)
3788
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3789
ALLOCATE(CHARACTER(l)::ptr % Name)
3790
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3791
END SUBROUTINE ListAddConstRealArray
3792
!------------------------------------------------------------------------------
3793
3794
3795
!------------------------------------------------------------------------------
3796
!> Adds a real array where the components are linearly dependent.
3797
!------------------------------------------------------------------------------
3798
SUBROUTINE ListAddDepRealArray(List,Name,DependName, &
3799
ni,TValues,n,m,FValues,Proc,Cvalue)
3800
!------------------------------------------------------------------------------
3801
TYPE(ValueList_t), POINTER :: List
3802
CHARACTER(LEN=*) :: Name,DependName
3803
CHARACTER(LEN=*), OPTIONAL :: Cvalue
3804
INTEGER :: ni,n,m
3805
REAL(KIND=dp) :: FValues(:,:,:)
3806
REAL(KIND=dp) :: TValues(ni)
3807
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
3808
!------------------------------------------------------------------------------
3809
INTEGER :: l
3810
TYPE(ValueListEntry_t), POINTER :: ptr
3811
!------------------------------------------------------------------------------
3812
3813
ptr => ListAdd( List, Name )
3814
IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc
3815
3816
ALLOCATE( ptr % FValues(n,m,ni),ptr % TValues(ni) )
3817
3818
ptr % TValues = TValues(1:ni)
3819
ptr % FValues = FValues(1:n,1:m,1:ni)
3820
ptr % TYPE = LIST_TYPE_VARIABLE_TENSOR
3821
3822
ptr % fdim = 0
3823
IF( n > 1 ) ptr % fdim = 1
3824
IF( m > 1 ) ptr % fdim = ptr % fdim + 1
3825
3826
IF ( PRESENT( Cvalue ) ) THEN
3827
ptr % CValue = CValue
3828
ptr % TYPE = LIST_TYPE_VARIABLE_TENSOR_STR
3829
END IF
3830
3831
l = LEN_TRIM(Name)
3832
IF(ALLOCATED(ptr % Name)) DEALLOCATE(ptr % Name)
3833
ALLOCATE(CHARACTER(l)::ptr % Name)
3834
ptr % NameLen = StringToLowerCase( ptr % Name,Name )
3835
3836
l = LEN_TRIM(DependName)
3837
IF(ALLOCATED(ptr % DependName)) DEALLOCATE(ptr % DependName)
3838
ALLOCATE(CHARACTER(l)::ptr % DependName)
3839
ptr % DepNameLen = StringToLowerCase( ptr % DependName,DependName )
3840
!------------------------------------------------------------------------------
3841
END SUBROUTINE ListAddDepRealArray
3842
!------------------------------------------------------------------------------
3843
3844
3845
!------------------------------------------------------------------------------
3846
! Given real array transform it to dependence array. This can only be done
3847
! if the size of the array is suitable.
3848
!------------------------------------------------------------------------------
3849
SUBROUTINE ListRealArrayToDepReal(List,Name,DepName,CubicTable,Monotone)
3850
TYPE(ValueList_t), POINTER :: List
3851
CHARACTER(LEN=*) :: Name
3852
CHARACTER(LEN=*) :: DepName
3853
LOGICAL, OPTIONAL :: CubicTable, Monotone
3854
3855
TYPE(ValueListEntry_t), POINTER :: ptr
3856
INTEGER :: n,m, l
3857
REAL(KIND=dp), ALLOCATABLE :: TmpValues(:,:,:)
3858
3859
ptr => ListFind( List, Name )
3860
3861
! Change only constant real array!
3862
IF( ptr % TYPE /= LIST_TYPE_CONSTANT_TENSOR ) RETURN
3863
3864
IF(.NOT. ASSOCIATED(ptr) ) THEN
3865
CALL Warn('ListRealArrayToDepArray','Could not find: '//TRIM(Name))
3866
RETURN
3867
END IF
3868
3869
IF( ptr % Fdim < 2 ) THEN
3870
CALL Warn('ListRealArrayToDepArray','No array form to transform!')
3871
RETURN
3872
END IF
3873
3874
n = SIZE(ptr % FValues,1)
3875
m = SIZE(ptr % FValues,2)
3876
3877
IF( m /= 2 ) THEN
3878
CALL Warn('ListRealArrayToDepArray','Number of columns must be 2!')
3879
RETURN
3880
END IF
3881
3882
ALLOCATE( TmpValues(n,m,1) )
3883
TmpValues = ptr % FValues
3884
DEALLOCATE( ptr % FValues )
3885
3886
ALLOCATE( ptr % FValues(1,1,n), ptr % TValues(n) )
3887
ptr % FValues(1,1,1:n) = TmpValues(1:n,2,1)
3888
ptr % TValues(1:n) = TmpValues(1:n,1,1)
3889
DEALLOCATE( TmpValues )
3890
3891
! The (x,y) table should be such that values of x are increasing in size
3892
IF( .NOT. CheckMonotone( n, ptr % FValues(1,1,:) ) ) THEN
3893
CALL Fatal('ListRealArrayToDepReal',&
3894
'Values x in > '//TRIM(Name)//' < not monotonically ordered!')
3895
END IF
3896
3897
! Make it cubic if asked
3898
IF ( n>3 .AND. PRESENT(CubicTable)) THEN
3899
IF ( CubicTable ) THEN
3900
ALLOCATE(ptr % CubicCoeff(n))
3901
CALL CubicSpline(n,ptr % TValues,Ptr % Fvalues(1,1,:), &
3902
Ptr % CubicCoeff, Monotone )
3903
END IF
3904
END IF
3905
3906
ALLOCATE(ptr % Cumulative(n))
3907
CALL CumulativeIntegral(ptr % TValues, Ptr % FValues(1,1,:), &
3908
Ptr % CubicCoeff, Ptr % Cumulative )
3909
3910
! Copy the depname
3911
l = LEN_TRIM(DepName)
3912
IF(ALLOCATED(ptr % DependName)) DEALLOCATE(ptr % DependName)
3913
ALLOCATE(CHARACTER(l)::ptr % DependName)
3914
ptr % DepNameLen = StringToLowerCase( ptr % DependName,DepName )
3915
3916
! Finally, change the type
3917
ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR
3918
3919
CALL Info('ListRealArrayToDepReal',&
3920
'Changed constant array to dependence table of size '//I2S(n)//'!')
3921
3922
END SUBROUTINE ListRealArrayToDepReal
3923
3924
3925
3926
!------------------------------------------------------------------------------
3927
!> Adds a logical entry to the list if it does not exist previously.
3928
!------------------------------------------------------------------------------
3929
SUBROUTINE ListAddNewLogical( List,Name,LValue )
3930
!------------------------------------------------------------------------------
3931
TYPE(ValueList_t), POINTER :: List
3932
CHARACTER(LEN=*) :: Name
3933
LOGICAL :: LValue
3934
!------------------------------------------------------------------------------
3935
TYPE(ValueListEntry_t), POINTER :: ptr
3936
!------------------------------------------------------------------------------
3937
IF( ListCheckPresent( List, Name ) ) RETURN
3938
3939
CALL ListAddLogical( List,Name,LValue )
3940
3941
END SUBROUTINE ListAddNewLogical
3942
!------------------------------------------------------------------------------
3943
3944
3945
!------------------------------------------------------------------------------
3946
!> Adds an integer to the list when not present previously.
3947
!------------------------------------------------------------------------------
3948
SUBROUTINE ListAddNewInteger( List,Name,IValue,Proc )
3949
!------------------------------------------------------------------------------
3950
TYPE(ValueList_t), POINTER :: List
3951
CHARACTER(LEN=*) :: Name
3952
INTEGER :: IValue
3953
INTEGER(Kind=AddrInt), OPTIONAL :: Proc
3954
!------------------------------------------------------------------------------
3955
TYPE(ValueListEntry_t), POINTER :: ptr
3956
!------------------------------------------------------------------------------
3957
IF( ListCheckPresent( List, Name ) ) RETURN
3958
3959
CALL ListAddInteger( List,Name,IValue,Proc )
3960
3961
END SUBROUTINE ListAddNewInteger
3962
!------------------------------------------------------------------------------
3963
3964
3965
!------------------------------------------------------------------------------
3966
!> Adds a constant real value to the list if not present.
3967
!------------------------------------------------------------------------------
3968
SUBROUTINE ListAddNewConstReal( List,Name,FValue,Proc,CValue )
3969
!------------------------------------------------------------------------------
3970
TYPE(ValueList_t), POINTER :: List
3971
CHARACTER(LEN=*) :: Name
3972
CHARACTER(LEN=*), OPTIONAL :: Cvalue
3973
REAL(KIND=dp) :: FValue
3974
INTEGER(KIND=AddrInt), OPTIONAL :: Proc
3975
!------------------------------------------------------------------------------
3976
TYPE(ValueListEntry_t), POINTER :: ptr
3977
!------------------------------------------------------------------------------
3978
IF( ListCheckPresent( List, Name ) ) RETURN
3979
3980
CALL ListAddConstReal( List,Name,FValue,Proc,CValue )
3981
3982
END SUBROUTINE ListAddNewConstReal
3983
!------------------------------------------------------------------------------
3984
3985
3986
3987
!------------------------------------------------------------------------------
3988
!> Add a string value to the list if not present.
3989
!------------------------------------------------------------------------------
3990
SUBROUTINE ListAddNewString( List,Name,CValue,CaseConversion )
3991
!------------------------------------------------------------------------------
3992
TYPE(ValueList_t), POINTER :: List
3993
CHARACTER(LEN=*) :: Name
3994
CHARACTER(LEN=*) :: CValue
3995
LOGICAL, OPTIONAL :: CaseConversion
3996
3997
IF( ListCheckPresent( List, Name ) ) RETURN
3998
3999
CALL ListAddString( List,Name,CValue,CaseConversion )
4000
4001
END SUBROUTINE ListAddNewString
4002
!------------------------------------------------------------------------------
4003
4004
4005
!------------------------------------------------------------------------------
4006
!> Gets a integer value from the list.
4007
!------------------------------------------------------------------------------
4008
RECURSIVE FUNCTION ListGetInteger( List,Name,Found,minv,maxv,UnfoundFatal,DefValue) RESULT(L)
4009
!------------------------------------------------------------------------------
4010
TYPE(ValueList_t), POINTER :: List
4011
CHARACTER(LEN=*) :: Name
4012
INTEGER, OPTIONAL :: DefValue
4013
INTEGER :: L
4014
LOGICAL, OPTIONAL :: Found, UnfoundFatal
4015
INTEGER, OPTIONAL :: minv,maxv
4016
!------------------------------------------------------------------------------
4017
TYPE(ValueListEntry_t), POINTER :: ptr
4018
!------------------------------------------------------------------------------
4019
IF(PRESENT(DefValue)) THEN
4020
L = DefValue
4021
ELSE
4022
L = 0
4023
END IF
4024
4025
ptr => ListFind(List,Name,Found)
4026
IF (.NOT.ASSOCIATED(ptr) ) THEN
4027
IF(PRESENT(UnfoundFatal)) THEN
4028
IF(UnfoundFatal) THEN
4029
WRITE(Message, '(A,A)') "Failed to find integer: ",Name
4030
CALL Fatal("ListGetInteger", Message)
4031
END IF
4032
END IF
4033
RETURN
4034
END IF
4035
4036
IF( ptr % type /= LIST_TYPE_INTEGER ) THEN
4037
CALL Fatal('ListGetInteger','Invalid list type for: '//TRIM(Name))
4038
END IF
4039
4040
IF ( ptr % PROCEDURE /= 0 ) THEN
4041
CALL ListPushActiveName(Name)
4042
L = ExecIntFunction( ptr % PROCEDURE, CurrentModel )
4043
CALL ListPopActiveName()
4044
ELSE
4045
IF ( .NOT. ASSOCIATED(ptr % IValues) ) THEN
4046
CALL Fatal( 'ListGetInteger', 'Value type for property ['//TRIM(Name)//&
4047
'] not used consistently.')
4048
END IF
4049
4050
L = ptr % IValues(1)
4051
END IF
4052
4053
IF ( PRESENT( minv ) ) THEN
4054
IF ( L < minv ) THEN
4055
WRITE( Message, '(A,I0,A,I0)') 'Given value ',L,' for property: ['//TRIM(Name)//&
4056
'] smaller than given minimum: ', minv
4057
CALL Fatal( 'ListGetInteger', Message )
4058
END IF
4059
END IF
4060
4061
IF ( PRESENT( maxv ) ) THEN
4062
IF ( L > maxv ) THEN
4063
WRITE( Message, '(A,I0,A,I0)') 'Given value ',L,' for property: ['//TRIM(Name)//&
4064
'] larger than given maximum: ', maxv
4065
CALL Fatal( 'ListGetInteger', Message )
4066
END IF
4067
END IF
4068
!------------------------------------------------------------------------------
4069
END FUNCTION ListGetInteger
4070
!------------------------------------------------------------------------------
4071
4072
4073
!------------------------------------------------------------------------------
4074
!> Gets a integer array from the list.
4075
!------------------------------------------------------------------------------
4076
RECURSIVE FUNCTION ListGetIntegerArray( List,Name,Found,UnfoundFatal ) RESULT( IValues )
4077
!------------------------------------------------------------------------------
4078
TYPE(ValueList_t), POINTER :: List
4079
CHARACTER(LEN=*) :: Name
4080
LOGICAL, OPTIONAL :: Found, UnfoundFatal
4081
!------------------------------------------------------------------------------
4082
TYPE(ValueListEntry_t), POINTER :: ptr
4083
INTEGER :: i,n
4084
INTEGER, POINTER :: IValues(:)
4085
!------------------------------------------------------------------------------
4086
NULLIFY( IValues )
4087
ptr => ListFind(List,Name,Found)
4088
IF (.NOT.ASSOCIATED(ptr) ) THEN
4089
IF(PRESENT(UnfoundFatal)) THEN
4090
IF(UnfoundFatal) THEN
4091
WRITE(Message, '(A,A)') "Failed to find integer array: ",Name
4092
CALL Fatal("ListGetIntegerArray", Message)
4093
END IF
4094
END IF
4095
RETURN
4096
END IF
4097
4098
IF ( .NOT. ASSOCIATED(ptr % IValues) ) THEN
4099
CALL Fatal( 'ListGetIntegerArray', 'Value type for property ['//TRIM(Name)//&
4100
'] not used consistently.')
4101
END IF
4102
4103
n = SIZE(ptr % IValues)
4104
IValues => Ptr % IValues(1:n)
4105
4106
IF ( ptr % PROCEDURE /= 0 ) THEN
4107
CALL ListPushActiveName(Name)
4108
IValues = 0
4109
DO i=1,N
4110
Ivalues(i) = ExecIntFunction( ptr % PROCEDURE, CurrentModel )
4111
END DO
4112
CALL ListPopActiveName()
4113
END IF
4114
!------------------------------------------------------------------------------
4115
END FUNCTION ListGetIntegerArray
4116
!------------------------------------------------------------------------------
4117
4118
4119
!------------------------------------------------------------------------------
4120
!> Check whether the keyword is associated to an integer or real array.
4121
!------------------------------------------------------------------------------
4122
RECURSIVE FUNCTION ListCheckIsArray( List,Name,Found ) RESULT( IsArray )
4123
!------------------------------------------------------------------------------
4124
TYPE(ValueList_t), POINTER :: List
4125
CHARACTER(LEN=*) :: Name
4126
LOGICAL, OPTIONAL :: Found
4127
LOGICAL :: IsArray
4128
!------------------------------------------------------------------------------
4129
TYPE(ValueListEntry_t), POINTER :: ptr
4130
INTEGER :: n
4131
!------------------------------------------------------------------------------
4132
4133
ptr => ListFind(List,Name,Found)
4134
IsArray = .FALSE.
4135
IF(.NOT. ASSOCIATED( ptr ) ) RETURN
4136
4137
n = 0
4138
IF ( ASSOCIATED(ptr % IValues) ) THEN
4139
n = SIZE(ptr % IValues)
4140
END IF
4141
IF( ASSOCIATED( ptr % FValues ) ) THEN
4142
n = SIZE(ptr % FValues)
4143
END IF
4144
4145
IsArray = ( n > 1 )
4146
4147
!------------------------------------------------------------------------------
4148
END FUNCTION ListCheckIsArray
4149
!------------------------------------------------------------------------------
4150
4151
4152
4153
!------------------------------------------------------------------------------
4154
!> Gets a logical value from the list, if not found return False.
4155
!------------------------------------------------------------------------------
4156
RECURSIVE FUNCTION ListGetLogical( List,Name,Found,UnfoundFatal,DefValue ) RESULT(L)
4157
!------------------------------------------------------------------------------
4158
TYPE(ValueList_t), POINTER :: List
4159
CHARACTER(LEN=*) :: Name
4160
LOGICAL :: L
4161
LOGICAL, OPTIONAL :: Found, UnfoundFatal, DefValue
4162
!------------------------------------------------------------------------------
4163
TYPE(ValueListEntry_t), POINTER :: ptr
4164
!------------------------------------------------------------------------------
4165
IF(PRESENT(DefValue)) THEN
4166
L = DefValue
4167
ELSE
4168
L = .FALSE.
4169
END IF
4170
4171
ptr => ListFind(List,Name,Found)
4172
IF (.NOT.ASSOCIATED(ptr) ) THEN
4173
IF(PRESENT(UnfoundFatal)) THEN
4174
IF(UnfoundFatal) THEN
4175
WRITE(Message, '(A,A)') "Failed to find logical: ",Name
4176
CALL Fatal("ListGetLogical", Message)
4177
END IF
4178
END IF
4179
RETURN
4180
END IF
4181
4182
IF(ptr % TYPE == LIST_TYPE_LOGICAL ) THEN
4183
L = ptr % Lvalue
4184
ELSE
4185
CALL Fatal('ListGetLogical','Invalid list type for: '//TRIM(Name))
4186
END IF
4187
4188
!------------------------------------------------------------------------------
4189
END FUNCTION ListGetLogical
4190
!------------------------------------------------------------------------------
4191
4192
4193
4194
!------------------------------------------------------------------------------
4195
!> A generalized version of ListGetLogical. Uses logical, only if the keyword is
4196
!> of type locical, if the type is real it return True for positive values,
4197
!> and otherwise returns True IF the keyword is present.
4198
!> Since the absence if a sign of False there is no separate Found flag.
4199
!------------------------------------------------------------------------------
4200
RECURSIVE FUNCTION ListGetLogicalGen( List, Name) RESULT(L)
4201
!------------------------------------------------------------------------------
4202
TYPE(ValueList_t), POINTER :: List
4203
CHARACTER(LEN=*) :: Name
4204
LOGICAL :: L
4205
!------------------------------------------------------------------------------
4206
TYPE(ValueListEntry_t), POINTER :: ptr
4207
LOGICAL :: Found
4208
REAL(KIND=dp) :: Rval
4209
!------------------------------------------------------------------------------
4210
4211
L = .FALSE.
4212
4213
ptr => ListFind(List,Name,Found)
4214
IF ( .NOT. ASSOCIATED(ptr) ) RETURN
4215
4216
IF(ptr % TYPE == LIST_TYPE_LOGICAL ) THEN
4217
L = ptr % Lvalue
4218
4219
ELSE IF ( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR .OR. &
4220
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_STR .OR. &
4221
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN
4222
4223
RVal = ListGetConstReal( List, Name )
4224
L = ( RVal > 0.0_dp )
4225
ELSE
4226
L = .TRUE.
4227
!Mere presence implies true mask
4228
!CALL Fatal('ListGetLogicalGen','Invalid list type for: '//TRIM(Name))
4229
END IF
4230
4231
!------------------------------------------------------------------------------
4232
END FUNCTION ListGetLogicalGen
4233
!------------------------------------------------------------------------------
4234
4235
4236
4237
!------------------------------------------------------------------------------
4238
!> Gets a string from the list by its name, if not found return empty string.
4239
!------------------------------------------------------------------------------
4240
RECURSIVE FUNCTION ListGetString( List,Name,Found,UnfoundFatal,DefValue ) RESULT(S)
4241
!------------------------------------------------------------------------------
4242
TYPE(ValueList_t), POINTER :: List
4243
CHARACTER(LEN=*) :: Name
4244
LOGICAL, OPTIONAL :: Found,UnfoundFatal
4245
CHARACTER(:), ALLOCATABLE :: S
4246
CHARACTER(*), OPTIONAL :: DefValue
4247
!------------------------------------------------------------------------------
4248
TYPE(ValueListEntry_t), POINTER :: ptr
4249
!------------------------------------------------------------------------------
4250
S = ' '
4251
IF(PRESENT(DefValue)) S = TRIM(DefValue)
4252
4253
ptr => ListFind(List,Name,Found)
4254
IF (.NOT.ASSOCIATED(ptr) ) THEN
4255
IF(PRESENT(UnfoundFatal)) THEN
4256
IF(UnfoundFatal) THEN
4257
WRITE(Message, '(A,A)') "Failed to find string: ",Name
4258
CALL Fatal("ListGetString", Message)
4259
END IF
4260
END IF
4261
RETURN
4262
END IF
4263
4264
IF( ptr % Type == LIST_TYPE_STRING ) THEN
4265
S = TRIM(ptr % Cvalue)
4266
ELSE
4267
CALL Fatal('ListGetString','Invalid list type: '//TRIM(Name))
4268
END IF
4269
!------------------------------------------------------------------------------
4270
END FUNCTION ListGetString
4271
!------------------------------------------------------------------------------
4272
4273
!------------------------------------------------------------------------------
4274
!> Get a constant real from the list by its name.
4275
!------------------------------------------------------------------------------
4276
RECURSIVE FUNCTION ListGetConstReal( List,Name,Found,x,y,z,minv,maxv,UnfoundFatal,DefValue) RESULT(F)
4277
!------------------------------------------------------------------------------
4278
TYPE(ValueList_t), POINTER :: List
4279
CHARACTER(LEN=*) :: Name
4280
REAL(KIND=dp) :: F
4281
LOGICAL, OPTIONAL :: Found,UnfoundFatal
4282
REAL(KIND=dp), OPTIONAL :: x,y,z,DefValue
4283
REAL(KIND=dp), OPTIONAL :: minv,maxv
4284
!------------------------------------------------------------------------------
4285
TYPE(Variable_t), POINTER :: Variable
4286
TYPE(ValueListEntry_t), POINTER :: ptr
4287
REAL(KIND=dp) :: xx,yy,zz
4288
INTEGER :: i,j,k,n
4289
!------------------------------------------------------------------------------
4290
IF(PRESENT(DefValue)) THEN
4291
F = DefValue
4292
ELSE
4293
F = 0.0_dp
4294
END IF
4295
4296
ptr => ListFind(List,Name,Found)
4297
IF (.NOT.ASSOCIATED(ptr) ) THEN
4298
IF(PRESENT(UnfoundFatal)) THEN
4299
IF(UnfoundFatal) THEN
4300
WRITE(Message, '(A,A)') "Failed to find constant real: ",Name
4301
CALL Fatal("ListGetConstReal", Message)
4302
END IF
4303
END IF
4304
RETURN
4305
END IF
4306
4307
SELECT CASE(ptr % TYPE)
4308
4309
CASE( LIST_TYPE_CONSTANT_SCALAR )
4310
4311
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
4312
CALL Fatal( 'ListGetConstReal', 'Value type for property ['//TRIM(Name)//&
4313
'] not used consistently.')
4314
END IF
4315
F = ptr % Coeff * ptr % Fvalues(1,1,1)
4316
4317
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
4318
4319
F = ptr % Coeff * GetMatcReal(ptr % Cvalue)
4320
4321
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
4322
4323
IF ( ptr % PROCEDURE == 0 ) THEN
4324
CALL Fatal( 'ListGetConstReal', 'Value type for property ['//TRIM(Name)//&
4325
'] not used consistently.')
4326
END IF
4327
4328
xx = 0.0_dp
4329
yy = 0.0_dp
4330
zz = 0.0_dp
4331
IF ( PRESENT(x) ) xx = x
4332
IF ( PRESENT(y) ) yy = y
4333
IF ( PRESENT(z) ) zz = z
4334
CALL ListPushActiveName(Name)
4335
F = Ptr % Coeff * &
4336
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,xx,yy,zz )
4337
CALL ListPopActiveName()
4338
4339
CASE( LIST_TYPE_VARIABLE_SCALAR, LIST_TYPE_VARIABLE_SCALAR_STR )
4340
CALL Fatal('ListGetConstReal','Constant cannot depend on variables: '//TRIM(Name))
4341
4342
CASE DEFAULT
4343
CALL Fatal('ListGetConstReal','Invalid list type for: '//TRIM(Name))
4344
4345
END SELECT
4346
4347
IF ( PRESENT( minv ) ) THEN
4348
IF ( F < minv ) THEN
4349
WRITE( Message, *) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', &
4350
' smaller than given minimum: ', minv
4351
CALL Fatal( 'ListGetInteger', Message )
4352
END IF
4353
END IF
4354
4355
IF ( PRESENT( maxv ) ) THEN
4356
IF ( F > maxv ) THEN
4357
WRITE( Message, *) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', &
4358
' larger than given maximum: ', maxv
4359
CALL Fatal( 'ListGetInteger', Message )
4360
END IF
4361
END IF
4362
!------------------------------------------------------------------------------
4363
END FUNCTION ListGetConstReal
4364
!------------------------------------------------------------------------------
4365
4366
4367
!------------------------------------------------------------------------------
4368
!> Returns a scalar real value, that may depend on other scalar values such as
4369
!> time or timestep size etc.
4370
!------------------------------------------------------------------------------
4371
RECURSIVE FUNCTION ListGetCReal( List, Name, Found, minv, maxv, UnfoundFatal, DefValue ) RESULT(s)
4372
!------------------------------------------------------------------------------
4373
TYPE(ValueList_t), POINTER :: List
4374
CHARACTER(LEN=*) :: Name
4375
REAL(KIND=dp), OPTIONAL :: minv,maxv
4376
LOGICAL, OPTIONAL :: Found,UnfoundFatal
4377
INTEGER, TARGET :: Dnodes(1)
4378
INTEGER, POINTER :: NodeIndexes(:)
4379
REAL(KIND=dp), OPTIONAL :: DefValue
4380
4381
REAL(KIND=dp) :: s
4382
REAL(KIND=dp) :: x(1)
4383
TYPE(Element_t), POINTER :: Element
4384
LOGICAL :: LFound
4385
4386
INTEGER :: n, istat
4387
4388
LFound = .FALSE.
4389
NodeIndexes => Dnodes
4390
n = 1
4391
NodeIndexes(n) = 1
4392
4393
x = 0.0_dp
4394
IF ( ASSOCIATED(List % head) ) THEN
4395
x(1:n) = ListGetReal( List, Name, n, NodeIndexes, LFound, minv=minv, maxv=maxv, &
4396
UnfoundFatal=UnfoundFatal )
4397
END IF
4398
s = x(1)
4399
4400
IF( PRESENT( DefValue ) ) THEN
4401
IF(.NOT. LFound ) s = DefValue
4402
END IF
4403
4404
IF ( PRESENT( Found ) ) Found = LFound
4405
4406
!------------------------------------------------------------------------------
4407
END FUNCTION ListGetCReal
4408
!------------------------------------------------------------------------------
4409
4410
!------------------------------------------------------------------------------
4411
!> Returns a scalar real value, that may depend on other scalar values such as
4412
!> time or timestep size etc.
4413
!------------------------------------------------------------------------------
4414
RECURSIVE FUNCTION ListGetRealAtNode( List, Name, Node, Found, UnfoundFatal ) RESULT(s)
4415
!------------------------------------------------------------------------------
4416
TYPE(ValueList_t), POINTER :: List
4417
CHARACTER(LEN=*) :: Name
4418
INTEGER :: Node
4419
LOGICAL, OPTIONAL :: Found, UnfoundFatal
4420
REAL(KIND=dp) :: s
4421
!-----------------------------------------------------------------------------
4422
INTEGER, TARGET, SAVE :: Dnodes(1)
4423
INTEGER, POINTER :: NodeIndexes(:)
4424
REAL(KIND=dp) :: x(1)
4425
INTEGER, PARAMETER :: one = 1
4426
4427
!$omp threadprivate(Dnodes)
4428
4429
4430
IF ( PRESENT( Found ) ) Found = .FALSE.
4431
4432
IF ( ASSOCIATED(List % Head) ) THEN
4433
NodeIndexes => Dnodes
4434
NodeIndexes(one) = Node
4435
4436
x(1:one) = ListGetReal( List, Name, one, NodeIndexes, Found, UnfoundFatal=UnfoundFatal)
4437
s = x(one)
4438
ELSE
4439
s = 0.0_dp
4440
END IF
4441
4442
!------------------------------------------------------------------------------
4443
END FUNCTION ListGetRealAtNode
4444
!------------------------------------------------------------------------------
4445
4446
4447
!> Get pointer to list of section
4448
!------------------------------------------------------------------------------
4449
FUNCTION ListGetSection( Element, SectionName, Found ) RESULT(lst)
4450
!------------------------------------------------------------------------------
4451
TYPE(ValueList_t), POINTER :: Lst
4452
CHARACTER(LEN=*) :: SectionName
4453
LOGICAL, OPTIONAL :: Found
4454
TYPE(Element_t) :: Element
4455
!------------------------------------------------------------------------------
4456
TYPE(ValueList_t), POINTER :: BodyLst
4457
INTEGER :: id
4458
LOGICAL :: LFound
4459
4460
id = Element % BodyId
4461
IF( id > 0 ) THEN
4462
bodylst => CurrentModel % Bodies(id) % Values
4463
ELSE
4464
NULLIFY( bodylst )
4465
END IF
4466
LFound = .FALSE.
4467
4468
NULLIFY( lst )
4469
4470
SELECT CASE ( SectionName )
4471
4472
CASE( 'body' )
4473
lst => bodylst
4474
Lfound = ASSOCIATED( lst )
4475
4476
CASE( 'material' )
4477
id = ListGetInteger( bodylst, SectionName, LFound )
4478
IF( LFound ) lst => CurrentModel % Materials(id) % Values
4479
4480
CASE( 'body force' )
4481
id = ListGetInteger( bodylst, SectionName, LFound )
4482
IF( LFound ) lst => CurrentModel % BodyForces(id) % Values
4483
4484
CASE( 'initial condition' )
4485
id = ListGetInteger( bodylst, SectionName, LFound )
4486
IF( LFound ) lst => CurrentModel % ICs(id) % Values
4487
4488
CASE( 'equation' )
4489
id = ListGetInteger( bodylst, SectionName, LFound )
4490
IF( LFound ) lst => CurrentModel % Equations(id) % Values
4491
4492
CASE( 'boundary condition' )
4493
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
4494
id = Element % BoundaryInfo % Constraint
4495
IF( id > 0 ) THEN
4496
lst => CurrentModel % BCs(id) % Values
4497
LFound = .TRUE.
4498
END IF
4499
END IF
4500
4501
CASE DEFAULT
4502
CALL Fatal('ListGetSection','Unknown section name: '//TRIM(SectionName))
4503
4504
END SELECT
4505
4506
IF( PRESENT( Found ) ) Found = LFound
4507
4508
!------------------------------------------------------------------------------
4509
END FUNCTION ListGetSection
4510
!------------------------------------------------------------------------------
4511
4512
4513
SUBROUTINE ListWarnUnsupportedKeyword( SectionName, Keyword, Found, FatalFound )
4514
4515
CHARACTER(LEN=*) :: SectionName, Keyword
4516
4517
LOGICAL, OPTIONAL :: Found, FatalFound
4518
LOGICAL :: LFound, LFatal
4519
INTEGER :: k
4520
CHARACTER(LEN=LEN(SectionName)) :: str
4521
4522
k = StringToLowerCase( str,SectionName )
4523
4524
LFatal = .FALSE.
4525
IF( PRESENT( FatalFound ) ) LFatal = FatalFound
4526
4527
SELECT CASE ( str ) !TRIM( str ) )
4528
4529
CASE( 'body' )
4530
LFound = ListCheckPresentAnyBody( CurrentModel, Keyword )
4531
4532
CASE( 'material' )
4533
LFound = ListCheckPresentAnyMaterial( CurrentModel, Keyword )
4534
4535
CASE( 'body force' )
4536
LFound = ListCheckPresentAnyBodyForce( CurrentModel, Keyword )
4537
4538
CASE( 'solver' )
4539
LFound = ListCheckPresentAnySolver( CurrentModel, Keyword )
4540
4541
CASE( 'equation' )
4542
LFound = ListCheckPresentAnyEquation( CurrentModel, Keyword )
4543
4544
CASE( 'boundary condition' )
4545
LFound = ListCheckPresentAnyBC( CurrentModel, Keyword )
4546
4547
CASE( 'simulation' )
4548
LFound = ListCheckPresent( CurrentModel % Simulation, Keyword )
4549
4550
CASE( 'constants' )
4551
LFound = ListCheckPresent( CurrentModel % Constants, Keyword )
4552
4553
CASE DEFAULT
4554
CALL Fatal('ListWarnUnsupportedKeyword',&
4555
'Unknown section for "'//TRIM(Keyword)//'": '//TRIM(SectionName))
4556
4557
END SELECT
4558
4559
IF( LFound ) THEN
4560
IF( LFatal ) THEN
4561
CALL Fatal('ListWarnUnsupportedKeyword',&
4562
'Keyword in section "'//TRIM(SectionName)//'" not supported: '//TRIM(Keyword) )
4563
ELSE
4564
CALL Warn('ListWarnUnsupportedKeyword',&
4565
'Keyword in section "'//TRIM(SectionName)//'" not supported: '//TRIM(Keyword) )
4566
END IF
4567
END IF
4568
4569
IF( PRESENT( Found ) ) Found = LFound
4570
4571
END SUBROUTINE ListWarnUnsupportedKeyword
4572
4573
4574
4575
!> Get pointer to list of section
4576
!------------------------------------------------------------------------------
4577
FUNCTION ListGetSectionId( Element, SectionName, Found ) RESULT(id)
4578
!------------------------------------------------------------------------------
4579
INTEGER :: id
4580
CHARACTER(LEN=*) :: SectionName
4581
LOGICAL, OPTIONAL :: Found
4582
TYPE(Element_t) :: Element
4583
!------------------------------------------------------------------------------
4584
TYPE(ValueList_t), POINTER :: BodyLst
4585
INTEGER :: body_id
4586
LOGICAL :: LFound
4587
4588
id = 0
4589
4590
body_id = Element % BodyId
4591
IF( body_id > 0 ) THEN
4592
bodylst => CurrentModel % Bodies(body_id) % Values
4593
ELSE
4594
NULLIFY( bodylst )
4595
END IF
4596
LFound = .FALSE.
4597
4598
SELECT CASE ( SectionName )
4599
4600
CASE( 'body' )
4601
id = body_id
4602
4603
CASE( 'material' )
4604
id = ListGetInteger( bodylst, SectionName, LFound )
4605
4606
CASE( 'body force' )
4607
id = ListGetInteger( bodylst, SectionName, LFound )
4608
4609
CASE( 'initial condition' )
4610
id = ListGetInteger( bodylst, SectionName, LFound )
4611
4612
CASE( 'equation' )
4613
id = ListGetInteger( bodylst, SectionName, LFound )
4614
4615
CASE( 'boundary condition' )
4616
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
4617
id = Element % BoundaryInfo % Constraint
4618
END IF
4619
4620
CASE DEFAULT
4621
CALL Fatal('ListGetSection','Unknown section name: '//TRIM(SectionName))
4622
4623
END SELECT
4624
4625
IF( PRESENT( Found ) ) Found = ( id > 0 )
4626
4627
!------------------------------------------------------------------------------
4628
END FUNCTION ListGetSectionId
4629
!------------------------------------------------------------------------------
4630
4631
4632
4633
!------------------------------------------------------------------------------
4634
!> Given a string containing comma-separated variablenames, reads the strings
4635
!> and obtains the corresponding variables to a table.
4636
!------------------------------------------------------------------------------
4637
SUBROUTINE ListParseStrToVars( str, slen, name, count, VarTable, &
4638
SomeAtIp, SomeAtNodes, AllGlobal, DummyCount, List )
4639
!------------------------------------------------------------------------------
4640
CHARACTER(LEN=*) :: str, name
4641
INTEGER :: slen, count
4642
TYPE(VariableTable_t) :: VarTable(:)
4643
LOGICAL :: SomeAtIp, SomeAtNodes, AllGlobal
4644
INTEGER :: DummyCount
4645
TYPE(ValueList_t), POINTER, OPTIONAL :: List
4646
!------------------------------------------------------------------------------
4647
INTEGER :: i,j,k,n,k1,l,l0,l1
4648
TYPE(Variable_t), POINTER :: Var
4649
REAL(KIND=dp) :: Val
4650
LOGICAL :: Found
4651
TYPE(ValueListEntry_t), POINTER :: ptr
4652
4653
SomeAtIp = .FALSE.
4654
SomeAtNodes = .FALSE.
4655
AllGlobal = .TRUE.
4656
4657
count=0
4658
l0=1
4659
IF(slen<=0) RETURN
4660
4661
DO WHILE( .TRUE. )
4662
! Remove zeros ahead
4663
DO WHILE( str(l0:l0) == ' ' )
4664
l0 = l0 + 1
4665
IF ( l0 > slen ) EXIT
4666
END DO
4667
IF ( l0 > slen ) EXIT
4668
4669
! Scan only until next comma
4670
l1 = INDEX( str(l0:slen),',')
4671
IF ( l1 > 0 ) THEN
4672
l1=l0+l1-2
4673
ELSE
4674
l1=slen
4675
END IF
4676
4677
! This is a special case of internal variables that should not be parsed
4678
! to point to actual variables.
4679
IF( count < DummyCount ) THEN
4680
Var => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) )
4681
IF(ASSOCIATED(Var)) THEN
4682
CALL Fatal('ListParseStrToVars','Function has '//I2S(DummyCount)//&
4683
' internal variables, use dummy names not: '//str(l0:l1))
4684
END IF
4685
AllGlobal = .FALSE.
4686
count = count + 1
4687
SomeAtIp = .TRUE.
4688
VarTable(count) % Variable => NULL()
4689
VarTable(count) % ParamValue = -1.0_dp
4690
ELSE IF ( str(l0:l1) == 'coordinate' ) THEN
4691
VarTable(count+1) % Variable => VariableGet( CurrentModel % Variables,"coordinate 1")
4692
VarTable(count+2) % Variable => VariableGet( CurrentModel % Variables,"coordinate 2")
4693
VarTable(count+3) % Variable => VariableGet( CurrentModel % Variables,"coordinate 3")
4694
count = count + 3
4695
SomeAtNodes = .TRUE.
4696
AllGlobal = .FALSE.
4697
ELSE
4698
Found = .FALSE.
4699
Var => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) )
4700
count = count + 1
4701
IF ( ASSOCIATED( Var ) ) THEN
4702
VarTable(count) % Variable => Var
4703
IF( SIZE( Var % Values ) > Var % Dofs ) AllGlobal = .FALSE.
4704
IF( Var % TYPE == Variable_on_gauss_points ) THEN
4705
SomeAtIp = .TRUE.
4706
ELSE
4707
SomeAtNodes = .TRUE.
4708
END IF
4709
Found = .TRUE.
4710
ELSE IF(l1-l0 > 5) THEN
4711
IF(str(l0:l0+4) == 'prev ') THEN
4712
Var => VariableGet( CurrentModel % Variables,TRIM(str(l0+5:l1)) )
4713
IF( ASSOCIATED( Var ) ) THEN
4714
VarTable(count) % Variable => Var
4715
VarTable(count) % tstep = -1
4716
IF( SIZE( Var % Values ) > Var % Dofs ) AllGlobal = .FALSE.
4717
IF( Var % TYPE == Variable_on_gauss_points ) THEN
4718
SomeAtIp = .TRUE.
4719
ELSE
4720
SomeAtNodes = .TRUE.
4721
END IF
4722
Found = .TRUE.
4723
END IF
4724
END IF
4725
END IF
4726
4727
! Ok, the string was not a variable name maybe it is a pure number
4728
! or another keytword.
4729
IF(.NOT. Found) THEN
4730
IF( VERIFY( str(l0:l1),'-.0123456789eE') == 0 ) THEN
4731
!PRINT *,'We do have a number:',Val
4732
READ(str(l0:l1),*) Val
4733
VarTable(count) % Variable => NULL()
4734
VarTable(count) % ParamValue = Val
4735
ELSE
4736
! Check if the dependency is actually a keyword
4737
Found = .FALSE.
4738
IF(PRESENT(List) ) THEN
4739
ptr => ListFind(List,str(l0:l1),Found)
4740
END IF
4741
IF( Found ) THEN
4742
VarTable(count) % Keyword => ptr
4743
AllGlobal = .FALSE.
4744
SomeAtNodes = .TRUE.
4745
ELSE
4746
CALL Info('ListParseStrToVars','Parsed variable '//I2S(count)//' of '//str(1:slen),Level=3)
4747
CALL Info('ListParseStrToVars','Parse counters: '&
4748
//I2S(l0)//', '//I2S(l1)//', '//I2S(slen),Level=10)
4749
CALL Fatal('ListParseStrToVars', 'Can''t find independent variable:['// &
4750
TRIM(str(l0:l1))//'] for dependent variable:['//TRIM(Name)//']' )
4751
END IF
4752
END IF
4753
END IF
4754
END IF
4755
4756
! New start after the comma
4757
l0 = l1+2
4758
IF ( l0 > slen ) EXIT
4759
END DO
4760
4761
!------------------------------------------------------------------------------
4762
END SUBROUTINE ListParseStrToVars
4763
!------------------------------------------------------------------------------
4764
4765
!-------------------------------------------------------------------------------------
4766
!> Given a table of variables and a node index return the variable values on the node.
4767
!-------------------------------------------------------------------------------------
4768
RECURSIVE SUBROUTINE VarsToValuesOnNodes( VarCount, VarTable, ind, T, count, intvarcount, tStep )
4769
!------------------------------------------------------------------------------
4770
INTEGER :: Varcount
4771
TYPE(VariableTable_t) :: VarTable(:)
4772
INTEGER :: ind
4773
INTEGER :: count
4774
INTEGER, OPTIONAL :: intvarcount
4775
INTEGER, OPTIONAL :: tstep
4776
REAL(KIND=dp) :: T(:)
4777
!------------------------------------------------------------------------------
4778
TYPE(Element_t), POINTER :: Element
4779
INTEGER :: i,j,k,n,k1,l,varsize,vari,vari0,tstep0,dti
4780
TYPE(Variable_t), POINTER :: Var
4781
LOGICAL :: Failed
4782
REAL(KIND=dp), POINTER :: Values(:)
4783
4784
Failed = .FALSE.
4785
4786
! Do not even try to treat the internal variables
4787
vari0 = 0
4788
IF(PRESENT(intvarcount)) vari0 = IntVarCount
4789
count = vari0
4790
4791
tstep0 = 0
4792
IF(PRESENT(tstep)) tstep0 = tstep
4793
4794
DO Vari = vari0+1, VarCount
4795
4796
Var => VarTable(Vari) % Variable
4797
! If we are asked keyword on previous timestep, then previous for that is 2nd previous...
4798
dti = -(tstep0 + VarTable(Vari) % tstep)
4799
4800
IF(.NOT. ASSOCIATED( Var ) ) THEN
4801
count = count + 1
4802
IF(ASSOCIATED( VarTable(Vari) % Keyword ) ) THEN
4803
T(count) = ListGetRealInside( VarTable(Vari) % Keyword,'',ind)
4804
ELSE
4805
T(count) = VarTable(Vari) % ParamValue
4806
END IF
4807
CYCLE
4808
END IF
4809
4810
Varsize = SIZE( Var % Values ) / Var % Dofs
4811
4812
IF( Varsize == 1 ) THEN
4813
DO l=1,Var % DOFs
4814
count = count + 1
4815
T(count) = Var % Values(l)
4816
END DO
4817
ELSE
4818
k1 = ind
4819
4820
IF ( Var % TYPE == Variable_on_gauss_points ) THEN
4821
count = count + Var % DOFs
4822
CYCLE
4823
ELSE IF( Var % TYPE == Variable_on_elements ) THEN
4824
Element => CurrentModel % CurrentElement
4825
IF( ASSOCIATED( Element ) ) THEN
4826
k1 = Element % ElementIndex
4827
ELSE
4828
CALL Fatal('VarsToValuesOnNodes','CurrentElement not associated!')
4829
END IF
4830
ELSE IF ( Var % TYPE == Variable_on_nodes_on_elements ) THEN
4831
Element => CurrentModel % CurrentElement
4832
IF ( ASSOCIATED(Element) ) THEN
4833
k1 = 0
4834
IF ( ASSOCIATED(Element % DGIndexes) ) THEN
4835
n = SIZE(Element % DGIndexes)
4836
DO i=1,n
4837
IF ( Element % NodeIndexes(i)==ind ) THEN
4838
k1 = Element % DGIndexes(i)
4839
EXIT
4840
END IF
4841
END DO
4842
ELSE IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
4843
BLOCK
4844
TYPE(Element_t), POINTER :: Parent
4845
DO j=1,2
4846
IF(j==1) THEN
4847
Parent => Element % BoundaryInfo % Left
4848
ELSE
4849
Parent => Element % BoundaryInfo % Right
4850
END IF
4851
DO i=1,Parent % TYPE % NumberOfNodes
4852
IF( Parent % NodeIndexes(i) == ind) THEN
4853
k1 = Parent % DGIndexes(i)
4854
EXIT
4855
END IF
4856
END DO
4857
IF( k1 > 0 ) THEN
4858
IF(Var % Perm(k1) > 0) EXIT
4859
END IF
4860
END DO
4861
END BLOCK
4862
END IF
4863
IF( k1 == 0 ) THEN
4864
CALL Fatal('VarsToValueOnNodes','Could not find index '//I2S(ind)//&
4865
' in element '//I2S(Element % ElementIndex)//' for '//TRIM(Var % Name))
4866
END IF
4867
ELSE
4868
CALL Fatal('VarsToValuesOnNodes','CurrentElement not associated!')
4869
END IF
4870
END IF
4871
4872
IF ( ASSOCIATED(Var % Perm) ) k1 = Var % Perm(k1)
4873
4874
IF ( k1 > 0 .AND. k1 <= VarSize ) THEN
4875
Values => Var % Values
4876
IF( dti > 0 ) THEN
4877
IF ( ASSOCIATED(Var % PrevValues) ) THEN
4878
IF ( dti <= SIZE(Var % PrevValues,2)) &
4879
Values => Var % PrevValues(:,dti)
4880
END IF
4881
END IF
4882
DO l=1,Var % DOFs
4883
count = count + 1
4884
T(count) = Values(Var % Dofs*(k1-1)+l)
4885
END DO
4886
ELSE
4887
Failed = .TRUE.
4888
DO l=1,Var % DOFs
4889
count = count + 1
4890
T(count) = HUGE(1.0_dp)
4891
END DO
4892
RETURN
4893
END IF
4894
END IF
4895
END DO
4896
4897
END SUBROUTINE VarsToValuesOnNodes
4898
!------------------------------------------------------------------------------
4899
4900
4901
!-------------------------------------------------------------------------------------
4902
!> Check which variables actually are on nodal ones.
4903
!> Didn't want to crowd the previous routine.
4904
!-------------------------------------------------------------------------------------
4905
SUBROUTINE VarsToValuesOnNodesWhich( VarCount, VarTable, IsNodalVar, count )
4906
!------------------------------------------------------------------------------
4907
INTEGER :: Varcount
4908
TYPE(VariableTable_t) :: VarTable(:)
4909
INTEGER :: count
4910
LOGICAL :: IsNodalVar(:)
4911
!------------------------------------------------------------------------------
4912
INTEGER :: vari
4913
TYPE(Variable_t), POINTER :: Var
4914
LOGICAL :: Failed
4915
4916
count = 0
4917
4918
DO Vari = 1, VarCount
4919
Var => VarTable(Vari) % Variable
4920
4921
IF(.NOT. ASSOCIATED( Var ) ) THEN
4922
count = count + 1
4923
IsNodalVar(count) = .FALSE.
4924
ELSE IF( SIZE(Var % Values) / Var % Dofs == 1 ) THEN
4925
IsNodalVar(count+1:count+var % dofs) = .FALSE.
4926
count = count + var % dofs
4927
ELSE
4928
IF ( Var % TYPE == Variable_on_gauss_points ) THEN
4929
IsNodalVar(count+1:count+var%dofs) = .FALSE.
4930
count = count + Var % DOFs
4931
ELSE
4932
IsNodalVar(count+1:count+var%dofs) = .TRUE.
4933
count = count + Var % DOFs
4934
END IF
4935
END IF
4936
END DO
4937
4938
END SUBROUTINE VarsToValuesOnNodesWhich
4939
!------------------------------------------------------------------------------
4940
4941
4942
4943
!------------------------------------------------------------------------------
4944
!> Some variable may be given on the IP points of the bullk only. In that case
4945
!> we need to solve a small linear system in each element to map the values to
4946
!> the nodes, and further to the integration point defined by Basis.
4947
!------------------------------------------------------------------------------
4948
FUNCTION InterpolateIPVariableToBoundary( Element, Basis, Var, dof ) RESULT ( T )
4949
!------------------------------------------------------------------------------
4950
TYPE(Element_t), POINTER :: Element
4951
REAL(KIND=dp) :: Basis(:)
4952
TYPE(Variable_t), POINTER :: Var
4953
INTEGER, OPTIONAL :: dof
4954
REAL(KIND=dp) :: T
4955
!------------------------------------------------------------------------------
4956
TYPE(Element_t), POINTER :: Parent
4957
INTEGER :: ipar, npar, i, j, n, np, nip, dofs
4958
REAL(KIND=dp), ALLOCATABLE :: fip(:),fdg(:)
4959
4960
! We have to provide interface for this as otherwise we would create a
4961
! cyclic dependence.
4962
INTERFACE
4963
SUBROUTINE Ip2DgFieldInElement( Mesh, Parent, nip, fip, np, fdg )
4964
USE Types
4965
TYPE(Mesh_t), POINTER :: Mesh
4966
TYPE(Element_t), POINTER :: Parent
4967
INTEGER :: nip, np
4968
REAL(KIND=dp) :: fip(:), fdg(:)
4969
END SUBROUTINE Ip2DgFieldInElement
4970
END INTERFACE
4971
4972
T = 0.0_dp
4973
n = Element % TYPE % NumberOfNodes
4974
npar = 0.0_dp
4975
dofs = Var % Dofs
4976
IF(dofs > 1) THEN
4977
IF(.NOT. PRESENT(dof)) THEN
4978
CALL Fatal('InterpolateIPVariableToBoundary','Give component of ip variable!')
4979
END IF
4980
END IF
4981
4982
! Go through both potential parents. If we find the information in both then
4983
! take on average. Otherwise use one-side interpolation.
4984
DO ipar = 1,2
4985
IF( ipar == 1 ) THEN
4986
Parent => Element % BoundaryInfo % Left
4987
ELSE
4988
Parent => Element % BoundaryInfo % Right
4989
END IF
4990
IF(.NOT. ASSOCIATED( Parent ) ) CYCLE
4991
4992
i = Parent % ElementIndex
4993
j = Var % Perm(i)
4994
nip = Var % Perm(i+1) - j
4995
IF( nip == 0 ) CYCLE
4996
np = Parent % TYPE % NumberOfNodes
4997
4998
ALLOCATE( fip(nip), fdg(np) )
4999
5000
IF( dofs > 1 ) THEN
5001
DO i=1,nip
5002
fip(i) = Var % Values(dofs*(j+i-1)+dof)
5003
END DO
5004
ELSE
5005
fip(1:nip) = Var % Values(j+1:j+nip)
5006
END IF
5007
fdg(1:np) = 0.0_dp
5008
5009
CALL Ip2DgFieldInElement( CurrentModel % Mesh, Parent, nip, fip, np, fdg )
5010
npar = npar + 1
5011
5012
! Use basis functions of the boundary to map stuff from nodes to IP points.
5013
DO i=1,n
5014
DO j=1,np
5015
IF( Element % NodeIndexes(i) == Parent % NodeIndexes(j) ) THEN
5016
T = T + Basis(i) * fdg(j)
5017
EXIT
5018
END IF
5019
END DO
5020
END DO
5021
5022
DEALLOCATE( fip, fdg )
5023
END DO
5024
5025
! Now take the average, if needed.
5026
IF( npar == 2 ) T = T / 2
5027
5028
END FUNCTION InterpolateIPVariableToBoundary
5029
!------------------------------------------------------------------------------
5030
5031
5032
5033
!-------------------------------------------------------------------------------------
5034
!> Given a table of variables return the variable values on the gauss point.
5035
!> This only deals with the gauss point variables, all other are already treated.
5036
!-------------------------------------------------------------------------------------
5037
SUBROUTINE VarsToValuesOnIps( VarCount, VarTable, T, count, ind, Basis, intvarcount, tstep)
5038
!------------------------------------------------------------------------------
5039
INTEGER :: Varcount
5040
TYPE(VariableTable_t) :: VarTable(:)
5041
INTEGER :: count
5042
REAL(KIND=dp) :: T(:)
5043
INTEGER, OPTIONAL :: ind
5044
REAL(KIND=dp), OPTIONAL :: Basis(:)
5045
INTEGER, OPTIONAL :: intvarcount
5046
INTEGER, OPTIONAL :: tstep
5047
!------------------------------------------------------------------------------
5048
TYPE(Element_t), POINTER :: Element
5049
INTEGER :: i,j,k,n,k1,l,varsize,vari,vari0,dti,tstep0
5050
TYPE(Variable_t), POINTER :: Var
5051
LOGICAL :: Failed
5052
REAL(KIND=dp), POINTER :: Values(:)
5053
5054
Failed = .FALSE.
5055
vari0 = 0
5056
IF( PRESENT(intvarcount)) THEN
5057
vari0 = intvarcount
5058
END IF
5059
count = vari0
5060
5061
tstep0 = 0
5062
IF(PRESENT(tstep)) tstep0 = tstep
5063
5064
DO Vari = vari0+1, VarCount
5065
5066
Var => VarTable(Vari) % Variable
5067
5068
IF(.NOT. ASSOCIATED( Var ) ) THEN
5069
count = count + 1
5070
T(count) = VarTable(Vari) % ParamValue
5071
CYCLE
5072
END IF
5073
5074
dti = -(tstep0 + VarTable(Vari) % tstep)
5075
Varsize = SIZE( Var % Values ) / Var % Dofs
5076
5077
k1 = 0
5078
IF ( Var % TYPE == Variable_on_gauss_points ) THEN
5079
Element => CurrentModel % CurrentElement
5080
i = Element % ElementIndex
5081
n = Var % Perm(i+1) - Var % Perm(i)
5082
5083
IF( n > 0 ) THEN
5084
IF(.NOT. PRESENT(ind) ) THEN
5085
CALL Fatal('VarsToValuesOnIPs','Ip field '//TRIM(Var % Name)//' given but no ip point given as parameter!')
5086
ELSE IF( n < ind ) THEN
5087
CALL Warn('VarsToValuesOnIPs','Too few integration points ('&
5088
//I2S(n)//' vs. '//I2S(ind)//') tabulated!')
5089
ELSE
5090
k1 = Var % Perm(i) + ind
5091
END IF
5092
ELSE
5093
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
5094
IF(.NOT. PRESENT(Basis) ) THEN
5095
CALL Fatal('VarsToValuesOnIps','We need the "Basis" parameter to map stuff to boundaries!')
5096
END IF
5097
IF( Var % Dofs > 1 ) THEN
5098
DO l=1,Var % Dofs
5099
T(count+l) = InterpolateIPVariableToBoundary( Element, Basis, Var, l )
5100
END DO
5101
ELSE
5102
T(count+1) = InterpolateIPVariableToBoundary( Element, Basis, Var )
5103
END IF
5104
ELSE
5105
CALL Warn('VarsToValuesOnIPs','Could not find dependent IP variable: '//TRIM(Var % Name))
5106
END IF
5107
END IF
5108
END IF
5109
5110
IF ( k1 > 0 ) THEN
5111
Values => Var % Values
5112
IF( dti > 0 ) THEN
5113
IF ( ASSOCIATED(Var % PrevValues) ) THEN
5114
IF ( dti <= SIZE(Var % PrevValues,2)) &
5115
Values => Var % PrevValues(:,dti)
5116
END IF
5117
END IF
5118
5119
DO l=1,Var % DOFs
5120
count = count + 1
5121
T(count) = Values(Var % Dofs*(k1-1)+l)
5122
END DO
5123
ELSE
5124
count = count + Var % Dofs
5125
END IF
5126
END DO
5127
5128
END SUBROUTINE VarsToValuesOnIps
5129
!------------------------------------------------------------------------------
5130
5131
5132
5133
!------------------------------------------------------------------------------
5134
SUBROUTINE ListParseStrToValues( str, slen, ind, name, T, count, AllGlobal )
5135
!------------------------------------------------------------------------------
5136
CHARACTER(LEN=*) :: str, name
5137
REAL(KIND=dp) :: T(:)
5138
INTEGER :: slen, count, ind
5139
LOGICAL :: AllGlobal
5140
!------------------------------------------------------------------------------
5141
TYPE(Element_t), POINTER :: Element
5142
INTEGER :: i,j,k,n,k1,l,l0,l1
5143
TYPE(Variable_t), POINTER :: Variable, CVar
5144
5145
AllGlobal = .TRUE.
5146
5147
count=0
5148
l0=1
5149
IF(slen<=0) RETURN
5150
5151
DO WHILE( .TRUE. )
5152
DO WHILE( str(l0:l0) == ' ' )
5153
l0 = l0 + 1
5154
IF ( l0 > slen ) EXIT
5155
END DO
5156
IF ( l0 > slen ) EXIT
5157
5158
l1 = INDEX( str(l0:slen),',')
5159
IF ( l1 > 0 ) THEN
5160
l1=l0+l1-2
5161
ELSE
5162
l1=slen
5163
END IF
5164
5165
IF ( str(l0:l1) /= 'coordinate' ) THEN
5166
Variable => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) )
5167
IF ( .NOT. ASSOCIATED( Variable ) ) THEN
5168
CALL Info('ListParseStrToValues','Parsed variable '//I2S(count+1)//' of '//str(1:slen),Level=3)
5169
CALL Info('ListParseStrToValues','Parse counters: '&
5170
//I2S(l0)//', '//I2S(l1)//', '//I2S(slen),Level=10)
5171
CALL Fatal('ListParseStrToValues','Can''t find independent variable:['// &
5172
TRIM(str(l0:l1))//'] for dependent variable:['//TRIM(Name)//']')
5173
END IF
5174
IF( SIZE( Variable % Values ) > Variable % Dofs ) AllGlobal = .FALSE.
5175
ELSE
5176
AllGlobal = .FALSE.
5177
Variable => VariableGet( CurrentModel % Variables,'Coordinate 1' )
5178
END IF
5179
5180
IF( Variable % TYPE == Variable_on_gauss_points ) THEN
5181
DO l=1,Variable % DOFs
5182
count = count + 1
5183
T(count) = HUGE(1.0_dp)
5184
END DO
5185
5186
l0 = l1+2
5187
IF ( l0 > slen ) EXIT
5188
CYCLE
5189
END IF
5190
5191
k1 = ind
5192
5193
IF ( Variable % TYPE == Variable_on_nodes_on_elements ) THEN
5194
Element => CurrentModel % CurrentElement
5195
IF ( ASSOCIATED(Element) ) THEN
5196
IF ( ASSOCIATED(Element % DGIndexes) ) THEN
5197
n = SIZE(Element % DGIndexes)
5198
DO i=1,n
5199
IF ( Element % NodeIndexes(i)==ind ) THEN
5200
k1 = Element % DGIndexes(i)
5201
EXIT
5202
END IF
5203
END DO
5204
END IF
5205
END IF
5206
END IF
5207
IF ( ASSOCIATED(Variable % Perm) ) k1 = Variable % Perm(k1)
5208
5209
IF ( k1>0 .AND. k1<=SIZE(Variable % Values) ) THEN
5210
IF ( str(l0:l1) == 'coordinate' ) THEN
5211
CVar => VariableGet( CurrentModel % Variables, 'Coordinate 1' )
5212
count = count + 1
5213
T(1) = CVar % Values(k1)
5214
CVar => VariableGet( CurrentModel % Variables, 'Coordinate 2' )
5215
count = count + 1
5216
T(2) = CVar % Values(k1)
5217
CVar => VariableGet( CurrentModel % Variables, 'Coordinate 3' )
5218
count = count + 1
5219
T(3) = CVar % Values(k1)
5220
ELSE
5221
IF ( Variable % DOFs == 1 ) THEN
5222
count = count + 1
5223
T(count) = Variable % Values(k1)
5224
ELSE
5225
DO l=1,Variable % DOFs
5226
count = count + 1
5227
T(count) = Variable % Values(Variable % DOFs*(k1-1)+l)
5228
END DO
5229
END IF
5230
END IF
5231
ELSE
5232
5233
count = count + 1
5234
IF ( ASSOCIATED(Variable % Perm) ) THEN
5235
T(count) = HUGE(1.0_dp)
5236
EXIT
5237
ELSE
5238
T(count) = Variable % Values(1)
5239
END IF
5240
END IF
5241
5242
l0 = l1+2
5243
IF ( l0 > slen ) EXIT
5244
END DO
5245
5246
!------------------------------------------------------------------------------
5247
END SUBROUTINE ListParseStrToValues
5248
!------------------------------------------------------------------------------
5249
5250
5251
!------------------------------------------------------------------------------
5252
FUNCTION ListCheckGlobal( ptr ) RESULT ( IsGlobal )
5253
!------------------------------------------------------------------------------
5254
TYPE(ValueListEntry_t), POINTER :: ptr
5255
LOGICAL :: IsGlobal
5256
!------------------------------------------------------------------------------
5257
TYPE(Element_t), POINTER :: Element
5258
INTEGER :: ind,i,j,k,n,k1,l,l0,l1,ll,count
5259
TYPE(Variable_t), POINTER :: Variable, CVar
5260
INTEGER :: slen
5261
5262
IsGlobal = .TRUE.
5263
5264
IF(.NOT.ASSOCIATED(ptr)) THEN
5265
CALL Warn('ListCheckGlobal','ptr not associated!')
5266
RETURN
5267
END IF
5268
5269
5270
IF( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_STR ) THEN
5271
RETURN
5272
5273
ELSE IF( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR .OR. &
5274
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
5275
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN
5276
5277
5278
IF ( ptr % PROCEDURE /= 0 ) THEN
5279
IsGlobal = .FALSE.
5280
RETURN
5281
END IF
5282
5283
slen = ptr % DepNameLen
5284
5285
IF( slen > 0 ) THEN
5286
count = 0
5287
l0 = 1
5288
DO WHILE( .TRUE. )
5289
5290
DO WHILE( ptr % DependName(l0:l0) == ' ' )
5291
l0 = l0 + 1
5292
END DO
5293
IF ( l0 > slen ) EXIT
5294
5295
l1 = INDEX( ptr % DependName(l0:slen),',')
5296
IF ( l1 > 0 ) THEN
5297
l1=l0+l1-2
5298
ELSE
5299
l1=slen
5300
END IF
5301
5302
count = count + 1
5303
5304
IF ( ptr % DependName(l0:l1) /= 'coordinate' ) THEN
5305
Variable => VariableGet( CurrentModel % Variables,TRIM(ptr % DependName(l0:l1)) )
5306
IF ( .NOT. ASSOCIATED( Variable ) ) THEN
5307
CALL Info('ListCheckGlobal','Parsed variable '//I2S(count)//' of '&
5308
//ptr % DependName(1:slen),Level=3)
5309
CALL Info('ListCheckGlobal','Parse counters: '&
5310
//I2S(l0)//', '//I2S(l1)//', '//I2S(slen),Level=10)
5311
5312
WRITE( Message, * ) 'Can''t find independent variable:[', &
5313
TRIM(ptr % DependName(l0:l1)),']'
5314
CALL Fatal( 'ListCheckGlobal', Message )
5315
END IF
5316
5317
IF( SIZE( Variable % Values ) > 1 ) THEN
5318
IsGlobal = .FALSE.
5319
RETURN
5320
END IF
5321
5322
ELSE
5323
IsGlobal = .FALSE.
5324
EXIT
5325
END IF
5326
5327
l0 = l1+2
5328
IF ( l0 > slen ) EXIT
5329
END DO
5330
ELSE
5331
IsGlobal = .FALSE.
5332
END IF
5333
END IF
5334
5335
5336
!------------------------------------------------------------------------------
5337
END FUNCTION ListCheckGlobal
5338
!------------------------------------------------------------------------------
5339
5340
5341
5342
!------------------------------------------------------------------------------
5343
FUNCTION ListCheckAllGlobal( List, name ) RESULT ( AllGlobal )
5344
!------------------------------------------------------------------------------
5345
TYPE(ValueList_t), POINTER :: List
5346
CHARACTER(LEN=*) :: name
5347
LOGICAL :: AllGlobal
5348
!------------------------------------------------------------------------------
5349
TYPE(ValueListEntry_t), POINTER :: ptr
5350
TYPE(Element_t), POINTER :: Element
5351
INTEGER :: ind,i,j,k,n,k1,l,l0,l1
5352
TYPE(Variable_t), POINTER :: Variable, CVar
5353
INTEGER :: slen
5354
5355
AllGlobal = .TRUE.
5356
5357
IF(.NOT.ASSOCIATED(List)) RETURN
5358
5359
ptr => List % Head
5360
IF(.NOT.ASSOCIATED(ptr)) RETURN
5361
5362
AllGlobal = ListCheckGlobal( ptr )
5363
5364
!------------------------------------------------------------------------------
5365
END FUNCTION ListCheckAllGlobal
5366
!------------------------------------------------------------------------------
5367
5368
!------------------------------------------------------------------------------
5369
!> Check Gets a real valued parameter in each node of an element.
5370
!------------------------------------------------------------------------------
5371
RECURSIVE FUNCTION ListCheckIsConstant( List,Name,Found) RESULT( IsConstant )
5372
!------------------------------------------------------------------------------
5373
TYPE(ValueList_t), POINTER :: List
5374
CHARACTER(LEN=*) :: Name
5375
LOGICAL, OPTIONAL :: Found
5376
LOGICAL :: IsConstant
5377
!------------------------------------------------------------------------------
5378
TYPE(ValueListEntry_t), POINTER :: ptr
5379
5380
IsConstant = .FALSE.
5381
ptr => ListFind(List,Name,Found)
5382
IF (.NOT.ASSOCIATED(ptr) ) RETURN
5383
5384
SELECT CASE(ptr % TYPE)
5385
CASE( LIST_TYPE_CONSTANT_SCALAR, &
5386
LIST_TYPE_CONSTANT_TENSOR, &
5387
LIST_TYPE_LOGICAL, &
5388
LIST_TYPE_INTEGER )
5389
IsConstant = .TRUE.
5390
END SELECT
5391
IF( ptr % PROCEDURE /= 0) IsConstant = .FALSE.
5392
5393
END FUNCTION ListCheckIsConstant
5394
!------------------------------------------------------------------------------
5395
5396
5397
!------------------------------------------------------------------------------
5398
!> Gets a real valued parameter in each node of an element.
5399
!------------------------------------------------------------------------------
5400
RECURSIVE FUNCTION ListGetReal( List,Name,N,NodeIndexes,Found,minv,maxv,UnfoundFatal ) RESULT(F)
5401
!------------------------------------------------------------------------------
5402
TYPE(ValueList_t), POINTER :: List
5403
CHARACTER(LEN=*) :: Name
5404
INTEGER :: N,NodeIndexes(:)
5405
REAL(KIND=dp) :: F(N)
5406
LOGICAL, OPTIONAL :: Found, UnfoundFatal
5407
REAL(KIND=dp), OPTIONAL :: minv,maxv
5408
!------------------------------------------------------------------------------
5409
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
5410
TYPE(ValueListEntry_t), POINTER :: ptr
5411
REAL(KIND=dp) :: T(MAX_FNC)
5412
TYPE(VariableTable_t) :: VarTable(MAX_FNC)
5413
INTEGER :: i,j,k,k1,l,l0,l1,lsize, VarCount
5414
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes
5415
! INTEGER :: TID, OMP_GET_THREAD_NUM
5416
!------------------------------------------------------------------------------
5417
! TID = 0
5418
! !$ TID=OMP_GET_THREAD_NUM()
5419
F = 0.0_dp
5420
ptr => ListFind(List,Name,Found)
5421
IF (.NOT.ASSOCIATED(ptr) ) THEN
5422
IF(PRESENT(UnfoundFatal)) THEN
5423
IF(UnfoundFatal) THEN
5424
WRITE(Message, '(A,A)') "Failed to find real: ",Name
5425
CALL Fatal("ListGetReal", Message)
5426
END IF
5427
END IF
5428
RETURN
5429
END IF
5430
5431
5432
SELECT CASE(ptr % TYPE)
5433
5434
CASE( LIST_TYPE_CONSTANT_SCALAR )
5435
5436
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
5437
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)//&
5438
'] not used consistently.')
5439
END IF
5440
F = ptr % Coeff * ptr % Fvalues(1,1,1)
5441
5442
5443
CASE( LIST_TYPE_VARIABLE_SCALAR )
5444
5445
CALL ListPushActiveName(Name)
5446
5447
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, VarTable, &
5448
SomeAtIp, SomeAtNodes, AllGlobal, 0, List )
5449
IF( SomeAtIp ) THEN
5450
CALL Fatal('ListGetReal','Function cannot deal with variables on IPs!')
5451
END IF
5452
5453
DO i=1,n
5454
k = NodeIndexes(i)
5455
5456
CALL VarsToValuesOnNodes( VarCount, VarTable, k, T, j )
5457
5458
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
5459
IF ( ptr % PROCEDURE /= 0 ) THEN
5460
F(i) = ptr % Coeff * &
5461
ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T )
5462
ELSE
5463
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
5464
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)//&
5465
'] not used consistently.')
5466
END IF
5467
F(i) = ptr % Coeff * &
5468
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
5469
T(1), ptr % CubicCoeff )
5470
IF( AllGlobal) THEN
5471
F(2:n) = F(1)
5472
EXIT
5473
END IF
5474
END IF
5475
END IF
5476
END DO
5477
CALL ListPopActiveName()
5478
5479
5480
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
5481
TVar => VariableGet( CurrentModel % Variables, 'Time' )
5482
F(1:n) = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % values,'st')
5483
5484
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
5485
5486
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, &
5487
VarTable, SomeAtIp, SomeAtNodes, AllGlobal, 0, List )
5488
IF( SomeAtIp ) THEN
5489
CALL Fatal('ListGetReal','Function cannot deal with variables on IPs!')
5490
END IF
5491
5492
5493
DO i=1,n
5494
k = NodeIndexes(i)
5495
5496
CALL VarsToValuesOnNodes( VarCount, VarTable, k, T, j )
5497
5498
IF ( .NOT. ptr % LuaFun ) THEN
5499
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
5500
F(i) = Ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
5501
END IF
5502
ELSE
5503
CALL ElmerEvalLua(LuaState, ptr, T, F(i), j )
5504
END IF
5505
5506
IF( AllGlobal ) THEN
5507
F(2:n) = F(1)
5508
EXIT
5509
END IF
5510
5511
END DO
5512
5513
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
5514
5515
IF ( ptr % PROCEDURE == 0 ) THEN
5516
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)//&
5517
'] not used consistently.')
5518
END IF
5519
5520
CALL ListPushActiveName(name)
5521
DO i=1,n
5522
F(i) = Ptr % Coeff * &
5523
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
5524
CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), &
5525
CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), &
5526
CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) )
5527
END DO
5528
CALL ListPopActiveName()
5529
5530
END SELECT
5531
5532
IF ( PRESENT( minv ) ) THEN
5533
IF ( MINVAL(F(1:n)) < minv ) THEN
5534
WRITE( Message,*) 'Given VALUE ', MINVAL(F(1:n)), ' for property: ', '[', TRIM(Name),']', &
5535
' smaller than given minimum: ', minv
5536
CALL Fatal( 'ListGetReal', Message )
5537
END IF
5538
END IF
5539
5540
IF ( PRESENT( maxv ) ) THEN
5541
IF ( MAXVAL(F(1:n)) > maxv ) THEN
5542
WRITE( Message,*) 'Given VALUE ', MAXVAL(F(1:n)), ' for property: ', '[', TRIM(Name),']', &
5543
' larger than given maximum ', maxv
5544
CALL Fatal( 'ListGetReal', Message )
5545
END IF
5546
END IF
5547
END FUNCTION ListGetReal
5548
!------------------------------------------------------------------------------
5549
5550
5551
!------------------------------------------------------------------------------
5552
!> Gets a real valued parameter for one node. This is a special
5553
!> version of this routine only for keywords depending on keywords.
5554
!------------------------------------------------------------------------------
5555
RECURSIVE FUNCTION ListGetRealInside( ptr,Name,NodeIndex) RESULT(F)
5556
!------------------------------------------------------------------------------
5557
TYPE(ValueListEntry_t), POINTER :: ptr
5558
CHARACTER(LEN=*) :: Name
5559
INTEGER :: NodeIndex
5560
REAL(KIND=dp) :: F
5561
!------------------------------------------------------------------------------
5562
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
5563
REAL(KIND=dp) :: T(MAX_FNC)
5564
TYPE(VariableTable_t) :: VarTable(MAX_FNC)
5565
INTEGER :: j, VarCount
5566
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes
5567
! INTEGER :: TID, OMP_GET_THREAD_NUM
5568
!------------------------------------------------------------------------------
5569
! TID = 0
5570
! !$ TID=OMP_GET_THREAD_NUM()
5571
F = 0.0_dp
5572
5573
SELECT CASE(ptr % TYPE)
5574
5575
CASE( LIST_TYPE_CONSTANT_SCALAR )
5576
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
5577
CALL Fatal( 'ListGetRealInside', 'Value type for property ['//TRIM(Name)// &
5578
'] not used consistently.' )
5579
END IF
5580
F = ptr % Coeff * ptr % Fvalues(1,1,1)
5581
5582
CASE( LIST_TYPE_VARIABLE_SCALAR )
5583
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, VarTable, &
5584
SomeAtIp, SomeAtNodes, AllGlobal, 0 )
5585
IF( SomeAtIp ) THEN
5586
CALL Fatal('ListGetRealInside','Function cannot deal with variables on IPs!')
5587
END IF
5588
5589
CALL VarsToValuesOnNodes( VarCount, VarTable, NodeIndex, T, j )
5590
5591
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
5592
IF ( ptr % PROCEDURE /= 0 ) THEN
5593
F = ptr % Coeff * &
5594
ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndex, T )
5595
ELSE
5596
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
5597
CALL Fatal( 'ListGetRealInside','Value type for property ['//TRIM(Name)// &
5598
'] not used consistently.' )
5599
END IF
5600
F = ptr % Coeff * &
5601
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
5602
T(1), ptr % CubicCoeff )
5603
END IF
5604
END IF
5605
5606
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
5607
TVar => VariableGet( CurrentModel % Variables, 'Time' )
5608
F = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % values,'st')
5609
5610
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
5611
5612
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, &
5613
VarTable, SomeAtIp, SomeAtNodes, AllGlobal, 0 )
5614
IF( SomeAtIp ) THEN
5615
CALL Fatal('ListGetRealInside','Function cannot deal with variables on IPs!')
5616
END IF
5617
5618
CALL VarsToValuesOnNodes( VarCount, VarTable, NodeIndex, T, j )
5619
IF ( .NOT. ptr % LuaFun ) THEN
5620
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
5621
F = Ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
5622
END IF
5623
ELSE
5624
CALL ElmerEvalLua(LuaState, ptr, T, F, j )
5625
END IF
5626
5627
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
5628
IF ( ptr % PROCEDURE == 0 ) THEN
5629
CALL Fatal('ListGetRealInside','Value type for property ['//TRIM(Name)// &
5630
'] not used consistently.')
5631
END IF
5632
F = Ptr % Coeff * &
5633
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
5634
CurrentModel % Mesh % Nodes % x( NodeIndex ), &
5635
CurrentModel % Mesh % Nodes % y( NodeIndex ), &
5636
CurrentModel % Mesh % Nodes % z( NodeIndex ) )
5637
END SELECT
5638
5639
END FUNCTION ListGetRealInside
5640
!------------------------------------------------------------------------------
5641
5642
5643
!------------------------------------------------------------------------------
5644
!> Gets a real valued parameter in one single point with value x.
5645
!> Optionally also computes the derivative at that point.
5646
!> Note that this uses same logical on sif file as ListGetReal
5647
!> but the variable is just a dummy as the dependent function is
5648
!> assumed to be set inside the code. This should be used with caution
5649
!> is it sets some confusing limitations to the user. The main limitation
5650
!> is the use of just one dependent variable.
5651
!------------------------------------------------------------------------------
5652
RECURSIVE FUNCTION ListGetFun( List,Name,x,Found,minv,maxv,dFdx,eps ) RESULT(F)
5653
!------------------------------------------------------------------------------
5654
TYPE(ValueList_t), POINTER :: List
5655
REAL(KIND=dp), OPTIONAL :: x
5656
REAL(KIND=dp) :: f
5657
CHARACTER(LEN=*), OPTIONAL :: Name
5658
LOGICAL, OPTIONAL :: Found
5659
REAL(KIND=dp), OPTIONAL :: minv,maxv
5660
REAL(KIND=dp), OPTIONAL :: dFdx, eps
5661
!------------------------------------------------------------------------------
5662
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
5663
TYPE(ValueListEntry_t), POINTER :: ptr, prevptr, derptr
5664
REAL(KIND=dp) :: T(1)
5665
INTEGER :: i,j,k,k1,l,l0,l1,lsize
5666
LOGICAL :: AllGlobal, GotIt
5667
REAL(KIND=dp) :: xeps, F2, F1
5668
!------------------------------------------------------------------------------
5669
5670
SAVE prevptr, derptr
5671
5672
IF(.NOT. PRESENT(x) ) THEN
5673
CALL Fatal('ListGetFun','Variable "x" is in fact compulsory!')
5674
END IF
5675
5676
F = 0.0_dp
5677
IF( PRESENT( Name ) ) THEN
5678
ptr => ListFind(List,Name,Found)
5679
IF ( .NOT.ASSOCIATED(ptr) ) RETURN
5680
ELSE
5681
IF(.NOT.ASSOCIATED(List)) RETURN
5682
ptr => List % Head
5683
IF ( .NOT.ASSOCIATED(ptr) ) THEN
5684
CALL Warn('ListGetFun','List entry not associated')
5685
RETURN
5686
END IF
5687
END IF
5688
5689
! Node number not applicable, hence set to zero
5690
k = 0
5691
T(1) = x
5692
5693
! See if we have analytical derivative available.
5694
! This is list-specific, hence memorize it.
5695
IF( PRESENT( DfDx) ) THEN
5696
IF( .NOT. ASSOCIATED( Ptr, PrevPtr ) ) THEN
5697
PrevPtr => Ptr
5698
derPtr => ListFind(List,TRIM(Name)//' Derivative',GotIt )
5699
END IF
5700
END IF
5701
5702
SELECT CASE(ptr % TYPE)
5703
5704
CASE( LIST_TYPE_CONSTANT_SCALAR )
5705
5706
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
5707
CALL Fatal( 'ListGetReal', 'Value type for property ['//TRIM(Name)// &
5708
'] not used consistently.')
5709
END IF
5710
F = ptr % Coeff * ptr % Fvalues(1,1,1)
5711
IF( PRESENT( dFdx ) ) THEN
5712
dFdx = 0.0_dp
5713
END IF
5714
5715
5716
CASE( LIST_TYPE_VARIABLE_SCALAR )
5717
5718
IF ( ptr % PROCEDURE /= 0 ) THEN
5719
CALL ListPushActiveName(name)
5720
F = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) )
5721
5722
! Compute derivative at the point if requested
5723
IF( PRESENT( dFdx ) ) THEN
5724
IF( ASSOCIATED( derPtr ) ) THEN
5725
! Analytical derivative available in another UDF
5726
IF(derptr % PROCEDURE /= 0) THEN
5727
dFdx = ExecRealFunction( derptr % PROCEDURE, CurrentModel, k, T(1) )
5728
ELSE
5729
CALL Fatal('ListGetFun','Derivative should be UDF if primary keyword is!')
5730
END IF
5731
ELSE
5732
! Numerical central difference scheme is used for accuracy.
5733
IF( PRESENT( eps ) ) THEN
5734
xeps = eps
5735
ELSE
5736
xeps = 1.0d-8
5737
END IF
5738
T(1) = x - xeps
5739
F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) )
5740
T(1) = x + xeps
5741
F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) )
5742
dFdx = ( F2 - F1 ) / (2*xeps)
5743
END IF
5744
END IF
5745
CALL ListPopActiveName()
5746
ELSE
5747
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
5748
CALL Fatal( 'ListGetFun', 'Value type for property ['//TRIM(Name)// &
5749
'] not used consistently.')
5750
END IF
5751
F = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
5752
x, ptr % CubicCoeff )
5753
! Compute the derivative symbolically from the table values.
5754
IF( PRESENT( dFdx ) ) THEN
5755
dFdx = DerivateCurve(ptr % TValues,ptr % FValues(1,1,:), &
5756
x, ptr % CubicCoeff )
5757
END IF
5758
END IF
5759
5760
5761
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
5762
5763
IF ( .NOT. ptr % LuaFun ) THEN
5764
F = GetMatcReal(ptr % Cvalue,1,[x])
5765
ELSE
5766
CALL ElmerEvalLua(LuaState, ptr, T, F, 1 )
5767
END IF
5768
5769
IF( PRESENT( dFdx ) ) THEN
5770
IF( ASSOCIATED( derPtr ) ) THEN
5771
! Compute also derivative from MATC expression
5772
IF( derPtr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN
5773
IF ( .NOT. derPtr % LuaFun ) THEN
5774
dFdx = GetMatcReal(derptr % Cvalue)
5775
ELSE
5776
CALL ElmerEvalLua(LuaState, derPtr, T, dFdx, 1 )
5777
END IF
5778
ELSE
5779
CALL Fatal('ListGetFun','Derivative should be given the same was as the primary keyword!')
5780
END IF
5781
ELSE
5782
! This is really expensive.
5783
! For speed also one sided difference could be considered.
5784
IF( PRESENT( eps ) ) THEN
5785
xeps = eps
5786
ELSE
5787
xeps = 1.0d-8
5788
END IF
5789
5790
IF ( .NOT. ptr % LuaFun ) THEN
5791
F1 = GetMatcReal(Ptr % Cvalue,1,[x-xeps])
5792
F2 = GetMatcReal(Ptr % Cvalue,1,[x+xeps])
5793
ELSE
5794
T(1) = x-xeps
5795
CALL ElmerEvalLua(LuaState, derPtr, T, F1, 1 )
5796
T(1) = x+xeps
5797
CALL ElmerEvalLua(LuaState, derPtr, T, F2, 1 )
5798
T(1) = x
5799
END IF
5800
dFdx = (F2-F1) / (2*xeps)
5801
END IF
5802
END IF
5803
5804
CASE DEFAULT
5805
CALL Fatal('ListGetFun','LIST_TYPE not implemented!')
5806
5807
END SELECT
5808
5809
IF ( PRESENT( minv ) ) THEN
5810
IF ( F < minv ) THEN
5811
WRITE( Message,*) 'Given value ', F, ' for property: ', '[', TRIM(Name),']', &
5812
' smaller than given minimum: ', minv
5813
CALL Fatal( 'ListGetFun', Message )
5814
END IF
5815
END IF
5816
5817
IF ( PRESENT( maxv ) ) THEN
5818
IF ( F > maxv ) THEN
5819
WRITE( Message,*) 'Given value ', F, ' for property: ', '[', TRIM(Name),']', &
5820
' larger than given maximum ', maxv
5821
CALL Fatal( 'ListGetFun', Message )
5822
END IF
5823
END IF
5824
5825
END FUNCTION ListGetFun
5826
!------------------------------------------------------------------------------
5827
5828
5829
!------------------------------------------------------------------------------
5830
RECURSIVE FUNCTION ListGetFunVec( List,Name,x,dofs,Found,dFdx,eps ) RESULT(F)
5831
!------------------------------------------------------------------------------
5832
TYPE(ValueList_t), POINTER :: List
5833
REAL(KIND=dp), OPTIONAL :: x(*)
5834
INTEGER, OPTIONAL :: dofs
5835
REAL(KIND=dp) :: f
5836
CHARACTER(LEN=*), OPTIONAL :: Name
5837
LOGICAL, OPTIONAL :: Found
5838
REAL(KIND=dp), OPTIONAL :: dFdx(*), eps
5839
!------------------------------------------------------------------------------
5840
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
5841
TYPE(ValueListEntry_t), POINTER :: ptr, prevptr, derptr
5842
REAL(KIND=dp) :: T(10)
5843
INTEGER :: i,j,k,k1,l,l0,l1,lsize
5844
LOGICAL :: GotIt
5845
REAL(KIND=dp) :: xeps, F2, F1
5846
CHARACTER(:), ALLOCATABLE :: tstr
5847
!------------------------------------------------------------------------------
5848
5849
SAVE prevptr, derptr
5850
5851
IF(.NOT. PRESENT(x) ) THEN
5852
CALL Fatal('ListGetFunVec','Variable "x" is in fact compulsory!')
5853
END IF
5854
5855
F = 0.0_dp
5856
IF( PRESENT( Name ) ) THEN
5857
ptr => ListFind(List,Name,Found)
5858
IF ( .NOT.ASSOCIATED(ptr) ) RETURN
5859
ELSE
5860
IF(.NOT.ASSOCIATED(List)) RETURN
5861
ptr => List % Head
5862
IF ( .NOT.ASSOCIATED(ptr) ) THEN
5863
CALL Warn('ListGetFunVec','List entry not associated')
5864
RETURN
5865
END IF
5866
END IF
5867
5868
! Node number not applicable, hence set to zero
5869
k = 0
5870
T(1:dofs) = x(1:dofs)
5871
5872
SELECT CASE(ptr % TYPE)
5873
5874
CASE( LIST_TYPE_VARIABLE_SCALAR )
5875
5876
IF ( ptr % PROCEDURE /= 0 ) THEN
5877
!CALL ListPushActiveName(name)
5878
F = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1:dofs) )
5879
5880
! Compute derivative at the point if requested
5881
IF( PRESENT( dFdx ) ) THEN
5882
! Numerical central difference scheme is used for accuracy.
5883
IF( PRESENT( eps ) ) THEN
5884
xeps = eps
5885
ELSE
5886
xeps = 1.0d-6
5887
END IF
5888
5889
DO i=1,dofs
5890
T(i) = x(i) - xeps
5891
F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1:dofs) )
5892
T(i) = x(i) + xeps
5893
F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1:dofs) )
5894
dFdx(i) = ( F2 - F1 ) / (2*xeps)
5895
T(i) = x(i)
5896
END DO
5897
END IF
5898
!CALL ListPopActiveName()
5899
END IF
5900
5901
5902
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
5903
IF ( .NOT. ptr % LuaFun ) THEN
5904
F = GetMatcReal(ptr % Cvalue,dofs,T)
5905
ELSE
5906
CALL ElmerEvalLua(LuaState, ptr, T(1:dofs), F, dofs )
5907
END IF
5908
5909
IF( PRESENT( dFdx ) ) THEN
5910
! For speed also one sided difference could be considered.
5911
IF( PRESENT( eps ) ) THEN
5912
xeps = eps
5913
ELSE
5914
xeps = 1.0d-6
5915
END IF
5916
DO i=1,dofs
5917
IF ( .NOT. ptr % LuaFun ) THEN
5918
tstr = 'tx('//I2S(i-1)//')'
5919
F1 = GetMatcReal(ptr % Cvalue,1,[x(i)-xeps],tstr)
5920
F2 = GetMatcReal(ptr % Cvalue,1,[x(i)+xeps],tstr)
5921
5922
! HAS BEEN a NO-OP, NOT CHANGED!!!!!
5923
! ! Revert back to original value
5924
! WRITE( cmd, * ) 'tx('//I2S(i-1)//')=', x(i)
5925
ELSE
5926
T(i) = T(i) - eps
5927
CALL ElmerEvalLua(LuaState, ptr, T(1:dofs), F1, dofs )
5928
T(i) = T(i) + 2*eps
5929
CALL ElmerEvalLua(LuaState, ptr, T(1:dofs), F2, dofs )
5930
T(i) = T(i) - eps
5931
END IF
5932
dFdx(i) = (F2-F1) / (2*xeps)
5933
END DO
5934
END IF
5935
5936
CASE DEFAULT
5937
CALL Fatal('ListGetFunVec','LIST_TYPE not implemented!')
5938
5939
END SELECT
5940
5941
END FUNCTION ListGetFunVec
5942
!------------------------------------------------------------------------------
5943
5944
5945
5946
5947
RECURSIVE SUBROUTINE ListInitHandle( Handle )
5948
5949
TYPE(ValueHandle_t) :: Handle
5950
5951
Handle % ValueType = -1
5952
Handle % SectionType = -1
5953
Handle % ListId = -1
5954
Handle % Element => NULL()
5955
Handle % List => NULL()
5956
Handle % Ptr => NULL()
5957
Handle % Nodes => NULL()
5958
Handle % Indexes => NULL()
5959
Handle % nValuesVec = 0
5960
Handle % ValuesVec => NULL()
5961
Handle % Values => NULL()
5962
Handle % ParValues => NULL()
5963
Handle % ParNo = 0
5964
Handle % DefIValue = 0
5965
Handle % DefRValue = 0.0_dp
5966
Handle % Rdim = 0
5967
Handle % RTensor => NULL()
5968
Handle % RTensorValues => NULL()
5969
Handle % DefLValue = .FALSE.
5970
Handle % Initialized = .FALSE.
5971
Handle % AllocationsDone = .FALSE.
5972
Handle % ConstantEverywhere = .FALSE.
5973
Handle % GlobalEverywhere = .FALSE.
5974
Handle % GlobalInList = .FALSE.
5975
Handle % EvaluateAtIP = .FALSE.
5976
Handle % SomeVarAtIp = .FALSE.
5977
Handle % SomewhereEvaluateAtIP = .FALSE.
5978
Handle % NotPresentAnywhere = .FALSE.
5979
Handle % UnfoundFatal = .FALSE.
5980
Handle % GotMinv = .FALSE.
5981
Handle % GotMaxv = .FALSE.
5982
Handle % VarCount = 0
5983
Handle % HandleIm => NULL()
5984
Handle % Handle2 => NULL()
5985
Handle % Handle3 => NULL()
5986
5987
END SUBROUTINE ListInitHandle
5988
5989
5990
!------------------------------------------------------------------------------
5991
!> Initializes the handle to save just a little bit for constant valued.
5992
!> This is not mandatory but may still be used.
5993
!------------------------------------------------------------------------------
5994
RECURSIVE SUBROUTINE ListInitElementKeyword( Handle,Section,Name,minv,maxv,&
5995
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,&
5996
FoundSomewhere,InitIm,InitVec3D,DummyCount)
5997
!------------------------------------------------------------------------------
5998
TYPE(ValueHandle_t) :: Handle
5999
CHARACTER(LEN=*) :: Section,Name
6000
REAL(KIND=dp), OPTIONAL :: minv,maxv
6001
REAL(KIND=dp), OPTIONAL :: DefRValue
6002
INTEGER, OPTIONAL :: DefIValue
6003
LOGICAL, OPTIONAL :: DefLValue
6004
LOGICAL, OPTIONAL :: UnfoundFatal
6005
LOGICAL, OPTIONAL :: EvaluateAtIp
6006
LOGICAL, OPTIONAL :: FoundSomewhere
6007
LOGICAL, OPTIONAL :: InitIm
6008
LOGICAL, OPTIONAL :: InitVec3D
6009
INTEGER, OPTIONAL :: DummyCount
6010
!------------------------------------------------------------------------------
6011
TYPE(ValueList_t), POINTER :: List
6012
TYPE(ValueListEntry_t), POINTER :: ptr
6013
INTEGER :: i, ni, NoVal, ValueType, IValue, dim, n, m, maxn, maxm
6014
TYPE(Model_t), POINTER :: Model
6015
REAL(KIND=dp) :: val, Rvalue
6016
CHARACTER(:), ALLOCATABLE :: CValue
6017
LOGICAL :: ConstantEverywhere, NotPresentAnywhere, Lvalue, FirstList, AllGlobal, Found
6018
REAL(KIND=dp), POINTER :: Basis(:)
6019
INTEGER, POINTER :: NodeIndexes(:)
6020
TYPE(Element_t), POINTER :: Element
6021
LOGICAL :: GotIt, FoundSomewhere1, FoundSomewhere2
6022
!------------------------------------------------------------------------------
6023
6024
! Number of internal variables that should be present on all function calls
6025
IF( PRESENT( DummyCount ) ) THEN
6026
Handle % IntVarCount = DummyCount
6027
END IF
6028
6029
IF( PRESENT( InitIm ) ) THEN
6030
IF( InitIm ) THEN
6031
IF( .NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
6032
ALLOCATE( Handle % HandleIm )
6033
CALL ListInitHandle( Handle % HandleIm )
6034
END IF
6035
CALL Info('ListInitElementKeyword','Treating real part of keyword',Level=15)
6036
CALL ListInitElementKeyword( Handle,Section,Name,minv,maxv,&
6037
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere,InitVec3D=InitVec3D)
6038
IF( PRESENT( FoundSomewhere) ) FoundSomewhere1 = FoundSomewhere
6039
6040
CALL Info('ListInitElementKeyword','Treating imaginary part of keyword',Level=15)
6041
CALL ListInitElementKeyword( Handle % HandleIm,Section,TRIM(Name)//' im',minv,maxv,&
6042
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere,InitVec3D=InitVec3D)
6043
IF( PRESENT( FoundSomewhere ) ) FoundSomewhere = FoundSomewhere .OR. FoundSomewhere1
6044
RETURN
6045
END IF
6046
END IF
6047
6048
IF( PRESENT( InitVec3D ) ) THEN
6049
IF( InitVec3D ) THEN
6050
IF( .NOT. ASSOCIATED( Handle % Handle2 ) ) THEN
6051
ALLOCATE( Handle % Handle2 )
6052
CALL ListInitHandle( Handle % Handle2 )
6053
END IF
6054
IF( .NOT. ASSOCIATED( Handle % Handle3 ) ) THEN
6055
ALLOCATE( Handle % Handle3 )
6056
CALL ListInitHandle( Handle % Handle3 )
6057
END IF
6058
6059
CALL ListInitElementKeyword( Handle,Section,TRIM(Name)//' 1',minv,maxv,&
6060
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere)
6061
IF( PRESENT( FoundSomewhere) ) FoundSomewhere1 = FoundSomewhere
6062
CALL ListInitElementKeyword( Handle % Handle2,Section,TRIM(Name)//' 2',minv,maxv,&
6063
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere)
6064
IF( PRESENT( FoundSomewhere) ) FoundSomewhere2 = FoundSomewhere
6065
CALL ListInitElementKeyword( Handle % Handle3,Section,TRIM(Name)//' 3',minv,maxv,&
6066
DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere)
6067
IF( PRESENT( FoundSomewhere ) ) FoundSomewhere = FoundSomewhere .OR. &
6068
FoundSomewhere1 .OR. FoundSomewhere2
6069
RETURN
6070
END IF
6071
END IF
6072
6073
CALL Info('ListInitElementKeyword','Treating keyword: '//TRIM(Name),Level=12)
6074
6075
Model => CurrentModel
6076
Handle % BulkElement = .TRUE.
6077
NULLIFY(ptr)
6078
6079
SELECT CASE ( Section )
6080
6081
CASE('Body')
6082
Handle % SectionType = SECTION_TYPE_BODY
6083
6084
CASE('Material')
6085
Handle % SectionType = SECTION_TYPE_MATERIAL
6086
6087
CASE('Body Force')
6088
Handle % SectionType = SECTION_TYPE_BF
6089
6090
CASE('Initial Condition')
6091
Handle % SectionType = SECTION_TYPE_IC
6092
6093
CASE('Boundary Condition')
6094
Handle % SectionType = SECTION_TYPE_BC
6095
Handle % BulkElement = .FALSE.
6096
6097
CASE('Component')
6098
Handle % SectionType = SECTION_TYPE_COMPONENT
6099
6100
CASE('Equation')
6101
Handle % SectionType = SECTION_TYPE_EQUATION
6102
6103
CASE DEFAULT
6104
CALL Fatal('ListInitElementKeyword','Unknown section: '//TRIM(Section))
6105
6106
END SELECT
6107
6108
6109
! Initialize the handle entries because it may be that the list structure was altered,
6110
! or the same handle is used for different keyword.
6111
Handle % ConstantEverywhere = .TRUE.
6112
Handle % GlobalInList = .FALSE.
6113
Handle % NotPresentAnywhere = .TRUE.
6114
Handle % SomewhereEvaluateAtIP = .FALSE.
6115
Handle % GlobalEverywhere = .TRUE.
6116
Handle % SomeVarAtIp = .FALSE.
6117
Handle % Name = TRIM(Name)
6118
Handle % ListId = -1
6119
Handle % EvaluateAtIp = .FALSE.
6120
Handle % List => NULL()
6121
Handle % Element => NULL()
6122
Handle % Unfoundfatal = .FALSE.
6123
IF (.NOT. ASSOCIATED( Handle % Ptr ) ) THEN
6124
Handle % Ptr => ListAllocate()
6125
END IF
6126
6127
6128
! Deallocate stuff that may change in size, or is used as a marker for first element
6129
IF( Handle % nValuesVec > 0 ) THEN
6130
DEALLOCATE( Handle % ValuesVec )
6131
Handle % nValuesVec = 0
6132
END IF
6133
6134
6135
Handle % Initialized = .TRUE.
6136
6137
FirstList = .TRUE.
6138
maxn = 0
6139
maxm = 0
6140
6141
i = 0
6142
DO WHILE(.TRUE.)
6143
i = i + 1
6144
6145
SELECT CASE ( Handle % SectionType )
6146
6147
CASE( SECTION_TYPE_BODY )
6148
IF(i > Model % NumberOfBodies ) EXIT
6149
List => Model % Bodies(i) % Values
6150
6151
CASE( SECTION_TYPE_MATERIAL )
6152
IF(i > Model % NumberOfMaterials ) EXIT
6153
List => Model % Materials(i) % Values
6154
6155
CASE( SECTION_TYPE_BF )
6156
IF(i > Model % NumberOfBodyForces ) EXIT
6157
List => Model % BodyForces(i) % Values
6158
6159
CASE( SECTION_TYPE_IC )
6160
IF( i > Model % NumberOfICs ) EXIT
6161
List => Model % ICs(i) % Values
6162
6163
CASE( SECTION_TYPE_EQUATION )
6164
IF( i > Model % NumberOfEquations ) EXIT
6165
List => Model % Equations(i) % Values
6166
6167
CASE( SECTION_TYPE_COMPONENT )
6168
IF( i > Model % NumberOfComponents ) EXIT
6169
List => Model % Components(i) % Values
6170
6171
CASE( SECTION_TYPE_BC )
6172
IF( i > Model % NumberOfBCs ) EXIT
6173
List => Model % BCs(i) % Values
6174
6175
! It is more difficult to make sure that the BC list is given for all BC elements.
6176
! Therefore set this to .FALSE. always for BCs.
6177
Handle % ConstantEverywhere = .FALSE.
6178
6179
CASE DEFAULT
6180
CALL Fatal('ListInitElementKeyword','Unknown section: '//I2S(Handle % SectionType))
6181
6182
END SELECT
6183
6184
! If the parameter is not defined in some list we cannot really be sure
6185
! that it is intentionally used as a zero. Hence we cannot assume that the
6186
! keyword is constant.
6187
ptr => ListFind(List,Name,Found)
6188
Handle % ptr % Head => ptr
6189
6190
IF ( .NOT. ASSOCIATED(ptr) ) THEN
6191
Handle % ConstantEverywhere = .FALSE.
6192
CYCLE
6193
ELSE IF( FirstList ) THEN
6194
Handle % NotPresentAnywhere = .FALSE.
6195
Handle % ValueType = ptr % Type
6196
END IF
6197
6198
ValueType = ptr % TYPE
6199
6200
IF( ValueType == LIST_TYPE_LOGICAL ) THEN
6201
Lvalue = ptr % Lvalue
6202
6203
IF( FirstList ) THEN
6204
Handle % LValue = LValue
6205
ELSE
6206
IF( Handle % LValue .NEQV. LValue ) THEN
6207
Handle % ConstantEverywhere = .FALSE.
6208
EXIT
6209
END IF
6210
END IF
6211
6212
ELSE IF( ValueType == LIST_TYPE_STRING ) THEN
6213
Cvalue = ptr % Cvalue
6214
IF( FirstList ) THEN
6215
Handle % CValueLen = len_trim(CValue)
6216
Handle % CValue = CValue(1:Handle % CValueLen)
6217
ELSE IF( Handle % CValue(1:Handle % CValueLen) /= Cvalue ) THEN
6218
Handle % ConstantEverywhere = .FALSE.
6219
EXIT
6220
END IF
6221
6222
ELSE IF( ValueType == LIST_TYPE_INTEGER ) THEN
6223
Ivalue = ptr % Ivalues(1)
6224
IF( FirstList ) THEN
6225
Handle % IValue = Ivalue
6226
ELSE IF( Handle % IValue /= Ivalue ) THEN
6227
Handle % ConstantEverywhere = .FALSE.
6228
EXIT
6229
END IF
6230
6231
ELSE IF( ValueType >= LIST_TYPE_CONSTANT_SCALAR .AND. &
6232
ValueType <= List_TYPE_CONSTANT_SCALAR_PROC ) THEN
6233
6234
IF( PRESENT( DummyCount ) ) THEN
6235
! If we feed internal variables then the eveluation cannot be global
6236
AllGlobal = .FALSE.
6237
ELSE
6238
! If the matc depends on only global variable, like time, we know that the values
6239
! of the MATC functions will be constant for each list.
6240
AllGlobal = ListCheckAllGlobal( Handle % ptr, name )
6241
END IF
6242
IF(.NOT. AllGlobal ) THEN
6243
Handle % GlobalEverywhere = .FALSE.
6244
Handle % ConstantEverywhere = .FALSE.
6245
IF( ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) ) THEN
6246
Handle % SomewhereEvaluateAtIp = .TRUE.
6247
EXIT
6248
END IF
6249
END IF
6250
6251
IF( Handle % ConstantEverywhere ) THEN
6252
Rvalue = ListGetCReal( List,Name)
6253
! and each list must have the same constant value
6254
IF( FirstList ) THEN
6255
Handle % RValue = Rvalue
6256
ELSE IF( ABS( Handle % RValue - Rvalue ) > TINY( RValue ) ) THEN
6257
Handle % ConstantEverywhere = .FALSE.
6258
END IF
6259
END IF
6260
6261
ELSE IF( ValueType >= LIST_TYPE_CONSTANT_TENSOR .AND. &
6262
ValueType <= LIST_TYPE_VARIABLE_TENSOR_STR ) THEN
6263
6264
Handle % GlobalEverywhere = .FALSE.
6265
Handle % ConstantEverywhere = .FALSE.
6266
IF( ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) ) THEN
6267
Handle % SomewhereEvaluateAtIp = .TRUE.
6268
END IF
6269
6270
n = SIZE( ptr % FValues,1 )
6271
m = SIZE( ptr % FValues,2 )
6272
maxn = MAX( n, maxn )
6273
maxm = MAX( m, maxm )
6274
ELSE
6275
CALL Fatal('ListInitElementKeyword','Unknown value type: '//I2S(ValueType))
6276
6277
END IF
6278
6279
FirstList = .FALSE.
6280
END DO
6281
6282
CALL Info('ListInitElementKeyword',&
6283
'Initiated handle for: > '//TRIM(Handle % Name)//' < of type: '// &
6284
I2S(Handle % ValueType),Level=12)
6285
6286
IF( PRESENT( UnfoundFatal ) ) THEN
6287
Handle % Unfoundfatal = UnfoundFatal
6288
IF( Handle % UnfoundFatal .AND. Handle % NotPresentAnywhere ) THEN
6289
CALL Fatal('ListInitElementKeywords','Keyword required but not present: '&
6290
//TRIM(Handle % Name))
6291
END IF
6292
END IF
6293
6294
IF( PRESENT( DefLValue ) ) THEN
6295
Handle % DefLValue = DefLValue
6296
END IF
6297
6298
IF( PRESENT( DefRValue ) ) THEN
6299
Handle % DefRValue = DefRValue
6300
END IF
6301
6302
IF( PRESENT( DefIValue ) ) THEN
6303
Handle % DefIValue = DefIValue
6304
END IF
6305
6306
IF( PRESENT( minv ) ) THEN
6307
Handle % GotMinv = .TRUE.
6308
Handle % minv = minv
6309
END IF
6310
6311
IF( PRESENT( maxv ) ) THEN
6312
Handle % GotMaxv = .TRUE.
6313
Handle % maxv = maxv
6314
END IF
6315
6316
IF( PRESENT( EvaluateAtIp ) ) THEN
6317
Handle % EvaluateAtIp = EvaluateAtIp
6318
END IF
6319
6320
IF( PRESENT( FoundSomewhere ) ) THEN
6321
FoundSomewhere = .NOT. Handle % NotPresentAnywhere
6322
END IF
6323
6324
! For tensor valued ListGetRealElement operations allocate the maximum size
6325
! of temporal table needed.
6326
IF( maxn > 1 .OR. maxm > 1 ) THEN
6327
ni = CurrentModel % Mesh % MaxElementNodes
6328
IF( ASSOCIATED( Handle % RtensorValues ) ) THEN
6329
IF( SIZE( Handle % RtensorValues, 1 ) < maxn .OR. &
6330
SIZE( Handle % RtensorValues, 2 ) < maxm .OR. &
6331
SIZE( Handle % RtensorValues, 3 ) < ni ) THEN
6332
DEALLOCATE( Handle % RtensorValues )
6333
END IF
6334
END IF
6335
IF(.NOT. ASSOCIATED( Handle % RtensorValues ) ) THEN
6336
ALLOCATE( Handle % RtensorValues(maxn,maxm,ni) )
6337
END IF
6338
END IF
6339
6340
END SUBROUTINE ListInitElementKeyword
6341
!------------------------------------------------------------------------------
6342
6343
6344
6345
!------------------------------------------------------------------------------
6346
!> Given a pointer to the element and the correct handle for the keyword find
6347
!> the list where the keyword valued should be found in.
6348
!------------------------------------------------------------------------------
6349
FUNCTION ElementHandleList( Element, Handle, ListSame, ListFound ) RESULT( List )
6350
6351
TYPE(Element_t), POINTER :: Element
6352
TYPE(ValueHandle_t) :: Handle
6353
TYPE(ValueList_t), POINTER :: List
6354
LOGICAL :: ListSame, ListFound
6355
!------------------------------------------------------------------------------
6356
INTEGER :: ListId, id
6357
6358
List => NULL()
6359
6360
ListSame = .FALSE.
6361
ListFound = .FALSE.
6362
6363
6364
! We are looking for the same element as previous time
6365
IF( ASSOCIATED( Element, Handle % Element ) ) THEN
6366
ListSame = .TRUE.
6367
List => Handle % List
6368
RETURN
6369
END IF
6370
6371
! Ok, not the same element, get the index that determines the list
6372
IF( Handle % BulkElement ) THEN
6373
ListId = Element % BodyId
6374
ELSE
6375
ListId = 0
6376
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
6377
ListId = Element % BoundaryInfo % Constraint
6378
END IF
6379
END IF
6380
6381
! We are looking at the same list as previous time
6382
IF( Handle % ListId == ListId ) THEN
6383
ListSame = .TRUE.
6384
List => Handle % List
6385
RETURN
6386
ELSE
6387
Handle % ListId = ListId
6388
IF( ListId <= 0 ) RETURN
6389
END IF
6390
6391
! Ok, we cannot use previous list, lets find the new list
6392
SELECT CASE ( Handle % SectionType )
6393
6394
CASE( SECTION_TYPE_BODY )
6395
List => CurrentModel % Bodies(ListId) % Values
6396
ListFound = .TRUE.
6397
6398
CASE( SECTION_TYPE_BF )
6399
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6400
'Body Force', ListFound )
6401
IF( ListFound ) List => CurrentModel % BodyForces(id) % Values
6402
6403
CASE( SECTION_TYPE_IC )
6404
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6405
'Initial Condition', ListFound )
6406
IF(ListFound) List => CurrentModel % ICs(id) % Values
6407
6408
CASE( SECTION_TYPE_MATERIAL )
6409
IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN
6410
id = Element % BoundaryInfo % Constraint
6411
IF(id >= 1 .AND. id <= CurrentModel % NumberOfBCs ) THEN
6412
id = ListGetInteger( CurrentModel % BCs(id) % Values, &
6413
'Material', ListFound )
6414
ELSE
6415
id = 0
6416
END IF
6417
ELSE
6418
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6419
'Material', ListFound )
6420
END IF
6421
IF(ListFound) List => CurrentModel % Materials(id) % Values
6422
6423
CASE( SECTION_TYPE_COMPONENT )
6424
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6425
'Component', ListFound )
6426
IF(ListFound) List => CurrentModel % Components(id) % Values
6427
6428
CASE( SECTION_TYPE_EQUATION )
6429
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6430
'Equation', ListFound )
6431
IF(ListFound) List => CurrentModel % Equations(id) % Values
6432
6433
CASE( SECTION_TYPE_BC )
6434
IF( ListId <= 0 .OR. ListId > CurrentModel % NumberOfBCs ) RETURN
6435
IF( CurrentModel % BCs(ListId) % Tag == ListId ) THEN
6436
List => CurrentModel % BCs(ListId) % Values
6437
ListFound = .TRUE.
6438
END IF
6439
6440
CASE( -1 )
6441
CALL Fatal('ElementHandleList','Handle not initialized!')
6442
6443
CASE DEFAULT
6444
CALL Fatal('ElementHandleList','Unknown section type!')
6445
6446
END SELECT
6447
6448
IF( ListFound ) THEN
6449
! We still have chance that this is the same list
6450
IF( ASSOCIATED( List, Handle % List ) ) THEN
6451
ListSame = .TRUE.
6452
ELSE
6453
Handle % List => List
6454
END IF
6455
ELSE
6456
Handle % List => NULL()
6457
END IF
6458
6459
END FUNCTION ElementHandleList
6460
!------------------------------------------------------------------------------
6461
6462
!------------------------------------------------------------------------------
6463
!> Given an index related to the related to the correct section returns the correct
6464
!> value list and a logical flag if there are no more.
6465
!------------------------------------------------------------------------------
6466
FUNCTION SectionHandleList( Handle, ListId, EndLoop ) RESULT( List )
6467
6468
TYPE(ValueHandle_t) :: Handle
6469
TYPE(ValueList_t), POINTER :: List
6470
INTEGER :: ListId
6471
LOGICAL :: EndLoop
6472
!------------------------------------------------------------------------------
6473
LOGICAL :: Found
6474
INTEGER :: id
6475
6476
List => NULL()
6477
6478
IF( Handle % SectionType == SECTION_TYPE_BC ) THEN
6479
EndLoop = ( ListId <= 0 .OR. ListId > CurrentModel % NumberOfBCs )
6480
ELSE
6481
EndLoop = ( ListId > CurrentModel % NumberOfBodies )
6482
END IF
6483
IF( EndLoop ) RETURN
6484
6485
6486
SELECT CASE ( Handle % SectionType )
6487
6488
CASE( SECTION_TYPE_BODY )
6489
List => CurrentModel % Bodies(ListId) % Values
6490
6491
CASE( SECTION_TYPE_BF )
6492
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6493
'Body Force', Found )
6494
IF( Found ) List => CurrentModel % BodyForces(id) % Values
6495
6496
CASE( SECTION_TYPE_IC )
6497
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6498
'Initial Condition', Found )
6499
IF(Found) List => CurrentModel % ICs(id) % Values
6500
6501
CASE( SECTION_TYPE_MATERIAL )
6502
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6503
'Material', Found )
6504
IF(Found) List => CurrentModel % Materials(id) % Values
6505
6506
CASE( SECTION_TYPE_EQUATION )
6507
id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, &
6508
'Equation',Found )
6509
IF(Found) List => CurrentModel % Equations(id) % Values
6510
6511
CASE( SECTION_TYPE_BC )
6512
List => CurrentModel % BCs(ListId) % Values
6513
6514
CASE( -1 )
6515
CALL Fatal('SectionHandleList','Handle not initialized!')
6516
6517
CASE DEFAULT
6518
CALL Fatal('SectionHandleList','Unknown section type!')
6519
6520
END SELECT
6521
6522
END FUNCTION SectionHandleList
6523
!------------------------------------------------------------------------------
6524
6525
6526
6527
!------------------------------------------------------------------------------
6528
!> Compares a string valued parameter in elements and return True if they are the same.
6529
!------------------------------------------------------------------------------
6530
FUNCTION ListCompareElementAnyString( Handle, RefValue ) RESULT( Same )
6531
!------------------------------------------------------------------------------
6532
TYPE(ValueHandle_t) :: Handle
6533
CHARACTER(LEN=*) :: RefValue
6534
LOGICAL :: Same
6535
!------------------------------------------------------------------------------
6536
TYPE(ValueList_t), POINTER :: List
6537
LOGICAL :: Found, EndLoop
6538
INTEGER :: id, n
6539
CHARACTER(:), ALLOCATABLE :: ThisValue
6540
!------------------------------------------------------------------------------
6541
6542
Same = .FALSE.
6543
6544
! If value is not present anywhere then return False
6545
IF( Handle % NotPresentAnywhere ) RETURN
6546
6547
id = 0
6548
DO WHILE (.TRUE.)
6549
id = id + 1
6550
List => SectionHandleList( Handle, id, EndLoop )
6551
IF( EndLoop ) EXIT
6552
IF(.NOT. ASSOCIATED( List ) ) CYCLE
6553
6554
ThisValue = ListGetString( List, Handle % Name, Found )
6555
IF( Found ) THEN
6556
n = len_TRIM(ThisValue)
6557
Same = ( ThisValue(1:n) == RefValue )
6558
IF( Same ) EXIT
6559
END IF
6560
END DO
6561
6562
END FUNCTION ListCompareElementAnyString
6563
!------------------------------------------------------------------------------
6564
6565
6566
!------------------------------------------------------------------------------
6567
!> Checks whether any of the logical flags has the desired logical value.
6568
!------------------------------------------------------------------------------
6569
FUNCTION ListCompareElementAnyLogical( Handle, RefValue ) RESULT( Same )
6570
!------------------------------------------------------------------------------
6571
TYPE(ValueHandle_t) :: Handle
6572
LOGICAL :: RefValue
6573
LOGICAL :: Same
6574
!------------------------------------------------------------------------------
6575
LOGICAL :: ThisValue
6576
TYPE(ValueList_t), POINTER :: List
6577
LOGICAL :: Found, EndLoop
6578
INTEGER :: id, CValueLen
6579
!------------------------------------------------------------------------------
6580
6581
Same = .FALSE.
6582
6583
! If value is not present anywhere then return False
6584
IF( Handle % NotPresentAnywhere ) RETURN
6585
6586
id = 0
6587
DO WHILE (.TRUE.)
6588
id = id + 1
6589
List => SectionHandleList( Handle, id, EndLoop )
6590
IF( EndLoop ) EXIT
6591
IF(.NOT. ASSOCIATED( List ) ) CYCLE
6592
6593
ThisValue = ListGetLogical( List, Handle % Name, Found )
6594
IF( Found ) THEN
6595
IF( ThisValue .AND. RefValue ) THEN
6596
Same = .TRUE.
6597
ELSE IF(.NOT. ThisValue .AND. .NOT. RefValue ) THEN
6598
Same = .TRUE.
6599
END IF
6600
IF( Same ) EXIT
6601
END IF
6602
END DO
6603
6604
END FUNCTION ListCompareElementAnyLogical
6605
!------------------------------------------------------------------------------
6606
6607
6608
6609
6610
!------------------------------------------------------------------------------
6611
!> Get value of parameter from either of the parents.
6612
!> If the value is found then the Left/Right parent is memorized internally.
6613
!> Might not be economical if there are two keywords that toggle but usually
6614
!> we just fetch one keyword from the parents.
6615
!------------------------------------------------------------------------------
6616
FUNCTION ListGetElementRealParent( Handle, Basis, Element, Found ) RESULT( RValue )
6617
6618
TYPE(ValueHandle_t) :: Handle
6619
TYPE(Element_t), OPTIONAL, POINTER :: Element
6620
REAL(KIND=dp), OPTIONAL :: Basis(:)
6621
LOGICAL, OPTIONAL :: Found
6622
REAL(KIND=dp) :: RValue
6623
LOGICAL :: IntFound
6624
LOGICAL :: lefttest = .TRUE. ! first start with left test 1st
6625
TYPE(Element_t), POINTER :: Parent, PElement
6626
6627
SAVE lefttest
6628
6629
!$omp threadprivate(lefttest)
6630
6631
! Find the pointer to the element, if not given
6632
IF( PRESENT( Element ) ) THEN
6633
PElement => Element
6634
ELSE
6635
PElement => CurrentModel % CurrentElement
6636
END IF
6637
6638
IntFound = .FALSE.
6639
IF( lefttest) THEN
6640
Parent => PElement % BoundaryInfo % Left
6641
ELSE
6642
Parent => PElement % BoundaryInfo % Right
6643
END IF
6644
6645
RValue = ListGetElementReal( Handle, Basis, Parent, IntFound, PElement % NodeIndexes )
6646
6647
! If not found do the same thing with the other parent
6648
IF(.NOT. IntFound ) THEN
6649
IF( lefttest) THEN
6650
Parent => PElement % BoundaryInfo % Right
6651
ELSE
6652
Parent => PElement % BoundaryInfo % Left
6653
END IF
6654
RValue = ListGetElementReal( Handle, Basis, Parent, IntFound, PElement % NodeIndexes )
6655
6656
! reverse the order in which left and right parent are tested
6657
IF( IntFound ) lefttest = .NOT. lefttest
6658
END IF
6659
6660
IF( PRESENT( Found ) ) Found = IntFound
6661
6662
END FUNCTION ListGetElementRealParent
6663
6664
6665
!------------------------------------------------------------------------------
6666
!> Gets a real valued parameter in the Gaussian integration point defined
6667
!> by the local basis function. To speed up things there is a handle associated
6668
!> to the given keyword (Name). Here the values are first evaluated at the
6669
!> nodal points and then using basis functions estimated at the
6670
!> gaussian integration points.
6671
!------------------------------------------------------------------------------
6672
FUNCTION ListGetElementReal( Handle,Basis,Element,Found,Indexes,&
6673
GaussPoint,Rdim,Rtensor,DummyVals,tstep) RESULT(Rvalue)
6674
!------------------------------------------------------------------------------
6675
TYPE(ValueHandle_t) :: Handle
6676
REAL(KIND=dp), OPTIONAL :: Basis(:)
6677
LOGICAL, OPTIONAL :: Found
6678
TYPE(Element_t), POINTER, OPTIONAL :: Element
6679
INTEGER, POINTER, OPTIONAL :: Indexes(:)
6680
INTEGER, OPTIONAL :: GaussPoint
6681
INTEGER, OPTIONAL :: Rdim
6682
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
6683
REAL(KIND=dp), OPTIONAL :: DummyVals(:)
6684
INTEGER, OPTIONAL :: tstep
6685
REAL(KIND=dp) :: Rvalue
6686
!------------------------------------------------------------------------------
6687
TYPE(ValueList_t), POINTER :: List
6688
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
6689
TYPE(ValueListEntry_t), POINTER :: ptr
6690
INTEGER, POINTER :: NodeIndexes(:)
6691
REAL(KIND=dp) :: T(MAX_FNC),x,y,z
6692
REAL(KIND=dp), POINTER :: F(:)
6693
REAL(KIND=dp), POINTER :: ParF(:,:)
6694
INTEGER :: i,j,j0,k,j2,k2,k1,l,l0,l1,lsize,ni,bodyid,id,n,m
6695
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes, ListSame, ListFound, GotIt, IntFound, &
6696
ElementSame
6697
TYPE(Element_t), POINTER :: PElement
6698
INTEGER :: lstat
6699
!------------------------------------------------------------------------------
6700
6701
! If value is not present anywhere then return False
6702
IF( Handle % NotPresentAnywhere ) THEN
6703
IF(PRESENT(Found)) Found = .FALSE.
6704
Rvalue = Handle % DefRValue
6705
RETURN
6706
END IF
6707
6708
IF( PRESENT( Rdim ) ) Rdim = 0
6709
6710
! If the value is known to be globally constant return it asap.
6711
IF( Handle % ConstantEverywhere ) THEN
6712
IF(PRESENT(Found)) Found = .TRUE.
6713
RValue = Handle % RValue
6714
RETURN
6715
END IF
6716
6717
! Find the pointer to the element, if not given
6718
IF( PRESENT( Element ) ) THEN
6719
PElement => Element
6720
ELSE
6721
PElement => CurrentModel % CurrentElement
6722
END IF
6723
6724
6725
! Set the default value
6726
Rvalue = Handle % DefRValue
6727
ElementSame = .FALSE.
6728
6729
6730
! We know by initialization the list entry type that the keyword has
6731
! Find the correct list to look the keyword in.
6732
! Bulk and boundary elements are treated separately.
6733
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
6734
6735
! If the provided list is the same as last time, also the keyword will
6736
! be sitting at the same place, otherwise find it in the new list
6737
IF( ListSame ) THEN
6738
IF( PRESENT( Found ) ) Found = Handle % Found
6739
IF( .NOT. Handle % Found ) RETURN
6740
6741
IF( Handle % GlobalInList ) THEN
6742
IF( Handle % Rdim == 0 ) THEN
6743
Rvalue = Handle % Values(1)
6744
RETURN
6745
ELSE
6746
! These have been checked already so they should exist
6747
Rdim = Handle % Rdim
6748
Rtensor => Handle % Rtensor
6749
RETURN
6750
END IF
6751
ELSE
6752
ptr => Handle % ptr % head
6753
IF (PRESENT(Rdim) .AND. PRESENT(Rtensor)) THEN
6754
Rdim = Handle % Rdim
6755
Rtensor => Handle % Rtensor
6756
END IF
6757
END IF
6758
ELSE IF( ListFound ) THEN
6759
6760
ptr => ListFind(List,Handle % Name,IntFound )
6761
IF(PRESENT(Found)) Found = IntFound
6762
Handle % Found = IntFound
6763
IF(.NOT. IntFound ) THEN
6764
IF( Handle % UnfoundFatal ) THEN
6765
CALL Fatal('ListGetElementReal','Could not find required keyword in list: '//TRIM(Handle % Name))
6766
END IF
6767
RETURN
6768
END IF
6769
6770
Handle % Ptr % Head => ptr
6771
Handle % Rdim = ptr % Fdim
6772
6773
IF( ptr % Fdim > 0 ) THEN
6774
n = SIZE(ptr % FValues,1)
6775
m = SIZE(ptr % FValues,2)
6776
IF ( ASSOCIATED( Handle % Rtensor) ) THEN
6777
IF ( SIZE(Handle % Rtensor,1) /= n .OR. SIZE(Handle % Rtensor,2) /= m ) THEN
6778
DEALLOCATE( Handle % Rtensor )
6779
END IF
6780
END IF
6781
IF(.NOT. ASSOCIATED( Handle % Rtensor) ) THEN
6782
ALLOCATE( Handle % Rtensor(n,m) )
6783
END IF
6784
6785
IF( PRESENT( Rdim ) .AND. PRESENT( Rtensor ) ) THEN
6786
Rdim = Handle % Rdim
6787
Rtensor => Handle % Rtensor
6788
ELSE
6789
CALL Fatal('ListGetElementReal','For tensors Rdim and Rtensor should be present!')
6790
END IF
6791
END IF
6792
6793
! It does not make sense to evaluate global variables at IP
6794
IF( Handle % SomewhereEvaluateAtIp ) THEN
6795
! Check whether the keyword should be evaluated at integration point directly
6796
! Only these dependency type may depend on position
6797
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
6798
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
6799
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN
6800
Handle % EvaluateAtIP = ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt )
6801
ELSE
6802
Handle % EvaluateAtIp = .FALSE.
6803
END IF
6804
END IF
6805
6806
IF( Ptr % DepNameLen > 0 ) THEN
6807
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, &
6808
Handle % Name, Handle % VarCount, Handle % VarTable, &
6809
SomeAtIp, SomeAtNodes, AllGlobal, Handle % IntVarCount, List )
6810
6811
Handle % GlobalInList = ( AllGlobal .AND. ptr % PROCEDURE == 0 )
6812
6813
! If some input parameter is given at integration point
6814
! we don't have any option other than evaluate things on IPs
6815
IF( SomeAtIP ) Handle % EvaluateAtIp = .TRUE.
6816
Handle % SomeVarAtIp = SomeAtIp
6817
6818
! If all variables are global ondes we don't need to evaluate things on IPs
6819
IF( AllGlobal ) Handle % EvaluateAtIp = .FALSE.
6820
6821
ELSE
6822
Handle % GlobalInList = ( ptr % PROCEDURE == 0 )
6823
END IF
6824
ELSE
6825
IF( Handle % UnfoundFatal ) THEN
6826
CALL Fatal('ListGetElementReal','Could not find list for required keyword: '//TRIM(Handle % Name))
6827
END IF
6828
Rvalue = Handle % DefRValue
6829
6830
!Handle % Values(1) = RValue
6831
IF( PRESENT(Found) ) THEN
6832
Found = .FALSE.
6833
Handle % Found = .FALSE.
6834
END IF
6835
RETURN
6836
END IF
6837
6838
! This is a later addition by which we add internal variables to be dummy arguments in the
6839
! list when calling Real valued keywords. The number of internal keywords is set on the
6840
! initialization phase of the handle and it is fixed per handle. The hope is that we can
6841
! pass internally computed stuff to the user defined subroutines beyond the typical
6842
! use of existing fields. For example, we can internally compute normal velocity, magnetic
6843
! field, strain velocity etc. This is almost never used.
6844
!------------------------------------------------------------------------------------------
6845
IF( Handle % IntVarCount > 0 ) THEN
6846
IF(.NOT. PRESENT( DummyVals ) ) THEN
6847
CALL Fatal('ListGetElementReal','This handle expects '&
6848
//I2S(Handle % IntVarCount)//' internal variables: '//TRIM(Handle % Name))
6849
END IF
6850
IF( SIZE( DummyVals ) /= Handle % IntVarCount ) THEN
6851
CALL Fatal('ListGetElementReal','We are expecting '&
6852
//I2S(Handle % IntVarCount)//' internal variables: '//TRIM(Handle % Name))
6853
END IF
6854
!Handle % VarTable(1:Handle % IntVarCount) % ParamValue = DummyVals
6855
END IF
6856
6857
6858
! Either evaluate parameter directly at IP,
6859
! or first at nodes and then using basis functions at IP.
6860
! The latter is the default.
6861
!------------------------------------------------------------------
6862
IF( Handle % EvaluateAtIp ) THEN
6863
IF(.NOT. PRESENT(Basis)) THEN
6864
CALL Fatal('ListGetElementReal','Parameter > Basis < is required for: '//TRIM(Handle % Name))
6865
END IF
6866
6867
! If we get back to the same element than last time use the data already
6868
! retrieved. If the element is new then get the data in every node of the
6869
! current element, or only in the 1st node if it is constant.
6870
6871
IF( ASSOCIATED( PElement, Handle % Element ) ) THEN
6872
IF( PRESENT( Indexes ) ) THEN
6873
ni = SIZE( Indexes )
6874
NodeIndexes => Indexes
6875
ELSE
6876
ni = Handle % Element % TYPE % NumberOfNodes
6877
NodeIndexes => PElement % NodeIndexes
6878
END IF
6879
6880
ParF => Handle % ParValues
6881
ELSE
6882
IF( .NOT. Handle % AllocationsDone ) THEN
6883
ni = CurrentModel % Mesh % MaxElementNodes
6884
ALLOCATE( Handle % Values(ni) )
6885
Handle % Values = 0.0_dp
6886
ALLOCATE( Handle % ParValues(MAX_FNC,ni), Handle % ParUsed(MAX_FNC) )
6887
Handle % ParValues = 0.0_dp
6888
Handle % ParUsed = .FALSE.
6889
Handle % AllocationsDone = .TRUE.
6890
END IF
6891
6892
Handle % Element => PElement
6893
IF( PRESENT( Indexes ) ) THEN
6894
ni = SIZE( Indexes )
6895
NodeIndexes => Indexes
6896
ELSE
6897
ni = PElement % TYPE % NumberOfNodes
6898
NodeIndexes => PElement % NodeIndexes
6899
END IF
6900
6901
! First fetch the nodal fields so that they may be evaluated at IP's
6902
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
6903
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
6904
ptr % TYPE == LIST_TYPE_VARIABLE_TENSOR .OR. &
6905
ptr % Type == LIST_TYPE_VARIABLE_TENSOR_STR ) THEN
6906
6907
! These might not have been initialized if this has mixed evaluation strategies
6908
IF(.NOT. ASSOCIATED( Handle % ParValues )) THEN
6909
ALLOCATE( Handle % ParValues(MAX_FNC,CurrentModel % Mesh % MaxElementNodes), &
6910
Handle % ParUsed(MAX_FNC) )
6911
Handle % ParValues = 0.0_dp
6912
Handle % ParUsed = .FALSE.
6913
END IF
6914
6915
CALL VarsToValuesOnNodesWhich( Handle % VarCount, Handle % VarTable, &
6916
Handle % ParUsed, j)
6917
j0 = Handle % IntVarCount+1
6918
6919
DO i=1,ni
6920
k = NodeIndexes(i)
6921
6922
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
6923
k, T, j, Handle % IntVarCount, tstep )
6924
6925
Handle % ParNo = j
6926
Handle % ParValues(j0:j,i) = T(j0:j)
6927
6928
! If the dependency table includes just global values (such as time)
6929
! the values will be the same for all element entries.
6930
IF( Handle % GlobalInList ) EXIT
6931
END DO
6932
END IF
6933
ParF => Handle % ParValues
6934
END IF
6935
6936
6937
SELECT CASE(ptr % TYPE)
6938
6939
CASE( LIST_TYPE_VARIABLE_SCALAR )
6940
6941
IF( Handle % IntVarCount > 0 ) THEN
6942
T(1:Handle % IntVarCount) = DummyVals
6943
END IF
6944
j0 = Handle % IntVarCount+1
6945
DO j=j0,Handle % VarCount
6946
IF( Handle % ParUsed(j) ) THEN
6947
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
6948
END IF
6949
END DO
6950
6951
! This one only deals with the variables on IPs, nodal ones are fetched separately
6952
IF( Handle % SomeVarAtIp ) THEN
6953
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, &
6954
GaussPoint, Basis, Handle % IntVarCount, tstep )
6955
END IF
6956
6957
! there is no node index, pass the negative GaussPoint as to separate it from positive node index
6958
IF ( ptr % PROCEDURE /= 0 ) THEN
6959
IF( PRESENT( GaussPoint ) ) THEN
6960
j = -GaussPoint
6961
ELSE
6962
j = 0
6963
END IF
6964
!CALL ListPushActiveName(Handle % name)
6965
6966
Rvalue = ExecRealFunction( ptr % PROCEDURE,CurrentModel, j, T )
6967
!CALL ListPopActiveName()
6968
ELSE
6969
RValue = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
6970
T(1), ptr % CubicCoeff )
6971
END IF
6972
6973
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
6974
6975
IF( Handle % IntVarCount > 0 ) THEN
6976
T(1:Handle % IntVarCount) = DummyVals
6977
END IF
6978
j0 = Handle % IntVarCount + 1
6979
DO j=j0,Handle % ParNo
6980
IF( Handle % ParUsed(j) ) THEN
6981
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
6982
END IF
6983
END DO
6984
6985
! This one only deals with the variables on IPs, nodal ones have been fecthed already
6986
IF( Handle % SomeVarAtIp ) THEN
6987
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, GaussPoint, Basis, &
6988
Handle % IntVarCount, tstep )
6989
END IF
6990
6991
IF ( ptr % LuaFun ) THEN
6992
CALL ElmerEvalLua(LuaState, ptr, T, RValue, Handle % ParNo )
6993
ELSE
6994
Rvalue = GetMatcReal(Ptr % Cvalue,Handle % ParNo,T)
6995
END IF
6996
6997
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
6998
6999
IF ( ptr % PROCEDURE /= 0 ) THEN
7000
x = SUM( Basis(1:ni) * CurrentModel % Mesh % Nodes % x( NodeIndexes(1:ni) ) )
7001
y = SUM( Basis(1:ni) * CurrentModel % Mesh % Nodes % y( NodeIndexes(1:ni) ) )
7002
z = SUM( Basis(1:ni) * CurrentModel % Mesh % Nodes % z( NodeIndexes(1:ni) ) )
7003
7004
!CALL ListPushActiveName(Handle % name)
7005
RValue = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,x,y,z)
7006
!CALL ListPopActiveName()
7007
ELSE
7008
CALL Fatal('ListGetElementReal','Constant scalar evaluation failed at ip!')
7009
END IF
7010
7011
CASE ( LIST_TYPE_CONSTANT_TENSOR )
7012
7013
n = SIZE( Handle % Rtensor, 1 )
7014
m = SIZE( Handle % Rtensor, 2 )
7015
7016
IF ( ptr % PROCEDURE /= 0 ) THEN
7017
CALL Fatal('ListGetElementReal','No proper API exists for constant tensors?!')
7018
ELSE
7019
Handle % Rtensor(:,:) = ptr % FValues(:,:,1)
7020
END IF
7021
7022
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
7023
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
7024
END IF
7025
7026
7027
CASE( LIST_TYPE_VARIABLE_TENSOR )
7028
7029
IF( Handle % IntVarCount > 0 ) THEN
7030
T(1:Handle % IntVarCount) = DummyVals
7031
END IF
7032
j0 = Handle % IntVarCount + 1
7033
DO j=j0,Handle % ParNo
7034
IF( Handle % ParUsed(j) ) THEN
7035
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
7036
END IF
7037
END DO
7038
7039
! This one only deals with the variables on IPs, nodal ones are fetched separately
7040
IF( Handle % SomeVarAtIp ) THEN
7041
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, GaussPoint, Basis, &
7042
Handle % IntVarCount, tstep )
7043
END IF
7044
7045
! there is no node index, pass the negative GaussPoint as to separate it from positive node index
7046
IF ( ptr % PROCEDURE /= 0 ) THEN
7047
IF( PRESENT( GaussPoint ) ) THEN
7048
j = -GaussPoint
7049
ELSE
7050
j = 0
7051
END IF
7052
!CALL ListPushActiveName(Handle % name)
7053
CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, &
7054
j, T, Handle % RTensor )
7055
!CALL ListPopActiveName()
7056
ELSE
7057
IF( Handle % ParNo /= 1 ) THEN
7058
CALL Fatal('ListGetElementReal','Table dependence only for one variable!')
7059
END IF
7060
DO j2=1,n
7061
DO k2=1,m
7062
Handle % Rtensor(j2,k2) = InterpolateCurve(ptr % TValues, ptr % FValues(j2,k2,:), &
7063
T(1), ptr % CubicCoeff )
7064
END DO
7065
END DO
7066
END IF
7067
7068
CASE( LIST_TYPE_VARIABLE_TENSOR_STR )
7069
7070
Handle % GlobalInList = .FALSE.
7071
7072
IF( Handle % IntVarCount > 0 ) THEN
7073
T(1:Handle % IntVarCount) = DummyVals
7074
END IF
7075
j0 = Handle % IntVarCount + 1
7076
DO j=j0,Handle % ParNo
7077
IF( Handle % ParUsed(j) ) THEN
7078
T(j) = SUM( Basis(1:ni) * Handle % ParValues(j,1:ni) )
7079
END IF
7080
END DO
7081
7082
! This one only deals with the variables on IPs, nodal ones are fetched separately
7083
IF( Handle % SomeVarAtIp ) THEN
7084
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, GaussPoint, Basis, &
7085
Handle % IntVarCount, tstep )
7086
END IF
7087
7088
IF ( .NOT. ptr % LuaFun ) THEN
7089
Handle % Rtensor = GetMatcRealArray(ptr % Cvalue,n,m,Handle % ParNo,T)
7090
ELSE
7091
CALL ElmerEvalLua(LuaState, ptr, T, Handle % RTensor, j )
7092
END IF
7093
CASE DEFAULT
7094
7095
CALL Fatal('ListGetElementReal','Unknown case for avaluation at ip: '//I2S(ptr % Type))
7096
7097
END SELECT
7098
7099
ELSE ! .NOT. EvaluteAtIp
7100
7101
! If we get back to the same element than last time use the data already
7102
! retrieved. If the element is new then get the data in every node of the
7103
! current element, or only in the 1st node if it is constant.
7104
7105
IF( Handle % IntVarCount > 0 ) THEN
7106
CALL Fatal('ListGetElementReal','It is assumed that dummy variables are given on IP points only!')
7107
END IF
7108
7109
IF( ASSOCIATED( PElement, Handle % Element ) ) THEN
7110
IF( PRESENT( Indexes ) ) THEN
7111
ni = SIZE( Indexes )
7112
NodeIndexes => Indexes
7113
ELSE
7114
ni = Handle % Element % TYPE % NumberOfNodes
7115
NodeIndexes => PElement % NodeIndexes
7116
END IF
7117
F => Handle % Values
7118
ElementSame = .TRUE.
7119
7120
ELSE
7121
IF( .NOT. Handle % AllocationsDone ) THEN
7122
ni = CurrentModel % Mesh % MaxElementNodes
7123
ALLOCATE( Handle % Values(ni) )
7124
Handle % Values = 0.0_dp
7125
IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN
7126
ALLOCATE( Handle % ParValues(MAX_FNC,ni), Handle % ParUsed(MAX_FNC) )
7127
Handle % ParValues = 0.0_dp
7128
Handle % ParUsed = .FALSE.
7129
END IF
7130
Handle % AllocationsDone = .TRUE.
7131
END IF
7132
7133
Handle % Element => PElement
7134
F => Handle % Values
7135
7136
IF( PRESENT( Indexes ) ) THEN
7137
ni = SIZE( Indexes )
7138
NodeIndexes => Indexes
7139
ELSE
7140
ni = PElement % TYPE % NumberOfNodes
7141
NodeIndexes => PElement % NodeIndexes
7142
END IF
7143
7144
SELECT CASE(ptr % TYPE)
7145
7146
CASE( LIST_TYPE_CONSTANT_SCALAR )
7147
7148
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
7149
CALL Fatal( 'ListGetElementReal', 'Value type for property ['//TRIM(Handle % Name)// &
7150
'] not used consistently.')
7151
END IF
7152
F(1) = ptr % Coeff * ptr % Fvalues(1,1,1)
7153
7154
7155
CASE( LIST_TYPE_VARIABLE_SCALAR )
7156
!CALL ListPushActiveName(Handle % name)
7157
7158
DO i=1,ni
7159
k = NodeIndexes(i)
7160
7161
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
7162
k, T, j )
7163
7164
IF ( ptr % PROCEDURE /= 0 ) THEN
7165
F(i) = ptr % Coeff * &
7166
ExecRealFunction( ptr % PROCEDURE,CurrentModel, &
7167
NodeIndexes(i), T )
7168
ELSE
7169
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
7170
CALL Fatal('ListGetElementReal','Value type for property ['//TRIM(Handle % Name)// &
7171
'] not used consistently!')
7172
END IF
7173
F(i) = ptr % Coeff * &
7174
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
7175
T(1), ptr % CubicCoeff )
7176
7177
! If the dependency table includes just global values (such as time)
7178
! the values will be the same for all element entries.
7179
IF( Handle % GlobalInList ) EXIT
7180
7181
END IF
7182
END DO
7183
!CALL ListPopActiveName()
7184
7185
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
7186
7187
IF ( ptr % LuaFun ) THEN
7188
CALL Fatal('ListGetElementReal','No routine for constant scalars LUA available!')
7189
ELSE
7190
TVar => VariableGet( CurrentModel % Variables, 'Time' )
7191
F(1) = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % values,'st')
7192
END IF
7193
7194
7195
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
7196
7197
DO i=1,ni
7198
k = NodeIndexes(i)
7199
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
7200
k, T, j )
7201
IF ( .NOT. ptr % LuaFun ) THEN
7202
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
7203
F(i) = ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
7204
END IF
7205
ELSE
7206
CALL ElmerEvalLua(LuaState, ptr, T, F(i), j )
7207
END IF
7208
7209
IF( Handle % GlobalInList ) EXIT
7210
END DO
7211
7212
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
7213
7214
IF ( ptr % PROCEDURE == 0 ) THEN
7215
CALL Fatal('ListGetElementReal','Value type for property ['//TRIM(Handle % Name)// &
7216
'] not used consistently!')
7217
END IF
7218
7219
!CALL ListPushActiveName(Handle % name)
7220
DO i=1,ni
7221
F(i) = ptr % Coeff * &
7222
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
7223
CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), &
7224
CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), &
7225
CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) )
7226
END DO
7227
!CALL ListPopActiveName()
7228
7229
7230
CASE ( LIST_TYPE_CONSTANT_TENSOR )
7231
7232
n = SIZE( Handle % Rtensor, 1 )
7233
m = SIZE( Handle % Rtensor, 2 )
7234
7235
IF ( ptr % PROCEDURE /= 0 ) THEN
7236
!CALL ListPushActiveName(Handle % name)
7237
DO i=1,n
7238
DO j=1,m
7239
Handle % Rtensor(i,j) = ExecConstRealFunction( ptr % PROCEDURE, &
7240
CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp )
7241
END DO
7242
END DO
7243
!CALL ListPopActiveName()
7244
ELSE
7245
Handle % Rtensor(:,:) = ptr % FValues(:,:,1)
7246
END IF
7247
7248
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
7249
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
7250
END IF
7251
7252
7253
CASE( LIST_TYPE_VARIABLE_TENSOR )
7254
7255
Handle % GlobalInList = .FALSE.
7256
7257
!CALL ListPushActiveName(Handle % name)
7258
7259
IF( PRESENT( Indexes ) ) THEN
7260
n = SIZE( Indexes )
7261
NodeIndexes => Indexes
7262
ELSE
7263
n = Handle % Element % TYPE % NumberOfNodes
7264
NodeIndexes => Handle % Element % NodeIndexes
7265
END IF
7266
7267
n = SIZE( Handle % Rtensor, 1 )
7268
m = SIZE( Handle % Rtensor, 2 )
7269
7270
DO i=1,ni
7271
k = NodeIndexes(i)
7272
7273
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
7274
k, T, j )
7275
7276
IF ( ptr % PROCEDURE /= 0 ) THEN
7277
CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, &
7278
NodeIndexes(i), T, Handle % RTensor )
7279
ELSE
7280
DO j2=1,n
7281
DO k2=1,m
7282
Handle % Rtensor(j2,k2) = InterpolateCurve(ptr % TValues, ptr % FValues(j2,k2,:), &
7283
T(1), ptr % CubicCoeff )
7284
END DO
7285
END DO
7286
END IF
7287
7288
!CALL ListPopActiveName()
7289
7290
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
7291
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
7292
END IF
7293
7294
! If all variables are global the Rtensor will be constant
7295
IF( Handle % GlobalInList ) EXIT
7296
7297
Handle % RtensorValues(1:n,1:m,i) = Handle % Rtensor(1:n,1:m)
7298
END DO
7299
7300
CASE( LIST_TYPE_VARIABLE_TENSOR_STR )
7301
7302
Handle % GlobalInList = .FALSE.
7303
7304
!CALL ListPushActiveName(Handle % name)
7305
7306
IF( PRESENT( Indexes ) ) THEN
7307
n = SIZE( Indexes )
7308
NodeIndexes => Indexes
7309
ELSE
7310
n = Handle % Element % TYPE % NumberOfNodes
7311
NodeIndexes => Handle % Element % NodeIndexes
7312
END IF
7313
7314
n = SIZE( Handle % Rtensor, 1 )
7315
m = SIZE( Handle % Rtensor, 2 )
7316
7317
DO i=1,ni
7318
k = NodeIndexes(i)
7319
7320
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, &
7321
k, T, j )
7322
7323
IF ( .NOT. ptr % LuaFun ) THEN
7324
7325
Handle % Rtensor = GetMatcRealArray(ptr % Cvalue,n,m,j,T)
7326
7327
ELSE
7328
CALL ElmerEvalLua(LuaState, ptr, T, Handle % RTensor, j )
7329
END IF
7330
!CALL ListPopActiveName()
7331
7332
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
7333
Handle % Rtensor = ptr % Coeff * Handle % Rtensor
7334
END IF
7335
7336
IF( Handle % GlobalInList ) EXIT
7337
7338
Handle % RtensorValues(1:n,1:m,i) = Handle % Rtensor(1:n,1:m)
7339
END DO
7340
END SELECT
7341
7342
END IF
7343
7344
7345
IF( Handle % Rdim == 0 ) THEN
7346
IF( Handle % GlobalInList ) THEN
7347
RValue = F(1)
7348
ELSE
7349
IF(.NOT. PRESENT(Basis)) THEN
7350
CALL Fatal('ListGetElementReal','Parameter > Basis < is required for: '//TRIM(Handle % Name))
7351
ELSE
7352
RValue = SUM( Basis(1:ni) * F(1:ni) )
7353
END IF
7354
END IF
7355
ELSE
7356
Rtensor => Handle % Rtensor
7357
Rdim = Handle % Rdim
7358
7359
IF( .NOT. Handle % GlobalInList ) THEN
7360
IF(.NOT. PRESENT(Basis)) THEN
7361
CALL Fatal('ListGetElementReal','Parameter > Basis < is required for: '//TRIM(Handle % Name))
7362
ELSE
7363
DO j2=1,SIZE( Handle % RTensor, 1 )
7364
DO k2=1,SIZE( Handle % RTensor, 2 )
7365
Handle % RTensor(j2,k2) = SUM( Basis(1:ni) * Handle % RtensorValues(j2,k2,1:ni) )
7366
END DO
7367
END DO
7368
END IF
7369
END IF
7370
END IF
7371
7372
END IF
7373
7374
IF ( Handle % GotMinv ) THEN
7375
IF ( RValue < Handle % minv ) THEN
7376
WRITE( Message,*) 'Given value ',RValue, ' for property: ', '[', TRIM(Handle % Name),']', &
7377
' smaller than given minimum: ', Handle % minv
7378
CALL Fatal( 'ListGetElementReal', Message )
7379
END IF
7380
END IF
7381
7382
IF ( Handle % GotMaxv ) THEN
7383
IF ( RValue > Handle % maxv ) THEN
7384
WRITE( Message,*) 'Given value ',RValue, ' for property: ', '[', TRIM(Handle % Name),']', &
7385
' larger than given maximum ', Handle % maxv
7386
CALL Fatal( 'ListGetElementReal', Message )
7387
END IF
7388
END IF
7389
7390
END FUNCTION ListGetElementReal
7391
!------------------------------------------------------------------------------
7392
7393
7394
!------------------------------------------------------------------------------
7395
!> This is just a wrapper for getting the imaginary part of the keyword if it
7396
!> has been properly initialized. For the solver modules it is more convenient
7397
!> as the code becomes more compact when using the "HandleIm" field instead of a
7398
!> totally new handle.
7399
!------------------------------------------------------------------------------
7400
FUNCTION ListGetElementIm( Handle,Basis,Element,Found,Indexes,&
7401
GaussPoint,Rdim,Rtensor) RESULT(Rvalue)
7402
!------------------------------------------------------------------------------
7403
TYPE(ValueHandle_t) :: Handle
7404
REAL(KIND=dp), OPTIONAL :: Basis(:)
7405
LOGICAL, OPTIONAL :: Found
7406
TYPE(Element_t), POINTER, OPTIONAL :: Element
7407
INTEGER, POINTER, OPTIONAL :: Indexes(:)
7408
INTEGER, OPTIONAL :: GaussPoint
7409
INTEGER, OPTIONAL :: Rdim
7410
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
7411
REAL(KIND=dp) :: Rvalue
7412
7413
IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
7414
CALL Fatal('ListGetElementIm','Initialize with imaginary component!')
7415
END IF
7416
Rvalue = ListGetElementReal(Handle % HandleIm,Basis,Element,Found,Indexes,&
7417
GaussPoint,Rdim,Rtensor)
7418
END FUNCTION ListGetElementIm
7419
7420
7421
!------------------------------------------------------------------------------
7422
!> This is just a wrapper for getting both the real and imaginary part of the keyword if it
7423
!> has been properly initialized. For the solver modules it is convenient since the
7424
!> final code is more compact. This does not work with vector valued keywords yet!
7425
!------------------------------------------------------------------------------
7426
FUNCTION ListGetElementComplex( Handle,Basis,Element,Found,Indexes,&
7427
GaussPoint,Rdim,Rtensor) RESULT(Zvalue)
7428
!------------------------------------------------------------------------------
7429
TYPE(ValueHandle_t) :: Handle
7430
REAL(KIND=dp), OPTIONAL :: Basis(:)
7431
LOGICAL, OPTIONAL :: Found
7432
TYPE(Element_t), POINTER, OPTIONAL :: Element
7433
INTEGER, POINTER, OPTIONAL :: Indexes(:)
7434
INTEGER, OPTIONAL :: GaussPoint
7435
INTEGER, OPTIONAL :: Rdim
7436
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
7437
COMPLEX(KIND=dp) :: Zvalue
7438
7439
REAL(KIND=dp) :: RValue, Ivalue
7440
LOGICAL :: RFound
7441
7442
IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
7443
CALL Fatal('ListGetElementComplex','Initialize with imaginary component!')
7444
END IF
7445
7446
IF( Handle % NotPresentAnywhere .AND. Handle % HandleIm % NotPresentAnywhere ) THEN
7447
IF(PRESENT(Found)) Found = .FALSE.
7448
Zvalue = CMPLX( Handle % DefRValue, 0.0_dp )
7449
RETURN
7450
END IF
7451
7452
Rvalue = ListGetElementReal(Handle,Basis,Element,Found,Indexes,GaussPoint)
7453
IF( PRESENT( Found ) ) RFound = Found
7454
7455
Ivalue = ListGetElementReal(Handle % HandleIm,Basis,Element,Found,Indexes,GaussPoint)
7456
IF( PRESENT( Found ) ) Found = Found .OR. RFound
7457
7458
Zvalue = CMPLX( Rvalue, Ivalue )
7459
7460
END FUNCTION ListGetElementComplex
7461
7462
7463
!------------------------------------------------------------------------------
7464
!> This is just a wrapper for getting a 3D real vector.
7465
!------------------------------------------------------------------------------
7466
FUNCTION ListGetElementReal3D( Handle,Basis,Element,Found,Indexes,&
7467
GaussPoint,Rdim,Rtensor) RESULT(RValue3D)
7468
!------------------------------------------------------------------------------
7469
TYPE(ValueHandle_t) :: Handle
7470
REAL(KIND=dp), OPTIONAL :: Basis(:)
7471
LOGICAL, OPTIONAL :: Found
7472
TYPE(Element_t), POINTER, OPTIONAL :: Element
7473
INTEGER, POINTER, OPTIONAL :: Indexes(:)
7474
INTEGER, OPTIONAL :: GaussPoint
7475
INTEGER, OPTIONAL :: Rdim
7476
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
7477
REAL(KIND=dp) :: RValue3D(3)
7478
7479
LOGICAL :: Found1, Found2
7480
7481
IF(.NOT. ASSOCIATED( Handle % Handle2 ) ) THEN
7482
CALL Fatal('ListGetElementReal3D','Initialize with 3D components!')
7483
END IF
7484
7485
IF( Handle % NotPresentAnywhere .AND. Handle % Handle2 % NotPresentAnywhere &
7486
.AND. Handle % Handle3 % NotPresentAnywhere ) THEN
7487
IF(PRESENT(Found)) Found = .FALSE.
7488
RValue3D = 0.0_dp
7489
RETURN
7490
END IF
7491
7492
Rvalue3D(1) = ListGetElementReal(Handle,Basis,Element,Found,Indexes,GaussPoint)
7493
IF( PRESENT( Found ) ) Found1 = Found
7494
7495
Rvalue3D(2) = ListGetElementReal(Handle % Handle2,Basis,Element,Found,Indexes,GaussPoint)
7496
IF( PRESENT( Found ) ) Found2 = Found
7497
7498
Rvalue3D(3) = ListGetElementReal(Handle % Handle3,Basis,Element,Found,Indexes,GaussPoint)
7499
IF( PRESENT( Found ) ) Found = Found1 .OR. Found2 .OR. Found
7500
7501
END FUNCTION ListGetElementReal3D
7502
7503
7504
!------------------------------------------------------------------------------
7505
!> This is a wrapper to get gradient of a real valued keyword with functional dependencies.
7506
!------------------------------------------------------------------------------
7507
FUNCTION ListGetElementRealGrad( Handle,dBasisdx,Element,Found,Indexes,tstep) RESULT(RGrad)
7508
!------------------------------------------------------------------------------
7509
TYPE(ValueHandle_t) :: Handle
7510
! dBasisdx is required since it is used to evaluate the gradient
7511
REAL(KIND=dp) :: dBasisdx(:,:)
7512
LOGICAL, OPTIONAL :: Found
7513
TYPE(Element_t), POINTER, OPTIONAL :: Element
7514
INTEGER, POINTER, OPTIONAL :: Indexes(:)
7515
INTEGER, OPTIONAL :: tstep
7516
REAL(KIND=dp) :: RGrad(3)
7517
LOGICAL :: Lfound
7518
INTEGER :: i
7519
7520
RGrad = 0.0_dp
7521
7522
IF( Handle % NotPresentAnywhere ) THEN
7523
IF( PRESENT( Found ) ) Found = .FALSE.
7524
RETURN
7525
END IF
7526
7527
! Derivative of constant is zero
7528
IF( Handle % ConstantEverywhere ) THEN
7529
IF( PRESENT( Found ) ) Found = .TRUE.
7530
RETURN
7531
END IF
7532
7533
! Obtain gradient of a scalar field going through the partial derivatives of the components
7534
DO i=1,3
7535
RGrad(i) = ListGetElementReal(Handle,dBasisdx(:,i),Element,Lfound,Indexes,tstep=tstep)
7536
! If we don't have it needless to contunue to 2nd and 3rd dimensions
7537
IF(.NOT. Lfound ) EXIT
7538
END DO
7539
IF( PRESENT( Found ) ) Found = Lfound
7540
7541
END FUNCTION ListGetElementRealGrad
7542
7543
7544
!------------------------------------------------------------------------------
7545
!> This is just a wrapper for getting divergence of a 3D real vector neatly.
7546
!------------------------------------------------------------------------------
7547
FUNCTION ListGetElementRealDiv( Handle,dBasisdx,Element,Found,Indexes) RESULT(Rdiv)
7548
!------------------------------------------------------------------------------
7549
TYPE(ValueHandle_t) :: Handle
7550
! dBasisdx is required since it is used to evaluate the divergence
7551
REAL(KIND=dp) :: dBasisdx(:,:)
7552
LOGICAL, OPTIONAL :: Found
7553
TYPE(Element_t), POINTER, OPTIONAL :: Element
7554
INTEGER, POINTER, OPTIONAL :: Indexes(:)
7555
REAL(KIND=dp) :: Rdiv, Rdiv_comps(3)
7556
7557
LOGICAL :: Found1
7558
7559
IF(PRESENT(Found)) Found = .FALSE.
7560
Rdiv = 0.0_dp
7561
7562
IF(.NOT. ASSOCIATED( Handle % Handle2 ) ) THEN
7563
CALL Fatal('ListGetElementReal3D','Initialize with 3D components!')
7564
END IF
7565
7566
IF( Handle % NotPresentAnywhere .AND. Handle % Handle2 % NotPresentAnywhere &
7567
.AND. Handle % Handle3 % NotPresentAnywhere ) THEN
7568
RETURN
7569
END IF
7570
7571
Rdiv_comps(1) = ListGetElementReal(Handle,dBasisdx(:,1),Element,Found1,Indexes)
7572
! We can only take Div of a vector field if all components are present
7573
IF(.NOT. Found1) RETURN
7574
Rdiv_comps(2) = ListGetElementReal(Handle % Handle2,dBasisdx(:,2),Element,Found1,Indexes)
7575
Rdiv_comps(3) = ListGetElementReal(Handle % Handle3,dBasisdx(:,3),Element,Found1,Indexes)
7576
7577
Rdiv = SUM(Rdiv_comps)
7578
IF( PRESENT( Found ) ) Found = .TRUE.
7579
7580
END FUNCTION ListGetElementRealDiv
7581
7582
7583
7584
!------------------------------------------------------------------------------
7585
!> This is just a wrapper for getting a 3D complex vector.
7586
!------------------------------------------------------------------------------
7587
FUNCTION ListGetElementComplex3D( Handle,Basis,Element,Found,Indexes,&
7588
GaussPoint,Rdim,Rtensor) RESULT(ZValue3D)
7589
!------------------------------------------------------------------------------
7590
TYPE(ValueHandle_t) :: Handle
7591
REAL(KIND=dp), OPTIONAL :: Basis(:)
7592
LOGICAL, OPTIONAL :: Found
7593
TYPE(Element_t), POINTER, OPTIONAL :: Element
7594
INTEGER, POINTER, OPTIONAL :: Indexes(:)
7595
INTEGER, OPTIONAL :: GaussPoint
7596
INTEGER, OPTIONAL :: Rdim
7597
REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:)
7598
COMPLEX(KIND=dp) :: ZValue3D(3)
7599
7600
REAL(KIND=dp) :: RValue3D(3), IValue3D(3)
7601
LOGICAL :: RFound
7602
7603
IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN
7604
CALL Fatal('ListGetElementComplex3D','Initialize with imaginary component!')
7605
END IF
7606
7607
Rvalue3D = ListGetElementReal3D(Handle,Basis,Element,Found,Indexes,GaussPoint)
7608
IF( PRESENT( Found ) ) RFound = Found
7609
7610
Ivalue3D = ListGetElementReal3D(Handle % HandleIm,Basis,Element,Found,Indexes,GaussPoint)
7611
IF( PRESENT( Found ) ) Found = Found .OR. RFound
7612
7613
Zvalue3D = CMPLX( Rvalue3D, Ivalue3D )
7614
7615
END FUNCTION ListGetElementComplex3D
7616
7617
7618
!------------------------------------------------------------------------------
7619
!> Gets a real valued parameter in all the Gaussian integration points.
7620
!------------------------------------------------------------------------------
7621
FUNCTION ListGetElementRealVec( Handle,ngp,BasisVec,Element,Found ) RESULT( Rvalues )
7622
!------------------------------------------------------------------------------
7623
TYPE(ValueHandle_t) :: Handle
7624
INTEGER :: ngp
7625
REAL(KIND=dp), OPTIONAL :: BasisVec(:,:)
7626
LOGICAL, OPTIONAL :: Found
7627
TYPE(Element_t), POINTER, OPTIONAL :: Element
7628
REAL(KIND=dp), POINTER :: Rvalues(:)
7629
!------------------------------------------------------------------------------
7630
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
7631
TYPE(ValueListEntry_t), POINTER :: ptr
7632
INTEGER, POINTER :: NodeIndexes(:)
7633
REAL(KIND=dp) :: T(MAX_FNC),x,y,z, RValue
7634
REAL(KIND=dp), POINTER :: F(:)
7635
REAL(KIND=dp), POINTER :: ParF(:,:)
7636
INTEGER :: i,j,k,k1,l,l0,l1,lsize,n,bodyid,id,node,gp
7637
TYPE(Element_t), POINTER :: PElement
7638
TYPE(ValueList_t), POINTER :: List
7639
LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes, ListSame, ListFound, &
7640
GotIt, IntFound, SizeSame
7641
!------------------------------------------------------------------------------
7642
7643
IF( Handle % nValuesVec < ngp ) THEN
7644
IF( Handle % nValuesVec > 0 ) THEN
7645
DEALLOCATE( Handle % ValuesVec )
7646
END IF
7647
ALLOCATE( Handle % ValuesVec(ngp) )
7648
Handle % nValuesVec = ngp
7649
7650
IF( Handle % ConstantEverywhere ) THEN
7651
Handle % ValuesVec = Handle % Rvalue
7652
ELSE
7653
Handle % ValuesVec = Handle % DefRValue
7654
END IF
7655
! If size is increased we need to ensure that even constants will be rechecked.
7656
Handle % ListId = -1
7657
SizeSame = .FALSE.
7658
ELSE
7659
SizeSame = .TRUE.
7660
END IF
7661
7662
! The results are always returned from the Handle % Values
7663
Rvalues => Handle % ValuesVec
7664
7665
! If value is not present anywhere then return False
7666
IF( Handle % NotPresentAnywhere ) THEN
7667
IF(PRESENT(Found)) Found = .FALSE.
7668
RETURN
7669
END IF
7670
7671
! If the value is known to be globally constant return it asap.
7672
IF( Handle % ConstantEverywhere ) THEN
7673
IF(PRESENT(Found)) Found = .TRUE.
7674
RETURN
7675
END IF
7676
7677
! Find the pointer to the element, if not given
7678
IF( PRESENT( Element ) ) THEN
7679
PElement => Element
7680
ELSE
7681
PElement => CurrentModel % CurrentElement
7682
END IF
7683
7684
! We know by initialization the list entry type that the keyword has
7685
! Find the correct list to look the keyword in.
7686
! Bulk and boundary elements are treated separately.
7687
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
7688
7689
! If the provided list is the same as last time, also the keyword will
7690
! be sitting at the same place, otherwise find it in the new list
7691
IF( ListSame .AND. SizeSame ) THEN
7692
IF( PRESENT( Found ) ) Found = Handle % Found
7693
IF( .NOT. Handle % Found ) RETURN
7694
IF( Handle % GlobalInList ) THEN
7695
RETURN
7696
ELSE
7697
ptr => Handle % ptr % head
7698
END IF
7699
ELSE IF( ListFound ) THEN
7700
7701
ptr => ListFind(List,Handle % Name,IntFound)
7702
IF(PRESENT(Found)) Found = IntFound
7703
Handle % Found = IntFound
7704
7705
IF(.NOT. IntFound ) THEN
7706
IF( Handle % UnfoundFatal ) THEN
7707
CALL Fatal('ListGetElementRealVec','Could not find required keyword in list: '//TRIM(Handle % Name))
7708
END IF
7709
Handle % ValuesVec = Handle % DefRValue
7710
RETURN
7711
END IF
7712
7713
Handle % Ptr % Head => ptr
7714
7715
! It does not make sense to evaluate global variables at IP
7716
IF( Handle % SomewhereEvaluateAtIp ) THEN
7717
! Check whether the keyword should be evaluated at integration point directly
7718
! Only these dependency type may depend on position
7719
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
7720
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
7721
ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN
7722
! Check whether the keyword should be evaluated at integration point directly
7723
Handle % EvaluateAtIp = ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt )
7724
ELSE
7725
Handle % EvaluateAtIp = .FALSE.
7726
END IF
7727
END IF
7728
7729
7730
IF( ptr % DepNameLen > 0 ) THEN
7731
CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, &
7732
Handle % Name, Handle % VarCount, Handle % VarTable, &
7733
SomeAtIp, SomeAtNodes, AllGlobal, 0, List )
7734
IF( SomeAtIp ) Handle % EvaluateAtIp = .TRUE.
7735
Handle % GlobalInList = ( AllGlobal .AND. ptr % PROCEDURE == 0 )
7736
IF( AllGlobal ) Handle % EvaluateAtIp = .FALSE.
7737
Handle % SomeVarAtIp = SomeAtIp
7738
ELSE
7739
Handle % GlobalInList = ( ptr % PROCEDURE == 0 )
7740
END IF
7741
7742
IF( Handle % IntVarCount > 0 ) THEN
7743
CALL Fatal('ListGetElementRealVec','Not yet implemented for dummy variables!')
7744
END IF
7745
7746
ELSE
7747
IF( Handle % UnfoundFatal ) THEN
7748
CALL Fatal('ListGetElementRealVec','Could not find list for required keyword: '//TRIM(Handle % Name))
7749
END IF
7750
IF( .NOT. Handle % AllocationsDone ) THEN
7751
n = CurrentModel % Mesh % MaxElementNodes
7752
ALLOCATE( Handle % Values(n) )
7753
Handle % Values = 0.0_dp
7754
IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN
7755
ALLOCATE( Handle % ParValues(MAX_FNC,n), Handle % ParUsed(MAX_FNC) )
7756
Handle % ParValues = 0.0_dp
7757
Handle % ParUsed = .FALSE.
7758
END IF
7759
Handle % AllocationsDone = .TRUE.
7760
END IF
7761
Handle % ValuesVec = Handle % DefRValue
7762
IF( PRESENT(Found) ) THEN
7763
Found = .FALSE.
7764
Handle % Found = .FALSE.
7765
END IF
7766
RETURN
7767
END IF
7768
7769
! Either evaluate parameter directly at IP,
7770
! or first at nodes and then using basis functions at IP.
7771
! The later is the default.
7772
!------------------------------------------------------------------
7773
IF( Handle % EvaluateAtIp ) THEN
7774
7775
IF(.NOT. PRESENT(BasisVec)) THEN
7776
CALL Fatal('ListGetElementRealVec','Parameter > Basis < is required for: '//TRIM(Handle % Name))
7777
END IF
7778
7779
IF( .NOT. Handle % AllocationsDone ) THEN
7780
n = CurrentModel % Mesh % MaxElementNodes
7781
ALLOCATE( Handle % Values(n) )
7782
Handle % Values = 0.0_dp
7783
ALLOCATE( Handle % ParValues(MAX_FNC,n) )
7784
Handle % ParValues = 0.0_dp
7785
Handle % AllocationsDone = .TRUE.
7786
END IF
7787
7788
Handle % Element => PElement
7789
n = PElement % TYPE % NumberOfNodes
7790
NodeIndexes => PElement % NodeIndexes
7791
7792
7793
IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. &
7794
ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. &
7795
ptr % TYPE == LIST_TYPE_VARIABLE_TENSOR .OR. &
7796
ptr % TYPE == LIST_TYPE_VARIABLE_TENSOR_STR ) THEN
7797
7798
! These might not have been initialized if this is has mixed evaluation strategies
7799
IF(.NOT. ASSOCIATED( Handle % ParValues )) THEN
7800
ALLOCATE( Handle % ParValues(MAX_FNC,CurrentModel % Mesh % MaxElementNodes) )
7801
Handle % ParValues = 0.0_dp
7802
END IF
7803
7804
DO i=1,n
7805
node = NodeIndexes(i)
7806
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, node, T, j )
7807
7808
IF( Handle % GlobalInList ) THEN
7809
CALL Warn('ListGetElementRealVec','Constant expression need not be evaluated at IPs!')
7810
END IF
7811
7812
Handle % ParNo = j
7813
Handle % ParValues(1:j,i) = T(1:j)
7814
END DO
7815
7816
ParF => Handle % ParValues
7817
END IF
7818
7819
7820
SELECT CASE(ptr % TYPE)
7821
7822
CASE( LIST_TYPE_VARIABLE_SCALAR )
7823
7824
! there is no node index, so use zero
7825
IF ( ptr % PROCEDURE /= 0 ) THEN
7826
!CALL ListPushActiveName(Handle % name)
7827
node = 0
7828
7829
DO gp = 1, ngp
7830
DO j=1,Handle % ParNo
7831
T(j) = SUM( BasisVec(gp,1:n) * ParF(j,1:n) )
7832
END DO
7833
Rvalue = ExecRealFunction( ptr % PROCEDURE, CurrentModel, node, T )
7834
Handle % ValuesVec(gp) = RValue
7835
END DO
7836
!CALL ListPopActiveName()
7837
ELSE
7838
DO gp = 1, ngp
7839
DO j=1,Handle % ParNo
7840
T(j) = SUM( BasisVec(gp,1:n) * ParF(j,1:n) )
7841
END DO
7842
RValue = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
7843
T(1), ptr % CubicCoeff )
7844
Handle % ValuesVec(gp) = RValue
7845
END DO
7846
END IF
7847
7848
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
7849
7850
! there is no node index, so use zero
7851
node = 0
7852
7853
DO gp = 1, ngp
7854
DO j=1,Handle % ParNo
7855
T(j) = SUM( BasisVec(gp,1:n) * Handle % ParValues(j,1:n) )
7856
END DO
7857
7858
! This one only deals with the variables on IPs, nodal ones have been fecthed already
7859
IF( Handle % SomeVarAtIp ) THEN
7860
CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, T, j, gp, BasisVec(gp,1:n) )
7861
END IF
7862
7863
IF ( .NOT. ptr % LuaFun ) THEN
7864
Rvalue = GetMatcReal(ptr % Cvalue,Handle % Parno,T)
7865
ELSE
7866
CALL ElmerEvalLua(LuaState, ptr, T, RValue, j)
7867
END IF
7868
Handle % ValuesVec(gp) = RValue
7869
END DO
7870
7871
7872
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
7873
7874
IF ( ptr % PROCEDURE /= 0 ) THEN
7875
!CALL ListPushActiveName(Handle % name)
7876
7877
DO gp = 1, ngp
7878
7879
x = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % x( NodeIndexes(1:n)))
7880
y = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % y( NodeIndexes(1:n)))
7881
z = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % z( NodeIndexes(1:n)))
7882
7883
RValue = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,x,y,z)
7884
Handle % ValuesVec(gp) = RValue
7885
END DO
7886
!CALL ListPopActiveName()
7887
7888
ELSE
7889
CALL Fatal('ListGetElementRealVec','Constant scalar evaluation failed at ip!')
7890
END IF
7891
7892
CASE DEFAULT
7893
7894
CALL Fatal('ListGetElementRealVec','Unknown case for avaluation at ip')
7895
7896
END SELECT
7897
7898
ELSE
7899
7900
IF( .NOT. Handle % AllocationsDone ) THEN
7901
n = CurrentModel % Mesh % MaxElementNodes
7902
ALLOCATE( Handle % Values(n) )
7903
Handle % Values = 0.0_dp
7904
IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN
7905
ALLOCATE( Handle % ParValues(MAX_FNC,n) )
7906
Handle % ParValues = 0.0_dp
7907
END IF
7908
Handle % AllocationsDone = .TRUE.
7909
END IF
7910
7911
Handle % Element => PElement
7912
n = PElement % TYPE % NumberOfNodes
7913
NodeIndexes => PElement % NodeIndexes
7914
F => Handle % Values
7915
7916
SELECT CASE(ptr % TYPE)
7917
7918
CASE( LIST_TYPE_CONSTANT_SCALAR )
7919
7920
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
7921
CALL Fatal( 'ListGetElementRealVec', 'Value type for property ['//TRIM(Handle % Name)// &
7922
'] not used consistently.')
7923
END IF
7924
F(1) = ptr % Coeff * ptr % Fvalues(1,1,1)
7925
RValues = F(1)
7926
7927
7928
CASE( LIST_TYPE_VARIABLE_SCALAR )
7929
7930
!CALL ListPushActiveName(Handle % name)
7931
7932
DO i=1,n
7933
node = NodeIndexes(i)
7934
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, node, T, j )
7935
7936
IF ( ptr % PROCEDURE /= 0 ) THEN
7937
F(i) = ptr % Coeff * &
7938
ExecRealFunction( ptr % PROCEDURE,CurrentModel, &
7939
NodeIndexes(i), T )
7940
ELSE
7941
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
7942
CALL Fatal( 'ListGetElementRealVec', 'Value type for property ['//TRIM(Handle % Name)// &
7943
'] not used consistently.')
7944
END IF
7945
F(i) = ptr % Coeff * &
7946
InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), &
7947
T(1), ptr % CubicCoeff )
7948
7949
! If the dependency table includes just global values (such as time)
7950
! the values will be the same for all element entries.
7951
IF( Handle % GlobalInList ) EXIT
7952
END IF
7953
END DO
7954
7955
IF( Handle % GlobalInList ) THEN
7956
Handle % ValuesVec = F(1)
7957
ELSE
7958
Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) )
7959
END IF
7960
!CALL ListPopActiveName()
7961
7962
7963
CASE( LIST_TYPE_CONSTANT_SCALAR_STR )
7964
7965
TVar => VariableGet( CurrentModel % Variables, 'Time' )
7966
Handle % ValuesVec = ptr % Coeff * GetMatcReal(ptr % Cvalue,1,Tvar % Values,'st')
7967
7968
CASE( LIST_TYPE_VARIABLE_SCALAR_STR )
7969
7970
DO i=1,n
7971
k = NodeIndexes(i)
7972
7973
CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j )
7974
7975
IF ( .NOT. ptr % LuaFun ) THEN
7976
IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN
7977
F(i) = ptr % Coeff * GetMatcReal(ptr % Cvalue,j,T)
7978
END IF
7979
ELSE
7980
call ElmerEvalLuaS(LuaState, ptr, T, F(i), j)
7981
F(i) = ptr % coeff * F(i)
7982
END IF
7983
IF( Handle % GlobalInList ) EXIT
7984
END DO
7985
7986
IF( Handle % GlobalInList ) THEN
7987
Handle % ValuesVec = F(1)
7988
ELSE
7989
Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) )
7990
END IF
7991
7992
CASE( LIST_TYPE_CONSTANT_SCALAR_PROC )
7993
IF ( ptr % PROCEDURE == 0 ) THEN
7994
CALL Fatal( 'ListGetElementRealVec', 'Value type for property ['//TRIM(Handle % Name)// &
7995
'] not used consistently.')
7996
END IF
7997
7998
!CALL ListPushActiveName(Handle % name)
7999
DO i=1,n
8000
F(i) = ptr % Coeff * &
8001
ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, &
8002
CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), &
8003
CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), &
8004
CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) )
8005
END DO
8006
!CALL ListPopActiveName()
8007
8008
Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) )
8009
8010
CASE DEFAULT
8011
CALL Info('ListGetElementRealVec','This one implemented ONLY for "ListGetElementReal"',Level=3)
8012
CALL Fatal('ListGetElementRealVec','Impossible entry type for "'&
8013
//TRIM(Handle % Name)//'": '//I2S(ptr % TYPE))
8014
8015
END SELECT
8016
8017
END IF
8018
8019
END FUNCTION ListGetElementRealVec
8020
!------------------------------------------------------------------------------
8021
8022
8023
8024
8025
!------------------------------------------------------------------------------
8026
!> Gets a logical valued parameter in elements.
8027
!------------------------------------------------------------------------------
8028
FUNCTION ListGetElementLogical( Handle, Element, Found ) RESULT(Lvalue)
8029
!------------------------------------------------------------------------------
8030
TYPE(ValueHandle_t) :: Handle
8031
TYPE(Element_t), POINTER, OPTIONAL :: Element
8032
LOGICAL, OPTIONAL :: Found
8033
LOGICAL :: Lvalue
8034
!------------------------------------------------------------------------------
8035
TYPE(ValueList_t), POINTER :: List
8036
TYPE(Element_t), POINTER :: PElement
8037
LOGICAL :: ListSame, ListFound, LFound
8038
INTEGER :: id, BodyId
8039
!------------------------------------------------------------------------------
8040
8041
! If value is not present anywhere then return False
8042
IF( Handle % NotPresentAnywhere ) THEN
8043
IF(PRESENT(Found)) Found = .FALSE.
8044
Lvalue = Handle % DefLValue
8045
RETURN
8046
END IF
8047
8048
! If the value is known to be globally constant return it asap.
8049
IF( Handle % ConstantEverywhere ) THEN
8050
IF(PRESENT(Found)) Found = .TRUE.
8051
Lvalue = Handle % LValue
8052
RETURN
8053
END IF
8054
8055
! Find the pointer to the element, if not given
8056
IF( PRESENT( Element ) ) THEN
8057
PElement => Element
8058
ELSE
8059
PElement => CurrentModel % CurrentElement
8060
END IF
8061
8062
! We know by initialization the list entry type that the keyword has
8063
! Find the correct list to look the keyword in.
8064
! Bulk and boundary elements are treated separately.
8065
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
8066
8067
IF( ListSame ) THEN
8068
IF( PRESENT( Found ) ) Found = Handle % Found
8069
LValue = Handle % LValue
8070
ELSE IF( ListFound ) THEN
8071
LValue = ListGetLogical( List, Handle % Name, LFound, UnfoundFatal = Handle % UnfoundFatal )
8072
Handle % LValue = LValue
8073
Handle % Found = LFound
8074
IF(PRESENT(Found)) Found = .TRUE.
8075
ELSE
8076
IF( Handle % UnfoundFatal ) THEN
8077
CALL Fatal('ListGetElementLogical','Could not find list for required keyword: '//TRIM(Handle % Name))
8078
END IF
8079
Lvalue = Handle % DefLValue
8080
Handle % Found = .FALSE.
8081
IF( PRESENT(Found) ) Found = .FALSE.
8082
END IF
8083
8084
END FUNCTION ListGetElementLogical
8085
!------------------------------------------------------------------------------
8086
8087
8088
!------------------------------------------------------------------------------
8089
!> Gets a integer valued parameter in elements.
8090
!------------------------------------------------------------------------------
8091
FUNCTION ListGetElementInteger( Handle, Element, Found ) RESULT(Ivalue)
8092
!------------------------------------------------------------------------------
8093
TYPE(ValueHandle_t) :: Handle
8094
TYPE(Element_t), POINTER, OPTIONAL :: Element
8095
LOGICAL, OPTIONAL :: Found
8096
INTEGER :: Ivalue
8097
!------------------------------------------------------------------------------
8098
TYPE(ValueList_t), POINTER :: List
8099
TYPE(Element_t), POINTER :: PElement
8100
LOGICAL :: ListSame, ListFound
8101
INTEGER :: id, BodyId
8102
!------------------------------------------------------------------------------
8103
8104
! If value is not present anywhere then return False
8105
IF( Handle % NotPresentAnywhere ) THEN
8106
IF(PRESENT(Found)) Found = .FALSE.
8107
Ivalue = Handle % DefIValue
8108
RETURN
8109
END IF
8110
8111
! If the value is known to be globally constant return it asap.
8112
IF( Handle % ConstantEverywhere ) THEN
8113
IF(PRESENT(Found)) Found = .TRUE.
8114
Ivalue = Handle % IValue
8115
RETURN
8116
END IF
8117
8118
! Find the pointer to the element, if not given
8119
IF( PRESENT( Element ) ) THEN
8120
PElement => Element
8121
ELSE
8122
PElement => CurrentModel % CurrentElement
8123
END IF
8124
8125
! We know by initialization the list entry type that the keyword has
8126
! Find the correct list to look the keyword in.
8127
! Bulk and boundary elements are treated separately.
8128
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
8129
8130
IF( ListSame ) THEN
8131
IF( PRESENT( Found ) ) Found = Handle % Found
8132
IValue = Handle % IValue
8133
ELSE IF( ListFound ) THEN
8134
IValue = ListGetInteger( List, Handle % Name, Found, UnfoundFatal = Handle % UnfoundFatal )
8135
Handle % IValue = IValue
8136
IF(PRESENT(Found)) Handle % Found = Found
8137
ELSE
8138
IF( Handle % UnfoundFatal ) THEN
8139
CALL Fatal('ListGetElementInteger','Could not find list for required keyword: '//TRIM(Handle % Name))
8140
END IF
8141
Ivalue = Handle % DefIValue
8142
Handle % IValue = IValue
8143
IF( PRESENT(Found) ) THEN
8144
Found = .FALSE.
8145
Handle % Found = .FALSE.
8146
END IF
8147
END IF
8148
8149
8150
END FUNCTION ListGetElementInteger
8151
!------------------------------------------------------------------------------
8152
8153
8154
8155
!------------------------------------------------------------------------------
8156
!> Gets a string valued parameter in elements.
8157
!------------------------------------------------------------------------------
8158
FUNCTION ListGetElementString( Handle, Element, Found ) RESULT( CValue )
8159
!------------------------------------------------------------------------------
8160
TYPE(ValueHandle_t) :: Handle
8161
CHARACTER(LEN=MAX_NAME_LEN) :: CValue
8162
TYPE(Element_t), POINTER, OPTIONAL :: Element
8163
LOGICAL, OPTIONAL :: Found
8164
!------------------------------------------------------------------------------
8165
TYPE(ValueList_t), POINTER :: List
8166
TYPE(Element_t), POINTER :: PElement
8167
LOGICAL :: ListSame, ListFound
8168
INTEGER :: id, BodyId
8169
!------------------------------------------------------------------------------
8170
8171
! If value is not present anywhere then return False
8172
IF( Handle % NotPresentAnywhere ) THEN
8173
IF(PRESENT(Found)) Found = .FALSE.
8174
Cvalue = ' '
8175
RETURN
8176
END IF
8177
8178
! If the value is known to be globally constant return it asap.
8179
IF( Handle % ConstantEverywhere ) THEN
8180
IF(PRESENT(Found)) Found = .TRUE.
8181
Cvalue = TRIM(Handle % CValue)
8182
RETURN
8183
END IF
8184
8185
! Find the pointer to the element, if not given
8186
IF( PRESENT( Element ) ) THEN
8187
PElement => Element
8188
ELSE
8189
PElement => CurrentModel % CurrentElement
8190
END IF
8191
8192
! We know by initialization the list entry type that the keyword has
8193
! Find the correct list to look the keyword in.
8194
! Bulk and boundary elements are treated separately.
8195
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
8196
8197
IF( ListSame ) THEN
8198
IF( PRESENT( Found ) ) Found = Handle % Found
8199
CValue = Handle % CValue(1:Handle % CValueLen)
8200
ELSE IF( ListFound ) THEN
8201
CValue = ListGetString( List, Handle % Name, Found, &
8202
UnfoundFatal = Handle % UnfoundFatal )
8203
Handle % CValue = TRIM(CValue)
8204
Handle % CValueLen = len_trim(CValue)
8205
IF(PRESENT(Found)) Handle % Found = Found
8206
ELSE
8207
IF( Handle % UnfoundFatal ) THEN
8208
CALL Fatal('ListGetElementString','Could not find list for required keyword: '//TRIM(Handle % Name))
8209
END IF
8210
Cvalue = ' '
8211
Handle % CValueLen = 0
8212
IF( PRESENT(Found) ) THEN
8213
Found = .FALSE.
8214
Handle % Found = .FALSE.
8215
END IF
8216
END IF
8217
8218
END FUNCTION ListGetElementString
8219
!------------------------------------------------------------------------------
8220
8221
8222
!------------------------------------------------------------------------------
8223
!> Is the keyword present somewhere
8224
!------------------------------------------------------------------------------
8225
FUNCTION ListGetElementSomewhere( Handle ) RESULT( Found )
8226
!------------------------------------------------------------------------------
8227
TYPE(ValueHandle_t) :: Handle
8228
LOGICAL :: Found
8229
!------------------------------------------------------------------------------
8230
Found = .NOT. ( Handle % NotPresentAnywhere )
8231
8232
END FUNCTION ListGetElementSomewhere
8233
!------------------------------------------------------------------------------
8234
8235
8236
8237
8238
!------------------------------------------------------------------------------
8239
!> Compares a string valued parameter in elements and return True if they are the same.
8240
!------------------------------------------------------------------------------
8241
FUNCTION ListCompareElementString( Handle, CValue2, Element, Found ) RESULT( SameString )
8242
!------------------------------------------------------------------------------
8243
TYPE(ValueHandle_t) :: Handle
8244
CHARACTER(LEN=*) :: CValue2
8245
TYPE(Element_t), POINTER, OPTIONAL :: Element
8246
LOGICAL, OPTIONAL :: Found
8247
LOGICAL :: SameString
8248
!------------------------------------------------------------------------------
8249
CHARACTER(LEN=MAX_NAME_LEN) :: CValue
8250
TYPE(ValueList_t), POINTER :: List
8251
TYPE(Element_t), POINTER :: PElement
8252
LOGICAL :: ListSame, ListFound, IntFound
8253
INTEGER :: id, BodyId
8254
!------------------------------------------------------------------------------
8255
8256
SameString = .FALSE.
8257
8258
! If value is not present anywhere then return False
8259
IF( Handle % NotPresentAnywhere ) THEN
8260
IF(PRESENT(Found)) Found = .FALSE.
8261
RETURN
8262
END IF
8263
8264
! If the value is known to be globally constant return it asap.
8265
IF( Handle % ConstantEverywhere ) THEN
8266
IF(PRESENT(Found)) Found = .TRUE.
8267
SameString = ( CValue2 == Handle % CValue(1:Handle % CValueLen) )
8268
RETURN
8269
END IF
8270
8271
! Find the pointer to the element, if not given
8272
IF( PRESENT( Element ) ) THEN
8273
PElement => Element
8274
ELSE
8275
PElement => CurrentModel % CurrentElement
8276
END IF
8277
8278
ListSame = .FALSE.
8279
ListFound = .FALSE.
8280
8281
! We know by initialization the list entry type that the keyword has
8282
! Find the correct list to look the keyword in.
8283
! Bulk and boundary elements are treated separately.
8284
List => ElementHandleList( PElement, Handle, ListSame, ListFound )
8285
8286
IF( ListSame ) THEN
8287
IF( PRESENT( Found ) ) Found = Handle % Found
8288
IF( Handle % Found ) THEN
8289
SameString = ( Handle % CValue(1:Handle % CValueLen) == CValue2 )
8290
END IF
8291
ELSE IF( ListFound ) THEN
8292
CValue = ListGetString( List, Handle % Name, IntFound, &
8293
UnfoundFatal = Handle % UnfoundFatal )
8294
Handle % Found = IntFound
8295
IF( IntFound ) THEN
8296
Handle % CValueLen = len_trim(CValue)
8297
Handle % CValue = CValue(1:Handle % CValueLen )
8298
SameString = (Handle % CValue(1:Handle % CValueLen) == CValue2 )
8299
END IF
8300
IF(PRESENT(Found)) Found = IntFound
8301
ELSE
8302
Handle % Cvalue = ' '
8303
Handle % CValueLen = 0
8304
Handle % Found = .FALSE.
8305
IF( PRESENT(Found) ) Found = .FALSE.
8306
END IF
8307
8308
END FUNCTION ListCompareElementString
8309
!------------------------------------------------------------------------------
8310
8311
8312
!------------------------------------------------------------------------------
8313
!> Initializes the variable handle in a similar manner as the keyword handle is
8314
!> initialized. This handle is more compact. Does not support p-fields or
8315
!> Hcurl & Hdiv fields yet.
8316
!------------------------------------------------------------------------------
8317
SUBROUTINE ListInitElementVariable( Handle, Name, USolver, UVariable, tStep, Found )
8318
!------------------------------------------------------------------------------
8319
TYPE(VariableHandle_t) :: Handle
8320
CHARACTER(LEN=*), OPTIONAL :: Name
8321
TYPE(Solver_t), OPTIONAL, TARGET :: USolver
8322
TYPE(Variable_t), OPTIONAL, TARGET :: UVariable
8323
INTEGER, OPTIONAL :: tStep
8324
LOGICAL, OPTIONAL :: Found
8325
8326
REAL(KIND=dp), POINTER :: Values(:)
8327
TYPE(Variable_t), POINTER :: Variable
8328
TYPE(Solver_t) , POINTER :: Solver
8329
TYPE(Element_t), POINTER :: Element
8330
8331
Handle % Variable => NULL()
8332
Handle % Values => NULL()
8333
Handle % Perm => NULL()
8334
Handle % Element => NULL()
8335
Handle % dofs = 0
8336
Handle % Found = .FALSE.
8337
8338
IF ( PRESENT(USolver) ) THEN
8339
Solver => USolver
8340
ELSE
8341
Solver => CurrentModel % Solver
8342
END IF
8343
8344
IF ( PRESENT(name) ) THEN
8345
Variable => VariableGet( Solver % Mesh % Variables, name )
8346
ELSE IF( PRESENT( UVariable ) ) THEN
8347
Variable => UVariable
8348
ELSE
8349
Variable => Solver % Variable
8350
END IF
8351
IF( PRESENT( Found ) ) Found = Handle % Found
8352
8353
IF ( .NOT. ASSOCIATED( Variable ) ) RETURN
8354
8355
Handle % Variable => Variable
8356
Handle % dofs = Variable % Dofs
8357
Handle % Found = .TRUE.
8358
8359
IF ( PRESENT(tStep) ) THEN
8360
IF ( tStep < 0 ) THEN
8361
IF ( ASSOCIATED(Variable % PrevValues) ) THEN
8362
IF ( -tStep<=SIZE(Variable % PrevValues,2)) &
8363
Handle % Values => Variable % PrevValues(:,-tStep)
8364
END IF
8365
END IF
8366
ELSE
8367
Handle % Values => Variable % Values
8368
END IF
8369
Handle % Perm => Variable % Perm
8370
8371
IF(PRESENT(Found)) Found = Handle % Found
8372
8373
END SUBROUTINE ListInitElementVariable
8374
!------------------------------------------------------------------------------
8375
8376
8377
!------------------------------------------------------------------------------
8378
!> Get a scalar field (e.g. potential or pressure) at the integration point.
8379
!> Works with different types of fields.
8380
!------------------------------------------------------------------------------
8381
FUNCTION ListGetElementScalarSolution( Handle, Basis, Element, Found, &
8382
GaussPoint, dof ) RESULT ( Val )
8383
8384
TYPE(VariableHandle_t) :: Handle
8385
REAL(KIND=dp), OPTIONAL :: Basis(:)
8386
TYPE( Element_t), POINTER, OPTIONAL :: Element
8387
INTEGER, OPTIONAL :: GaussPoint
8388
INTEGER, OPTIONAL :: dof
8389
LOGICAL, OPTIONAL :: Found
8390
REAL(KIND=dp) :: Val
8391
8392
TYPE( Element_t), POINTER :: pElement
8393
INTEGER :: i,j, k, n
8394
INTEGER, POINTER :: Indexes(:)
8395
LOGICAL :: SameElement
8396
8397
Val = 0.0_dp
8398
8399
IF( PRESENT( Found ) ) Found = .FALSE.
8400
8401
IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN
8402
8403
! Find the pointer to the element, if not given
8404
IF( PRESENT( Element ) ) THEN
8405
PElement => Element
8406
ELSE
8407
PElement => CurrentModel % CurrentElement
8408
END IF
8409
8410
SameElement = ASSOCIATED( Handle % Element, pElement )
8411
IF( SameElement ) THEN
8412
IF( .NOT. Handle % ActiveElement ) RETURN
8413
ELSE
8414
Handle % Element => pElement
8415
END IF
8416
8417
IF( Handle % dofs > 1 ) THEN
8418
IF( .NOT. PRESENT( dof ) ) THEN
8419
CALL Fatal('ListGetElementScalarSolution','Argument "dof" is needed for vector fields!')
8420
END IF
8421
END IF
8422
8423
! If variable is defined on gauss points return that instead
8424
IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN
8425
IF( .NOT. PRESENT( GaussPoint ) ) THEN
8426
CALL Fatal('ListGetElementScalarSolution','Argument "GaussPoint" required as an argument!')
8427
END IF
8428
8429
j = pElement % ElementIndex
8430
8431
IF( .NOT. SameElement ) THEN
8432
n = Handle % Perm(j+1) - Handle % Perm(j)
8433
Handle % ActiveElement = ( n > 0 )
8434
IF( n == 0 ) RETURN
8435
END IF
8436
8437
k = Handle % Perm(j) + GaussPoint
8438
8439
IF( Handle % Dofs == 1 ) THEN
8440
val = Handle % Values( k )
8441
ELSE
8442
val = Handle % Values( Handle % Dofs * (k-1) + dof )
8443
END IF
8444
8445
ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN
8446
j = Handle % Perm( pElement % ElementIndex )
8447
Handle % ActiveElement = ( j > 0 )
8448
8449
IF( j == 0 ) RETURN
8450
8451
IF( Handle % Dofs == 1 ) THEN
8452
val = Handle % Values( j )
8453
ELSE
8454
val = Handle % Values( Handle % Dofs * (j-1) + dof )
8455
END IF
8456
8457
ELSE
8458
IF( .NOT. PRESENT( Basis ) ) THEN
8459
CALL Fatal('ListGetElementScalarSolution',&
8460
'Argument "Basis" required for non gauss-point variable!')
8461
END IF
8462
8463
IF( .NOT. SameElement ) THEN
8464
IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN
8465
n = pElement % TYPE % NumberOfNodes
8466
Indexes => pElement % DGIndexes
8467
IF(.NOT. ASSOCIATED( Indexes ) ) THEN
8468
CALL Fatal('ListGetElementScalarSolution','DGIndexes not associated!')
8469
END IF
8470
ELSE
8471
n = pElement % TYPE % NumberOfNodes
8472
Indexes => pElement % NodeIndexes
8473
END IF
8474
8475
Handle % n = n
8476
8477
IF( ASSOCIATED( Handle % Perm ) ) THEN
8478
Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) )
8479
Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 )
8480
IF(.NOT. Handle % ActiveElement ) RETURN
8481
ELSE
8482
Handle % Indexes(1:n) = [(i,i=1,4)]
8483
Handle % ActiveElement = .TRUE.
8484
END IF
8485
END IF
8486
8487
n = Handle % n
8488
IF( Handle % Dofs == 1 ) THEN
8489
val = SUM( Basis(1:n) * Handle % Values( Handle % Indexes(1:n) ) )
8490
ELSE
8491
val = SUM( Basis(1:n) * Handle % Values( &
8492
Handle % dofs*(Handle % Indexes(1:n)-1)+dof ) )
8493
END IF
8494
8495
END IF
8496
8497
IF( PRESENT( Found ) ) Found = .TRUE.
8498
8499
END FUNCTION ListGetElementScalarSolution
8500
!------------------------------------------------------------------------------
8501
8502
!------------------------------------------------------------------------------
8503
!> Get a scalar field (e.g. potential or pressure) at the integration points.
8504
!> Works with different types of fields. Vectorized version.
8505
!------------------------------------------------------------------------------
8506
FUNCTION ListGetElementScalarSolutionVec( Handle, ngp, Basis, Element, Found, dof ) RESULT ( Vals )
8507
8508
TYPE(VariableHandle_t) :: Handle
8509
INTEGER :: ngp
8510
REAL(KIND=dp), OPTIONAL :: Basis(:,:)
8511
TYPE( Element_t), POINTER, OPTIONAL :: Element
8512
INTEGER, OPTIONAL :: dof
8513
LOGICAL, OPTIONAL :: Found
8514
REAL(KIND=dp), POINTER :: Vals(:)
8515
8516
TYPE( Element_t), POINTER :: pElement
8517
INTEGER :: i,j, k, n
8518
INTEGER, POINTER :: Indexes(:)
8519
8520
NULLIFY(Vals)
8521
8522
IF( PRESENT( Found ) ) Found = .FALSE.
8523
8524
IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN
8525
8526
! Find the pointer to the element, if not given
8527
IF( PRESENT( Element ) ) THEN
8528
PElement => Element
8529
ELSE
8530
PElement => CurrentModel % CurrentElement
8531
END IF
8532
8533
IF( ASSOCIATED( Handle % Element, pElement ) ) THEN
8534
IF( Handle % ActiveElement ) THEN
8535
Vals => Handle % IpValues
8536
END IF
8537
IF( PRESENT( Found ) ) Found = Handle % ActiveElement
8538
RETURN
8539
ELSE
8540
Handle % Element => pElement
8541
END IF
8542
8543
IF( Handle % dofs > 1 ) THEN
8544
IF( .NOT. PRESENT( dof ) ) THEN
8545
CALL Fatal('ListGetElementScalarSolutionVec','Argument "dof" is needed for vector fields!')
8546
END IF
8547
END IF
8548
8549
IF( Handle % ipN < ngp ) THEN
8550
IF( Handle % ipN > 0 ) THEN
8551
DEALLOCATE( Handle % ipValues )
8552
END IF
8553
ALLOCATE( Handle % ipValues(ngp) )
8554
Handle % ipValues(1:ngp) = 0.0_dp
8555
Handle % ipN = ngp
8556
END IF
8557
8558
! If variable is defined on gauss points return that instead
8559
IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN
8560
j = pElement % ElementIndex
8561
n = Handle % Perm(j+1) - Handle % Perm(j)
8562
Handle % ActiveElement = ( n > 0 )
8563
IF( n == 0 ) RETURN
8564
8565
IF( n /= ngp ) THEN
8566
CALL Fatal('ListGetElementScalarSolutionVec','Mismatch in number of Gauss points!')
8567
END IF
8568
8569
k = Handle % Perm(j)
8570
IF( Handle % Dofs == 1 ) THEN
8571
Handle % ipValues(1:ngp) = Handle % Values(k+1:k+ngp)
8572
ELSE
8573
Handle % ipValues(1:ngp) = Handle % Values(k+dof:k+ngp*Handle % Dofs:Handle % Dofs)
8574
END IF
8575
Vals => Handle % ipValues
8576
8577
ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN
8578
j = Handle % Perm( pElement % ElementIndex )
8579
Handle % ActiveElement = ( j > 0 )
8580
IF( j == 0 ) RETURN
8581
IF( Handle % Dofs == 1 ) THEN
8582
Handle % ipValues(1:ngp) = Handle % Values( j )
8583
ELSE
8584
Handle % ipValues(1:ngp) = Handle % Values( Handle % Dofs * (j-1) + dof )
8585
END IF
8586
Vals => Handle % ipValues
8587
8588
ELSE
8589
IF( .NOT. PRESENT( Basis ) ) THEN
8590
CALL Fatal('ListGetElementScalarSolutionVec',&
8591
'Argument "Basis" required for non gauss-point variable!')
8592
END IF
8593
8594
IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN
8595
n = pElement % TYPE % NumberOfNodes
8596
Indexes => pElement % DGIndexes
8597
IF(.NOT. ASSOCIATED( Indexes ) ) THEN
8598
CALL Fatal('ListGetElementScalarSolutionVec','DGIndexes not associated!')
8599
END IF
8600
ELSE
8601
n = pElement % TYPE % NumberOfNodes
8602
Indexes => pElement % NodeIndexes
8603
END IF
8604
8605
Handle % n = n
8606
8607
IF( ASSOCIATED( Handle % Perm ) ) THEN
8608
Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) )
8609
Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 )
8610
IF(.NOT. Handle % ActiveElement ) RETURN
8611
ELSE
8612
Handle % Indexes(1:n) = Indexes(1:n)
8613
Handle % ActiveElement = .TRUE.
8614
END IF
8615
8616
IF( Handle % Dofs == 1 ) THEN
8617
Handle % ipValues(1:ngp) = MATMUL(Basis(1:ngp,1:n),&
8618
Handle % Values( Handle % Indexes(1:n) ) )
8619
ELSE
8620
Handle % ipValues(1:ngp) = MATMUL(Basis(1:ngp,1:n),&
8621
Handle % Values( Handle % Dofs*( Handle % Indexes(1:n)-1)+dof ) )
8622
END IF
8623
Vals => Handle % ipValues
8624
END IF
8625
8626
IF( PRESENT( Found ) ) Found = ASSOCIATED( Vals )
8627
8628
END FUNCTION ListGetElementScalarSolutionVec
8629
!------------------------------------------------------------------------------
8630
8631
8632
!------------------------------------------------------------------------------
8633
!> Get a vector field (e.g. velocity or displacement) at the integration points.
8634
!> Works with different types of fields. Vectorized version.
8635
!------------------------------------------------------------------------------
8636
FUNCTION ListGetElementVectorSolutionVec( Handle, ngp, dim, Basis, Element, Found ) RESULT ( Vals )
8637
8638
TYPE(VariableHandle_t) :: Handle
8639
INTEGER :: ngp, dim
8640
REAL(KIND=dp), OPTIONAL :: Basis(:,:)
8641
TYPE( Element_t), POINTER, OPTIONAL :: Element
8642
LOGICAL, OPTIONAL :: Found
8643
REAL(KIND=dp), POINTER :: Vals(:,:)
8644
8645
TYPE( Element_t), POINTER :: pElement
8646
INTEGER :: i,j, k, n, dof
8647
INTEGER, POINTER :: Indexes(:)
8648
8649
NULLIFY(Vals)
8650
8651
IF( PRESENT( Found ) ) Found = .FALSE.
8652
8653
IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN
8654
8655
! Find the pointer to the element, if not given
8656
IF( PRESENT( Element ) ) THEN
8657
PElement => Element
8658
ELSE
8659
PElement => CurrentModel % CurrentElement
8660
END IF
8661
8662
IF( ASSOCIATED( Handle % Element, pElement ) ) THEN
8663
IF( Handle % ActiveElement ) THEN
8664
Vals => Handle % IpValues3D
8665
END IF
8666
IF( PRESENT( Found ) ) Found = Handle % ActiveElement
8667
RETURN
8668
ELSE
8669
Handle % Element => pElement
8670
END IF
8671
8672
IF( Handle % ipN < ngp ) THEN
8673
IF( Handle % ipN > 0 ) THEN
8674
DEALLOCATE( Handle % ipValues3D )
8675
END IF
8676
ALLOCATE( Handle % ipValues3D(ngp,Handle % dofs) )
8677
Handle % ipValues3D(1:ngp,1:Handle % Dofs) = 0.0_dp
8678
Handle % ipN = ngp
8679
END IF
8680
8681
! If variable is defined on gauss points return that instead
8682
IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN
8683
j = pElement % ElementIndex
8684
n = Handle % Perm(j+1) - Handle % Perm(j)
8685
Handle % ActiveElement = ( n > 0 )
8686
IF( n == 0 ) RETURN
8687
8688
IF( n /= ngp ) THEN
8689
CALL Fatal('ListGetElementVectorSolutionVec','Mismatch in number of Gauss points!')
8690
END IF
8691
8692
k = Handle % Perm(j)
8693
DO dof=1,MIN(Handle % dofs,dim)
8694
Handle % ipValues3D(1:ngp,dof) = Handle % Values(k+dof:k+ngp*Handle % Dofs:Handle % Dofs)
8695
END DO
8696
Vals => Handle % ipValues3D
8697
8698
ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN
8699
j = Handle % Perm( pElement % ElementIndex )
8700
Handle % ActiveElement = ( j > 0 )
8701
IF( j == 0 ) RETURN
8702
8703
DO dof=1,MIN(Handle % dofs,dim)
8704
Handle % ipValues3D(1:ngp,dof) = Handle % Values( Handle % Dofs * (j-1) + dof )
8705
END DO
8706
Vals => Handle % ipValues3D
8707
8708
ELSE
8709
IF( .NOT. PRESENT( Basis ) ) THEN
8710
CALL Fatal('ListGetElementVectorSolutionVec',&
8711
'Argument "Basis" required for non gauss-point variable!')
8712
END IF
8713
8714
IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN
8715
n = pElement % TYPE % NumberOfNodes
8716
Indexes => pElement % DGIndexes
8717
IF(.NOT. ASSOCIATED( Indexes ) ) THEN
8718
CALL Fatal('ListGetElementVectorSolutionVec','DGIndexes not associated!')
8719
END IF
8720
ELSE
8721
n = pElement % TYPE % NumberOfNodes
8722
Indexes => pElement % NodeIndexes
8723
END IF
8724
8725
Handle % n = n
8726
8727
IF( ASSOCIATED( Handle % Perm ) ) THEN
8728
Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) )
8729
Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 )
8730
IF(.NOT. Handle % ActiveElement ) RETURN
8731
ELSE
8732
Handle % Indexes(1:n) = Indexes(1:n)
8733
Handle % ActiveElement = .TRUE.
8734
END IF
8735
8736
DO dof=1,MIN(Handle % dofs,dim)
8737
Handle % ipValues3D(1:ngp,dof) = MATMUL(Basis(1:ngp,1:n),&
8738
Handle % Values( Handle % Dofs*( Handle % Indexes(1:n)-1)+dof ) )
8739
END DO
8740
Vals => Handle % ipValues3D
8741
END IF
8742
8743
IF( PRESENT( Found ) ) Found = ASSOCIATED( Vals )
8744
8745
END FUNCTION ListGetElementVectorSolutionVec
8746
!------------------------------------------------------------------------------
8747
8748
8749
!------------------------------------------------------------------------------
8750
!> Get a vector field (e.g. velocity or displacement) at the integration point.
8751
!> Works with different types of fields.
8752
!------------------------------------------------------------------------------
8753
FUNCTION ListGetElementVectorSolution( Handle, Basis, Element, Found, GaussPoint, &
8754
dofs ) &
8755
RESULT ( Val3D )
8756
8757
TYPE(VariableHandle_t) :: Handle
8758
REAL(KIND=dp), OPTIONAL :: Basis(:)
8759
TYPE( Element_t), POINTER, OPTIONAL :: Element
8760
INTEGER, OPTIONAL :: GaussPoint
8761
INTEGER, OPTIONAL :: dofs
8762
LOGICAL, OPTIONAL :: Found
8763
REAL(KIND=dp) :: Val3D(3)
8764
8765
INTEGER :: dof, Ldofs
8766
8767
Val3D = 0.0_dp
8768
8769
IF( .NOT. ASSOCIATED( Handle % Variable ) ) THEN
8770
IF(PRESENT(Found)) Found = .FALSE.
8771
RETURN
8772
END IF
8773
8774
IF( PRESENT( dofs ) ) THEN
8775
Ldofs = dofs
8776
ELSE
8777
Ldofs = MIN( 3, Handle % Dofs )
8778
END IF
8779
8780
DO dof = 1, Ldofs
8781
Val3D(dof) = ListGetElementScalarSolution( Handle, Basis, Element, Found, &
8782
GaussPoint, dof )
8783
IF( .NOT. Handle % ActiveElement ) RETURN
8784
END DO
8785
8786
END FUNCTION ListGetElementVectorSolution
8787
8788
8789
8790
!------------------------------------------------------------------------------
8791
!> Gets a constant real array from the list by its name.
8792
!------------------------------------------------------------------------------
8793
RECURSIVE FUNCTION ListGetConstRealArray( List,Name,Found,UnfoundFatal ) RESULT( F )
8794
!------------------------------------------------------------------------------
8795
TYPE(ValueList_t), POINTER :: List
8796
CHARACTER(LEN=*) :: Name
8797
LOGICAL, OPTIONAL :: Found, UnfoundFatal
8798
!------------------------------------------------------------------------------
8799
REAL(KIND=dp), POINTER :: F(:,:)
8800
INTEGER :: i,j,n,m
8801
TYPE(ValueListEntry_t), POINTER :: ptr
8802
!------------------------------------------------------------------------------
8803
NULLIFY( F )
8804
ptr => ListFind(List,Name,Found)
8805
IF (.NOT.ASSOCIATED(ptr) ) THEN
8806
IF(PRESENT(UnfoundFatal)) THEN
8807
IF(UnfoundFatal) THEN
8808
CALL Fatal("ListGetConstRealArray", "Failed to find: "//TRIM(Name) )
8809
END IF
8810
END IF
8811
RETURN
8812
END IF
8813
8814
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
8815
CALL Fatal( 'ListGetConstRealArray', 'Value type for property ['//TRIM(Name)// &
8816
'] not used consistently.')
8817
END IF
8818
8819
n = SIZE( ptr % FValues,1 )
8820
m = SIZE( ptr % FValues,2 )
8821
8822
F => ptr % FValues(:,:,1)
8823
8824
IF ( ptr % PROCEDURE /= 0 ) THEN
8825
CALL ListPushActiveName(name)
8826
DO i=1,n
8827
DO j=1,m
8828
F(i,j) = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,0.0d0,0.0d0,0.0d0 )
8829
END DO
8830
END DO
8831
CALL ListPopActiveName()
8832
END IF
8833
END FUNCTION ListGetConstRealArray
8834
!------------------------------------------------------------------------------
8835
8836
8837
!------------------------------------------------------------------------------
8838
!> Gets an 1D constant real array from the list by its name.
8839
!------------------------------------------------------------------------------
8840
RECURSIVE FUNCTION ListGetConstRealArray1( List,Name,Found,UnfoundFatal ) RESULT( F )
8841
!------------------------------------------------------------------------------
8842
TYPE(ValueList_t), POINTER :: List
8843
CHARACTER(LEN=*) :: Name
8844
LOGICAL, OPTIONAL :: Found, UnfoundFatal
8845
!------------------------------------------------------------------------------
8846
REAL(KIND=dp), POINTER :: F(:)
8847
INTEGER :: i,j,n,m
8848
TYPE(ValueListEntry_t), POINTER :: ptr
8849
!------------------------------------------------------------------------------
8850
NULLIFY( F )
8851
ptr => ListFind(List,Name,Found)
8852
IF (.NOT.ASSOCIATED(ptr) ) THEN
8853
IF(PRESENT(UnfoundFatal)) THEN
8854
IF(UnfoundFatal) THEN
8855
CALL Fatal("ListGetConstRealArray1","Failed to find: "//TRIM(Name))
8856
END IF
8857
END IF
8858
RETURN
8859
END IF
8860
8861
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
8862
CALL Fatal( 'ListGetConstRealArray1', 'Value type for property ['//TRIM(Name)// &
8863
'] not used consistently.')
8864
END IF
8865
8866
n = SIZE( ptr % FValues,1 )
8867
m = SIZE( ptr % FValues,2 )
8868
IF( m > 1 ) THEN
8869
CALL Warn('ListGetConstRealArray1','The routine is designed for 1D arrays!')
8870
END IF
8871
8872
F => ptr % FValues(:,1,1)
8873
8874
END FUNCTION ListGetConstRealArray1
8875
!------------------------------------------------------------------------------
8876
8877
8878
8879
!------------------------------------------------------------------------------
8880
!> Gets a real array from the list by its name,
8881
!------------------------------------------------------------------------------
8882
RECURSIVE SUBROUTINE ListGetRealArray( List,Name,F,ni,NodeIndexes,Found, UnfoundFatal)
8883
!------------------------------------------------------------------------------
8884
TYPE(ValueList_t), POINTER :: List
8885
CHARACTER(LEN=*) :: Name
8886
LOGICAL, OPTIONAL :: Found, UnfoundFatal
8887
INTEGER :: ni,NodeIndexes(:)
8888
REAL(KIND=dp), POINTER :: F(:,:,:), G(:,:)
8889
!------------------------------------------------------------------------------
8890
TYPE(ValueListEntry_t), POINTER :: ptr
8891
8892
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
8893
8894
REAL(KIND=dp) :: T(MAX_FNC)
8895
LOGICAL :: AllGlobal
8896
INTEGER :: i,j,k,nlen,n,m,k1,l
8897
!------------------------------------------------------------------------------
8898
ptr => ListFind(List,Name,Found)
8899
IF ( .NOT.ASSOCIATED(ptr) ) THEN
8900
IF(PRESENT(UnfoundFatal)) THEN
8901
IF(UnfoundFatal) THEN
8902
CALL Fatal("ListGetConstRealArray","Failed to find: "//TRIM(Name))
8903
END IF
8904
END IF
8905
RETURN
8906
END IF
8907
8908
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
8909
CALL Fatal( 'ListGetRealArray', &
8910
'Value type for property > '// TRIM(Name) // '< not used consistently.')
8911
END IF
8912
8913
n = SIZE(ptr % FValues,1)
8914
m = SIZE(ptr % FValues,2)
8915
8916
IF ( .NOT.ASSOCIATED( F ) ) THEN
8917
ALLOCATE( F(n,m,ni) )
8918
ELSE IF ( SIZE(F,1)/=n.OR.SIZE(F,2)/=n.OR.SIZE(F,3)/=ni ) THEN
8919
DEALLOCATE( F )
8920
ALLOCATE( F(n,m,ni) )
8921
END IF
8922
8923
8924
SELECT CASE(ptr % TYPE)
8925
CASE ( LIST_TYPE_CONSTANT_TENSOR )
8926
DO i=1,ni
8927
F(:,:,i) = ptr % Coeff * ptr % FValues(:,:,1)
8928
END DO
8929
8930
IF ( ptr % PROCEDURE /= 0 ) THEN
8931
CALL ListPushActiveName(name)
8932
DO i=1,n
8933
DO j=1,m
8934
F(i,j,1) = ptr % Coeff * &
8935
ExecConstRealFunction( ptr % PROCEDURE, &
8936
CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp )
8937
END DO
8938
END DO
8939
CALL ListPopActiveName()
8940
END IF
8941
8942
8943
CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR )
8944
8945
CALL ListPushActiveName(name)
8946
DO i=1,ni
8947
k = NodeIndexes(i)
8948
CALL ListParseStrToValues( Ptr % DependName, Ptr % DepNameLen, k, Name, T, j, AllGlobal)
8949
IF ( ANY(T(1:j)==HUGE(1._dP)) ) CYCLE
8950
8951
IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN
8952
IF ( .NOT. ptr % LuaFun ) THEN
8953
F(1:n,1:m,i) = GetMatcRealArray(ptr % Cvalue,n,m,j,T)
8954
ELSE
8955
call ElmerEvalLuaT(LuaState, ptr, T, F(:,:,i), j)
8956
END IF
8957
ELSE IF ( ptr % PROCEDURE /= 0 ) THEN
8958
G => F(:,:,i)
8959
CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, &
8960
NodeIndexes(i), T, G )
8961
ELSE
8962
DO j=1,n
8963
DO k=1,m
8964
F(j,k,i) = InterpolateCurve(ptr % TValues, ptr % FValues(j,k,:), &
8965
T(1), ptr % CubicCoeff )
8966
END DO
8967
END DO
8968
END IF
8969
IF( AllGlobal ) EXIT
8970
END DO
8971
CALL ListPopActiveName()
8972
8973
IF( AllGlobal ) THEN
8974
DO i=2,ni
8975
DO j=1,n
8976
DO k=1,m
8977
F(j,k,i) = F(j,k,1)
8978
END DO
8979
END DO
8980
END DO
8981
END IF
8982
8983
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
8984
F = ptr % Coeff * F
8985
END IF
8986
8987
CASE DEFAULT
8988
F = 0.0d0
8989
DO i=1,n
8990
IF ( PRESENT( Found ) ) THEN
8991
F(i,1,:) = ListGetReal( List,Name,ni,NodeIndexes,Found )
8992
ELSE
8993
F(i,1,:) = ListGetReal( List,Name,ni,NodeIndexes )
8994
END IF
8995
END DO
8996
END SELECT
8997
!------------------------------------------------------------------------------
8998
END SUBROUTINE ListGetRealArray
8999
!------------------------------------------------------------------------------
9000
9001
!------------------------------------------------------------------------------
9002
!> Gets a real vector from the list by its name
9003
!------------------------------------------------------------------------------
9004
RECURSIVE SUBROUTINE ListGetRealVector( List,Name,F,ni,NodeIndexes,Found )
9005
!------------------------------------------------------------------------------
9006
TYPE(ValueList_t), POINTER :: List
9007
CHARACTER(LEN=*) :: Name
9008
LOGICAL, OPTIONAL :: Found
9009
INTEGER :: ni,NodeIndexes(:)
9010
REAL(KIND=dp), TARGET :: F(:,:)
9011
!------------------------------------------------------------------------------
9012
TYPE(ValueListEntry_t), POINTER :: ptr
9013
9014
TYPE(Variable_t), POINTER :: Variable, CVar, TVar
9015
9016
REAL(KIND=dp), ALLOCATABLE :: G(:,:)
9017
REAL(KIND=dp) :: T(MAX_FNC)
9018
REAL(KIND=dp), POINTER :: RotMatrix(:,:)
9019
INTEGER :: i,j,k,nlen,n,m,k1,S1,S2,l, cnt
9020
LOGICAL :: AllGlobal, lFound, AnyFound
9021
!------------------------------------------------------------------------------
9022
ptr => ListFind(List,Name,lFound)
9023
IF ( .NOT.ASSOCIATED(ptr) ) THEN
9024
IF(PRESENT(Found)) Found = .FALSE.
9025
AnyFound = .FALSE.
9026
DO i=1,SIZE(F,1)
9027
F(i,1:ni) = ListGetReal(List,TRIM(Name)//' '//I2S(i),ni,NodeIndexes,lFound)
9028
AnyFound = AnyFound.OR.lFound
9029
END DO
9030
IF(PRESENT(Found)) THEN
9031
Found = AnyFound
9032
ELSE IF(.NOT.AnyFound) THEN
9033
CALL Warn( 'ListFind', 'Requested property ['//TRIM(Name)//'] not found')
9034
END IF
9035
IF( .NOT. AnyFound ) RETURN
9036
GOTO 200
9037
ELSE
9038
Found = lFound
9039
END IF
9040
9041
F = 0._dp
9042
cnt = 0
9043
ALLOCATE(G(SIZE(F,1),SIZE(F,2)))
9044
9045
100 CONTINUE
9046
9047
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
9048
CALL Fatal( 'ListGetRealVector', &
9049
'Value type for property > '// TRIM(Name) // '< not used consistently.')
9050
END IF
9051
9052
n = SIZE(ptr % FValues,1)
9053
9054
SELECT CASE(ptr % TYPE)
9055
CASE ( LIST_TYPE_CONSTANT_TENSOR )
9056
DO i=1,n
9057
G(:,i) = ptr % Coeff * ptr % FValues(:,1,1)
9058
END DO
9059
9060
IF ( ptr % PROCEDURE /= 0 ) THEN
9061
CALL ListPushActiveName(name)
9062
DO i=1,n
9063
F(i,1) = ptr % Coeff * &
9064
ExecConstRealFunction( ptr % PROCEDURE, &
9065
CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp )
9066
END DO
9067
CALL ListPopActiveName()
9068
END IF
9069
9070
CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR )
9071
9072
CALL ListPushActiveName(name)
9073
DO i=1,ni
9074
k = NodeIndexes(i)
9075
CALL ListParseStrToValues( Ptr % DependName, Ptr % DepNameLen, k, Name, T, j, AllGlobal)
9076
IF ( ANY(T(1:j)==HUGE(1._dP)) ) CYCLE
9077
9078
IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN
9079
IF ( .NOT. ptr % LuaFun ) THEN
9080
G(1:n,i) = GetMatcRealVector(ptr % Cvalue,n,j,T)
9081
ELSE
9082
CALL ElmerEvalLuaV(LuaState, ptr, T, G(:,i), j)
9083
END IF
9084
ELSE IF ( ptr % PROCEDURE /= 0 ) THEN
9085
CALL ExecRealVectorFunction( ptr % PROCEDURE, CurrentModel, &
9086
NodeIndexes(i), T, G(:,i) )
9087
ELSE
9088
DO k=1,n
9089
G(k,i) = InterpolateCurve(ptr % TValues, &
9090
ptr % FValues(k,1,:), T(MIN(j,k)), ptr % CubicCoeff )
9091
END DO
9092
END IF
9093
9094
IF( AllGlobal ) EXIT
9095
END DO
9096
CALL ListPopActiveName()
9097
9098
IF( AllGlobal ) THEN
9099
DO i=2,ni
9100
DO j=1,n
9101
G(j,i) = G(j,1)
9102
END DO
9103
END DO
9104
END IF
9105
9106
IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN
9107
G = ptr % Coeff * G
9108
END IF
9109
9110
CASE DEFAULT
9111
G = 0.0d0
9112
DO i=1,n
9113
IF ( PRESENT( Found ) ) THEN
9114
G(i,1:ni) = ListGetReal( List,Name,ni,NodeIndexes,Found )
9115
ELSE
9116
G(i,1:ni) = ListGetReal( List,Name,ni,NodeIndexes )
9117
END IF
9118
END DO
9119
END SELECT
9120
9121
9122
F = F + G
9123
cnt = cnt + 1
9124
ptr => ListFind(List,Name//'{'//I2S(cnt)//'}',lFound)
9125
IF(ASSOCIATED(ptr)) GOTO 100
9126
9127
200 IF( ListGetLogical( List, Name//' Property Rotate', lFound ) ) THEN
9128
RotMatrix => ListGetConstRealArray( List,'Property Rotation Matrix',lFound )
9129
IF( .NOT. ASSOCIATED( RotMatrix ) ) THEN
9130
CALL Fatal('ListGetRealVector','Property rotation matrix not given for: '//TRIM(Name))
9131
END IF
9132
IF( SIZE(F,1) /= 3 ) THEN
9133
CALL Fatal('ListGetRealVector','Property may be rotated only with three components!')
9134
END IF
9135
DO i = 1,SIZE(F,2)
9136
F(1:3,i) = MATMUL( RotMatrix, F(1:3,i) )
9137
END DO
9138
END IF
9139
9140
9141
!------------------------------------------------------------------------------
9142
END SUBROUTINE ListGetRealVector
9143
!------------------------------------------------------------------------------
9144
9145
9146
!------------------------------------------------------------------------------
9147
!> Gets a real derivative from. This is only available for tables with dependencies.
9148
!------------------------------------------------------------------------------
9149
RECURSIVE FUNCTION ListGetDerivValue(List,Name,N,NodeIndexes,dT) RESULT(F)
9150
!------------------------------------------------------------------------------
9151
TYPE(ValueList_t), POINTER :: List
9152
CHARACTER(LEN=*) :: Name
9153
INTEGER :: N,NodeIndexes(:)
9154
REAL(KIND=dp), OPTIONAL :: dT
9155
REAL(KIND=dp) :: F(N)
9156
!------------------------------------------------------------------------------
9157
TYPE(Variable_t), POINTER :: Variable
9158
TYPE(ValueListEntry_t), POINTER :: ptr
9159
INTEGER :: i,k,l
9160
REAL(KIND=dp) :: T,T1(1),T2(1),F1,F2
9161
!------------------------------------------------------------------------------
9162
9163
F = 0.0D0
9164
ptr => ListFind(List,Name)
9165
9166
9167
IF ( .NOT.ASSOCIATED(ptr) ) RETURN
9168
9169
9170
SELECT CASE(ptr % TYPE)
9171
CASE( LIST_TYPE_VARIABLE_SCALAR )
9172
9173
IF ( ptr % PROCEDURE /= 0 ) THEN
9174
IF( .NOT. PRESENT( dT ) ) THEN
9175
CALL Fatal('ListGetDerivValue','Numerical derivative of function requires dT')
9176
END IF
9177
Variable => VariableGet( CurrentModel % Variables,ptr % DependName )
9178
IF( .NOT. ASSOCIATED( Variable ) ) THEN
9179
CALL Fatal('ListGetDeriveValue','Cannot derivate with variable: '//TRIM(ptr % DependName))
9180
END IF
9181
9182
DO i=1,n
9183
k = NodeIndexes(i)
9184
IF ( ASSOCIATED(Variable % Perm) ) k = Variable % Perm(k)
9185
IF ( k > 0 ) THEN
9186
T = Variable % Values(k)
9187
T1(1) = T + 0.5_dp * dT
9188
T2(1) = T - 0.5_dp * dT
9189
F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndexes(i), T1 )
9190
F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndexes(i), T2 )
9191
F(i) = ptr % Coeff * ( F1 - F2 ) / dT
9192
END IF
9193
END DO
9194
9195
ELSE
9196
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
9197
CALL Fatal( 'ListGetDerivValue', &
9198
'Value type for property > '// TRIM(Name) // '< not used consistently.')
9199
END IF
9200
Variable => VariableGet( CurrentModel % Variables,ptr % DependName )
9201
IF( .NOT. ASSOCIATED( Variable ) ) THEN
9202
CALL Fatal('ListGetDeriveValue','Cannot derivate with variable: '//TRIM(ptr % DependName))
9203
END IF
9204
DO i=1,n
9205
k = NodeIndexes(i)
9206
IF ( ASSOCIATED(Variable % Perm) ) k = Variable % Perm(k)
9207
IF ( k > 0 ) THEN
9208
T = Variable % Values(k)
9209
F(i) = ptr % Coeff * &
9210
DerivateCurve(ptr % TValues,ptr % FValues(1,1,:), &
9211
T, ptr % CubicCoeff )
9212
END IF
9213
END DO
9214
END IF
9215
9216
9217
CASE DEFAULT
9218
CALL Fatal( 'ListGetDerivValue', &
9219
'No automated derivation possible for > '//TRIM(Name)//' <' )
9220
9221
END SELECT
9222
9223
9224
END FUNCTION ListGetDerivValue
9225
!------------------------------------------------------------------------------
9226
9227
9228
!------------------------------------------------------------------------------
9229
!> Given the body of a keyword find the 1st free keyword in the list structure.
9230
!> The intended use for this is in Solver_init to decleare exported variables
9231
!> without the risk of running over some existing ones.
9232
!------------------------------------------------------------------------------
9233
FUNCTION NextFreeKeyword(keyword0,List) RESULT (Keyword)
9234
9235
CHARACTER(LEN=*) :: Keyword0
9236
TYPE(ValueList_t), POINTER :: List
9237
CHARACTER(:), ALLOCATABLE :: Keyword
9238
INTEGER :: No
9239
9240
DO No = 1, 9999
9241
Keyword = TRIM(Keyword0)//' '//I2S(No)
9242
IF( .NOT. ListCheckPresent(List,Keyword)) EXIT
9243
END DO
9244
9245
!------------------------------------------------------------------------------
9246
END FUNCTION NextFreeKeyword
9247
!------------------------------------------------------------------------------
9248
9249
9250
!------------------------------------------------------------------------------
9251
!> Check if the keyword is present in any boundary condition.
9252
!------------------------------------------------------------------------------
9253
FUNCTION ListCheckPresentAnyBC( Model, Name, ValueLst ) RESULT(Found)
9254
!------------------------------------------------------------------------------
9255
TYPE(Model_t) :: Model
9256
CHARACTER(LEN=*) :: Name
9257
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9258
LOGICAL :: Found
9259
INTEGER :: bc
9260
9261
Found = .FALSE.
9262
IF(PRESENT(ValueLst)) ValueLst => NULL()
9263
DO bc = 1,Model % NumberOfBCs
9264
Found = ListCheckPresent( Model % BCs(bc) % Values, Name )
9265
IF( Found ) THEN
9266
IF(PRESENT(ValueLst)) ValueLst => Model % BCs(bc) % Values
9267
EXIT
9268
END IF
9269
END DO
9270
!------------------------------------------------------------------------------
9271
END FUNCTION ListCheckPresentAnyBC
9272
!------------------------------------------------------------------------------
9273
9274
!------------------------------------------------------------------------------
9275
!> Check if the keyword is present in any boundary condition.
9276
!------------------------------------------------------------------------------
9277
FUNCTION ListCheckPresentAnyIC( Model, Name, ValueLst ) RESULT(Found)
9278
!------------------------------------------------------------------------------
9279
TYPE(Model_t) :: Model
9280
CHARACTER(LEN=*) :: Name
9281
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9282
LOGICAL :: Found
9283
INTEGER :: ic
9284
9285
Found = .FALSE.
9286
IF(PRESENT(ValueLst)) ValueLst => NULL()
9287
DO ic = 1,Model % NumberOfICs
9288
Found = ListCheckPresent( Model % ICs(ic) % Values, Name )
9289
IF( Found ) THEN
9290
IF(PRESENT(ValueLst)) ValueLst => Model % ICs(ic) % Values
9291
EXIT
9292
END IF
9293
END DO
9294
!------------------------------------------------------------------------------
9295
END FUNCTION ListCheckPresentAnyIC
9296
!------------------------------------------------------------------------------
9297
9298
!------------------------------------------------------------------------------
9299
!> Check if the keyword is True in any boundary condition.
9300
!------------------------------------------------------------------------------
9301
FUNCTION ListGetLogicalAnyBC( Model, Name ) RESULT(Found)
9302
!------------------------------------------------------------------------------
9303
TYPE(Model_t) :: Model
9304
CHARACTER(LEN=*) :: Name
9305
LOGICAL :: Found, GotIt
9306
INTEGER :: bc
9307
9308
Found = .FALSE.
9309
DO bc = 1,Model % NumberOfBCs
9310
Found = ListgetLogical( Model % BCs(bc) % Values, Name, GotIt )
9311
IF( Found ) EXIT
9312
END DO
9313
!------------------------------------------------------------------------------
9314
END FUNCTION ListGetLogicalAnyBC
9315
!------------------------------------------------------------------------------
9316
9317
9318
!------------------------------------------------------------------------------
9319
!> Check if the keyword is present in any body.
9320
!------------------------------------------------------------------------------
9321
FUNCTION ListCheckPresentAnyBody( Model, Name, ValueLst ) RESULT(Found)
9322
!------------------------------------------------------------------------------
9323
TYPE(Model_t) :: Model
9324
CHARACTER(LEN=*) :: Name
9325
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9326
LOGICAL :: Found
9327
INTEGER :: body
9328
9329
Found = .FALSE.
9330
IF(PRESENT(ValueLst)) ValueLst => NULL()
9331
DO body = 1,Model % NumberOfBodies
9332
Found = ListCheckPresent( Model % Bodies(body) % Values, Name )
9333
IF( Found ) THEN
9334
IF(PRESENT(ValueLst)) ValueLst => Model % Bodies(body) % Values
9335
EXIT
9336
END IF
9337
END DO
9338
!------------------------------------------------------------------------------
9339
END FUNCTION ListCheckPresentAnyBody
9340
!------------------------------------------------------------------------------
9341
9342
!------------------------------------------------------------------------------
9343
!> Check if the keyword is true in any body.
9344
!------------------------------------------------------------------------------
9345
FUNCTION ListGetLogicalAnyBody( Model, Name ) RESULT(Found)
9346
!------------------------------------------------------------------------------
9347
TYPE(Model_t) :: Model
9348
CHARACTER(LEN=*) :: Name
9349
LOGICAL :: Found
9350
INTEGER :: body
9351
LOGICAL :: GotIt
9352
9353
Found = .FALSE.
9354
DO body = 1,Model % NumberOfBodies
9355
Found = ListGetLogical( Model % Bodies(body) % Values, Name, GotIt )
9356
IF( Found ) EXIT
9357
END DO
9358
!------------------------------------------------------------------------------
9359
END FUNCTION ListGetLogicalAnyBody
9360
!------------------------------------------------------------------------------
9361
9362
9363
!------------------------------------------------------------------------------
9364
!> Check if the keyword is true in any body.
9365
!------------------------------------------------------------------------------
9366
FUNCTION ListGetCRealAnyBody( Model, Name, Found ) RESULT( F )
9367
!------------------------------------------------------------------------------
9368
TYPE(Model_t) :: Model
9369
CHARACTER(LEN=*) :: Name
9370
LOGICAL, OPTIONAL :: Found
9371
REAL(KIND=dp) :: F
9372
9373
INTEGER :: body
9374
LOGICAL :: GotIt
9375
9376
F = 0.0_dp
9377
GotIt = .FALSE.
9378
DO body = 1,Model % NumberOfBodies
9379
F = ListGetCReal( Model % Bodies(body) % Values, Name, GotIt )
9380
IF( GotIt ) EXIT
9381
END DO
9382
9383
IF( PRESENT( Found ) ) Found = GotIt
9384
9385
!------------------------------------------------------------------------------
9386
END FUNCTION ListGetCRealAnyBody
9387
!------------------------------------------------------------------------------
9388
9389
!------------------------------------------------------------------------------
9390
!> Check if the keyword is present in any body force.
9391
!------------------------------------------------------------------------------
9392
FUNCTION ListCheckPresentAnyBodyForce( Model, Name, ValueLst ) RESULT(Found)
9393
!------------------------------------------------------------------------------
9394
TYPE(Model_t) :: Model
9395
CHARACTER(LEN=*) :: Name
9396
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9397
LOGICAL :: Found
9398
INTEGER :: bf
9399
9400
Found = .FALSE.
9401
IF(PRESENT(ValueLst)) ValueLst => NULL()
9402
DO bf = 1,Model % NumberOfBodyForces
9403
Found = ListCheckPresent( Model % BodyForces(bf) % Values, Name )
9404
IF( Found ) THEN
9405
IF(PRESENT(ValueLst)) ValueLst => Model % BodyForces(bf) % Values
9406
EXIT
9407
END IF
9408
END DO
9409
!------------------------------------------------------------------------------
9410
END FUNCTION ListCheckPresentAnyBodyForce
9411
!------------------------------------------------------------------------------
9412
9413
!------------------------------------------------------------------------------
9414
!> Check if the keyword is True in any body force.
9415
!------------------------------------------------------------------------------
9416
FUNCTION ListGetLogicalAnyBodyForce( Model, Name ) RESULT(Found)
9417
!------------------------------------------------------------------------------
9418
TYPE(Model_t) :: Model
9419
CHARACTER(LEN=*) :: Name
9420
LOGICAL :: Found, GotIt
9421
INTEGER :: bf
9422
9423
Found = .FALSE.
9424
DO bf = 1,Model % NumberOfBodyForces
9425
Found = ListGetLogical( Model % BodyForces(bf) % Values, Name, GotIt )
9426
IF( Found ) EXIT
9427
END DO
9428
!------------------------------------------------------------------------------
9429
END FUNCTION ListGetLogicalAnyBodyForce
9430
!------------------------------------------------------------------------------
9431
9432
!------------------------------------------------------------------------------
9433
!> Check if the keyword is present in any material.
9434
!------------------------------------------------------------------------------
9435
FUNCTION ListCheckPresentAnyMaterial( Model, Name, ValueLst ) RESULT(Found)
9436
!------------------------------------------------------------------------------
9437
TYPE(Model_t) :: Model
9438
CHARACTER(LEN=*) :: Name
9439
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9440
LOGICAL :: Found
9441
INTEGER :: mat
9442
9443
Found = .FALSE.
9444
IF(PRESENT(ValueLst)) ValueLst => NULL()
9445
DO mat = 1,Model % NumberOfMaterials
9446
Found = ListCheckPresent( Model % Materials(mat) % Values, Name )
9447
IF( Found ) THEN
9448
IF(PRESENT(ValueLst)) ValueLst => Model % Materials(mat) % Values
9449
EXIT
9450
END IF
9451
END DO
9452
!------------------------------------------------------------------------------
9453
END FUNCTION ListCheckPresentAnyMaterial
9454
!------------------------------------------------------------------------------
9455
9456
9457
!------------------------------------------------------------------------------
9458
!> Check if the keyword is present in any solver.
9459
!------------------------------------------------------------------------------
9460
FUNCTION ListCheckPresentAnySolver( Model, Name, ValueLst ) RESULT(Found)
9461
!------------------------------------------------------------------------------
9462
TYPE(Model_t) :: Model
9463
CHARACTER(LEN=*) :: Name
9464
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9465
LOGICAL :: Found
9466
INTEGER :: ind
9467
9468
Found = .FALSE.
9469
IF(PRESENT(ValueLst)) ValueLst => NULL()
9470
DO ind = 1,Model % NumberOfSolvers
9471
Found = ListCheckPresent( Model % Solvers(ind) % Values, Name )
9472
IF( Found ) THEN
9473
IF(PRESENT(ValueLst)) ValueLst => Model % Solvers(ind) % Values
9474
EXIT
9475
END IF
9476
END DO
9477
!------------------------------------------------------------------------------
9478
END FUNCTION ListCheckPresentAnySolver
9479
!------------------------------------------------------------------------------
9480
9481
9482
9483
!------------------------------------------------------------------------------
9484
!> Check if the keyword is present in any component.
9485
!------------------------------------------------------------------------------
9486
FUNCTION ListCheckPresentAnyComponent( Model, Name, ValueLst ) RESULT( Found )
9487
!------------------------------------------------------------------------------
9488
IMPLICIT NONE
9489
TYPE(Model_t) :: Model
9490
CHARACTER(LEN=*) :: Name
9491
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9492
LOGICAL :: Found
9493
INTEGER :: ind
9494
9495
Found = .FALSE.
9496
IF(PRESENT(ValueLst)) ValueLst => NULL()
9497
DO ind=1, Model % NumberOfComponents
9498
Found = ListCheckPresent( Model % Components(ind) % Values, Name )
9499
IF( Found ) THEN
9500
IF(PRESENT(ValueLst)) ValueLst => Model % Components(ind) % Values
9501
EXIT
9502
END IF
9503
END DO
9504
!------------------------------------------------------------------------------
9505
END FUNCTION ListCheckPresentAnyComponent
9506
!------------------------------------------------------------------------------
9507
9508
9509
!------------------------------------------------------------------------------
9510
FUNCTION ListCheckPrefixAnyComponent( Model, Name ) RESULT( Found )
9511
!------------------------------------------------------------------------------
9512
IMPLICIT NONE
9513
TYPE(Model_t) :: Model
9514
CHARACTER(LEN=*) :: Name
9515
LOGICAL :: Found
9516
INTEGER :: ind
9517
TYPE(ValueListEntry_t), POINTER :: ptr
9518
9519
Found = .FALSE.
9520
DO ind=1, Model % NumberOfComponents
9521
ptr => ListFindPrefix( Model % Components(ind) % Values, Name, Found )
9522
IF( Found ) EXIT
9523
END DO
9524
!------------------------------------------------------------------------------
9525
END FUNCTION ListCheckPrefixAnyComponent
9526
!------------------------------------------------------------------------------
9527
9528
9529
9530
!------------------------------------------------------------------------------
9531
!> Check if the keyword is true in any component.
9532
!------------------------------------------------------------------------------
9533
FUNCTION ListGetLogicalAnyComponent( Model, Name ) RESULT( Found )
9534
!------------------------------------------------------------------------------
9535
IMPLICIT NONE
9536
9537
TYPE(Model_t) :: Model
9538
CHARACTER(LEN=*) :: Name
9539
LOGICAL :: Found, GotIt
9540
INTEGER :: ind
9541
9542
Found = .FALSE.
9543
DO ind=1, Model % NumberOfComponents
9544
Found = ListGetLogical( Model % Components(ind) % Values, Name, GotIt )
9545
IF( Found ) EXIT
9546
END DO
9547
!------------------------------------------------------------------------------
9548
END FUNCTION ListGetLogicalAnyComponent
9549
!------------------------------------------------------------------------------
9550
9551
!------------------------------------------------------------------------------
9552
!> Check if the keyword in any material is defined as an array
9553
!------------------------------------------------------------------------------
9554
FUNCTION ListCheckAnyMaterialIsArray( Model, Name ) RESULT(IsArray)
9555
!------------------------------------------------------------------------------
9556
TYPE(Model_t) :: Model
9557
CHARACTER(LEN=*) :: Name
9558
LOGICAL :: IsArray
9559
LOGICAL :: Found
9560
INTEGER :: mat, n, m
9561
TYPE(ValueListEntry_t), POINTER :: ptr
9562
9563
IsArray = .FALSE.
9564
DO mat = 1,Model % NumberOfMaterials
9565
ptr => ListFind(Model % Materials(mat) % Values,Name,Found)
9566
IF( .NOT. ASSOCIATED( ptr ) ) CYCLE
9567
IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN
9568
CALL Fatal( 'ListCheckAnyMaterialArray', 'Value type for property ['//TRIM(Name)// &
9569
'] not used consistently.')
9570
END IF
9571
n = SIZE( ptr % FValues,1 )
9572
m = SIZE( ptr % FValues,2 )
9573
IsArray = ( n > 1 ) .OR. ( m > 1 )
9574
IF( IsArray ) EXIT
9575
END DO
9576
!------------------------------------------------------------------------------
9577
END FUNCTION ListCheckAnyMaterialIsArray
9578
!------------------------------------------------------------------------------
9579
9580
9581
!------------------------------------------------------------------------------
9582
!> Check if the keyword is True in any material.
9583
!------------------------------------------------------------------------------
9584
FUNCTION ListGetLogicalAnyMaterial( Model, Name ) RESULT(Found)
9585
!------------------------------------------------------------------------------
9586
TYPE(Model_t) :: Model
9587
CHARACTER(LEN=*) :: Name
9588
LOGICAL :: Found, GotIt
9589
INTEGER :: mat
9590
9591
Found = .FALSE.
9592
DO mat = 1,Model % NumberOfMaterials
9593
Found = ListGetLogical( Model % Materials(mat) % Values, Name, GotIt )
9594
IF( Found ) EXIT
9595
END DO
9596
!------------------------------------------------------------------------------
9597
END FUNCTION ListGetLogicalAnyMaterial
9598
!------------------------------------------------------------------------------
9599
9600
9601
!------------------------------------------------------------------------------
9602
!> Check if the keyword is True in any solver.
9603
!------------------------------------------------------------------------------
9604
FUNCTION ListGetLogicalAnySolver( Model, Name ) RESULT(Found)
9605
!------------------------------------------------------------------------------
9606
TYPE(Model_t) :: Model
9607
CHARACTER(LEN=*) :: Name
9608
LOGICAL :: Found, GotIt
9609
INTEGER :: ind
9610
9611
Found = .FALSE.
9612
DO ind = 1,Model % NumberOfSolvers
9613
Found = ListGetLogical( Model % Solvers(ind) % Values, Name, GotIt )
9614
IF( Found ) EXIT
9615
END DO
9616
!------------------------------------------------------------------------------
9617
END FUNCTION ListGetLogicalAnySolver
9618
!------------------------------------------------------------------------------
9619
9620
9621
!------------------------------------------------------------------------------
9622
!> Check if the keyword is present in any equation.
9623
!------------------------------------------------------------------------------
9624
FUNCTION ListCheckPresentAnyEquation( Model, Name, ValueLst ) RESULT(Found)
9625
!------------------------------------------------------------------------------
9626
TYPE(Model_t) :: Model
9627
CHARACTER(LEN=*) :: Name
9628
TYPE(ValueList_t), POINTER, OPTIONAL :: ValueLst
9629
LOGICAL :: Found
9630
INTEGER :: eq
9631
9632
Found = .FALSE.
9633
IF(PRESENT(ValueLst)) ValueLst => NULL()
9634
DO eq = 1,Model % NumberOfEquations
9635
Found = ListCheckPresent( Model % Equations(eq) % Values, Name )
9636
IF( Found ) THEN
9637
IF(PRESENT(ValueLst)) ValueLst => Model % Equations(eq) % Values
9638
EXIT
9639
END IF
9640
END DO
9641
!------------------------------------------------------------------------------
9642
END FUNCTION ListCheckPresentAnyEquation
9643
!------------------------------------------------------------------------------
9644
9645
!------------------------------------------------------------------------------
9646
!> Check if the keyword is True in any equation.
9647
!------------------------------------------------------------------------------
9648
FUNCTION ListGetLogicalAnyEquation( Model, Name ) RESULT(Found)
9649
!------------------------------------------------------------------------------
9650
TYPE(Model_t) :: Model
9651
CHARACTER(LEN=*) :: Name
9652
LOGICAL :: Found, GotIt
9653
INTEGER :: eq
9654
9655
Found = .FALSE.
9656
DO eq = 1,Model % NumberOfEquations
9657
Found = ListGetLogical( Model % Equations(eq) % Values, Name, GotIt )
9658
IF( Found ) EXIT
9659
END DO
9660
!------------------------------------------------------------------------------
9661
END FUNCTION ListGetLogicalAnyEquation
9662
!------------------------------------------------------------------------------
9663
9664
9665
!------------------------------------------------------------------------------
9666
!> Elmer may include scalar and vector variables which may be known by their
9667
!> original name or have an alias. For historical reasons they are introduced
9668
!> by two quite separate ways. This subroutine tries to make the definition of
9669
!> variables for saving more straight-forward.
9670
!------------------------------------------------------------------------------
9671
SUBROUTINE CreateListForSaving( Model, List, ShowVariables, ClearList, &
9672
UseGenericKeyword )
9673
!------------------------------------------------------------------------------
9674
IMPLICIT NONE
9675
!------------------------------------------------------------------------------
9676
TYPE(Model_t) :: Model
9677
TYPE(ValueList_t), POINTER :: List
9678
LOGICAL :: ShowVariables
9679
LOGICAL, OPTIONAL :: ClearList
9680
LOGICAL, OPTIONAL :: UseGenericKeyword
9681
!------------------------------------------------------------------------------
9682
INTEGER :: i,j,k,l,LoopDim, VarDim,FullDim,DOFs,dim,Comp
9683
TYPE(Variable_t), POINTER :: Variables, Var, Var1
9684
CHARACTER(LEN=2*MAX_NAME_LEN) :: VarName, VarStr, str
9685
LOGICAL :: IsVector, Set, GotIt, ComponentVector, ThisOnly, IsIndex, &
9686
EnforceVectors, UseGeneric, DisplacementV
9687
INTEGER :: Nvector, Nscalar
9688
TYPE(ValueList_t), POINTER :: Params
9689
9690
Params => Model % Solver % Values
9691
Variables => Model % Mesh % Variables
9692
9693
IF( .NOT. ASSOCIATED( Variables ) ) THEN
9694
CALL Warn('CreateListForSaving','Mesh does not include any variables!')
9695
RETURN
9696
END IF
9697
9698
UseGeneric = .FALSE.
9699
IF( PRESENT( UseGenericKeyword ) ) THEN
9700
UseGeneric = UseGenericKeyword
9701
END IF
9702
9703
9704
!------------------------------------------------------------------------------
9705
! Sometimes the list must be cleared in order to use it for a different mesh
9706
!-----------------------------------------------------------------------------
9707
IF( PRESENT( ClearList ) ) THEN
9708
IF( ClearList ) THEN
9709
IF( UseGeneric ) THEN
9710
DO i=1,999
9711
WRITE(VarStr,'(A,I0)') 'Variable ',i
9712
IF( ListCheckPresent( List, VarStr ) ) THEN
9713
CALL ListRemove( List, VarStr )
9714
ELSE
9715
EXIT
9716
END IF
9717
END DO
9718
ELSE
9719
DO i=1,999
9720
WRITE(VarStr,'(A,I0)') 'Scalar Field ',i
9721
IF( ListCheckPresent( List, VarStr ) ) THEN
9722
CALL ListRemove( List, VarStr )
9723
ELSE
9724
EXIT
9725
END IF
9726
END DO
9727
9728
DO i=1,999
9729
WRITE(VarStr,'(A,I0)') 'Vector Field ',i
9730
IF( ListCheckPresent( List, VarStr ) ) THEN
9731
CALL ListRemove( List, VarStr )
9732
ELSE
9733
EXIT
9734
END IF
9735
9736
WRITE(VarStr,'(A,I0,A)') 'Vector Field ',i,' Complement'
9737
IF( ListCheckPresent( List, VarStr ) ) THEN
9738
CALL ListRemove( List, VarStr )
9739
END IF
9740
END DO
9741
9742
END IF
9743
END IF
9744
END IF
9745
9746
!-------------------------------------------------------------------
9747
! First check that there is a need to create the list i.e. it is not
9748
! already manually defined
9749
!-------------------------------------------------------------------
9750
IF( UseGeneric ) THEN
9751
IF( ListCheckPresent( List,'Variable 1' ) ) THEN
9752
CALL Info('CreateListForSaving','Variable 1 exists, creating no list!',Level=10)
9753
RETURN
9754
END IF
9755
ELSE
9756
IF( ListCheckPresent( List,'Scalar Field 1' ) ) THEN
9757
CALL Info('CreateListForSaving','Scalar Field 1 exists, creating no list!',Level=10)
9758
RETURN
9759
END IF
9760
9761
IF( ListCheckPresent( List,'Vector Field 1' ) ) THEN
9762
CALL Info('CreateListForSaving','Vector Field 1 exists, creating no list!',Level=10)
9763
RETURN
9764
END IF
9765
END IF
9766
9767
Nscalar = 0
9768
Nvector = 0
9769
9770
9771
ThisOnly = .NOT. ListGetLogical( Params,'Interpolate Fields',GotIt)
9772
dim = Model % Mesh % MeshDim
9773
9774
EnforceVectors = ListGetLogical( Params,'Enforce Vectors',GotIt)
9775
IF(.NOT. GotIt ) EnforceVectors = .TRUE.
9776
9777
9778
! For historical reasons treat "displacement" in a special way
9779
! but only if it exists as vector. Otherwise it will be treated by its components.
9780
! This fixes output for the elasticity solver in case of mixed solution.
9781
Var => Variables
9782
DisplacementV = .FALSE.
9783
DO WHILE( ASSOCIATED( Var ) )
9784
IF( Var % Name == 'displacement' ) DisplacementV = .TRUE.
9785
Var => Var % Next
9786
END DO
9787
9788
9789
Var => Variables
9790
9791
DO WHILE( ASSOCIATED( Var ) )
9792
9793
! Skip if variable is not active for saving
9794
IF ( .NOT. Var % Output ) THEN
9795
Var => Var % Next
9796
CYCLE
9797
END IF
9798
9799
! Skip if variable is global one
9800
IF ( SIZE( Var % Values ) == Var % DOFs ) THEN
9801
Var => Var % Next
9802
CYCLE
9803
END IF
9804
9805
IF( Var % TYPE == Variable_global ) THEN
9806
Var => Var % Next
9807
CYCLE
9808
ELSE IF( Var % TYPE == Variable_on_gauss_points ) THEN
9809
CONTINUE
9810
9811
ELSE IF( Var % TYPE == Variable_on_elements ) THEN
9812
CONTINUE
9813
9814
END IF
9815
9816
! Skip if variable is otherwise strange in size
9817
IF(.NOT. ASSOCIATED( Var % Perm ) ) THEN
9818
IF( Var % TYPE == Variable_on_nodes ) THEN
9819
IF( SIZE( Var % Values ) /= Var % Dofs * Model % Mesh % NumberOfNodes ) THEN
9820
Var => Var % Next
9821
CYCLE
9822
END IF
9823
ELSE IF( Var % TYPE == Variable_on_nodes_on_elements ) THEN
9824
IF( SIZE( Var % Values ) /= Var % Dofs * Model % Mesh % NumberOfBulkElements ) THEN
9825
Var => Var % Next
9826
CYCLE
9827
END IF
9828
END IF
9829
END IF
9830
9831
VarDim = Var % Dofs
9832
IsVector = (VarDim > 1)
9833
Set = .FALSE.
9834
9835
WRITE(VarName,'(A)') TRIM(Var % Name)
9836
9837
SELECT CASE(Var % Name)
9838
9839
CASE( 'coordinate 1','coordinate 2','coordinate 3' )
9840
! These are treated separatetely as coordinates are not typically saved
9841
9842
9843
CASE( 'mesh update' )
9844
! Mesh update is treated separately because its special connection to displacement
9845
Set = .TRUE.
9846
IF(.NOT. UseGeneric ) THEN
9847
Var1 => Variables
9848
DO WHILE( ASSOCIATED( Var1 ) )
9849
IF ( TRIM(Var1 % Name) == 'displacement' ) EXIT
9850
Var1 => Var1 % Next
9851
END DO
9852
IF ( ASSOCIATED( Var1 ) ) Set = .FALSE.
9853
END IF
9854
9855
CASE('mesh update 1','mesh update 2', 'mesh update 3' )
9856
9857
CASE( 'displacement' )
9858
Set = .TRUE.
9859
! mesh update is by default the complement to displacement
9860
! However, for generic variablelist the complement is not active
9861
IF(.NOT. UseGeneric ) THEN
9862
Var1 => Variables
9863
DO WHILE( ASSOCIATED( Var1 ) )
9864
IF ( TRIM(Var1 % Name) == 'mesh update' ) EXIT
9865
Var1 => Var1 % Next
9866
END DO
9867
IF ( ASSOCIATED( Var1 ) ) THEN
9868
WRITE(VarStr,'(A,I0,A)') 'Vector Field ',Nvector+1,' Complement'
9869
CALL ListAddString( List ,TRIM(VarStr),'mesh update')
9870
END IF
9871
END IF
9872
9873
!CASE( 'displacement 1','displacement 2','displacement 3')
9874
9875
9876
CASE DEFAULT
9877
! All vector variables are assumed to be saved using its components
9878
! rather than vector itself.
9879
IF ( VarDim == 1 ) THEN
9880
Set = .TRUE.
9881
9882
str = ' '
9883
j = LEN_TRIM(Var % Name)
9884
DO i=1,j
9885
str(i:i) = Var % Name(i:i)
9886
END DO
9887
9888
IsIndex = .FALSE.
9889
Comp = 0
9890
k = INDEX( str(:j),' ',BACK=.TRUE.)
9891
9892
IF( k > 0 ) THEN
9893
IsIndex = ( VERIFY( str(k:j),' 0123456789') == 0 )
9894
IF( IsIndex ) READ( str(k:j), * ) Comp
9895
END IF
9896
9897
! This is the easy way of checking that the component belongs to a vector
9898
! The size of the vector can be either dim or 3.
9899
GotIt = .FALSE.
9900
IF( IsIndex ) THEN
9901
Var1 => VariableGet(Variables,TRIM(str(1:k)),ThisOnly)
9902
IF( ASSOCIATED( Var1 ) ) THEN
9903
GotIt = .TRUE.
9904
IsVector = ( Var1 % Dofs == Dim .OR. Var1 % Dofs == 3 )
9905
Set = ( Comp == 1 .OR. .NOT. IsVector )
9906
END IF
9907
END IF
9908
9909
! This is a hard way of ensuring that the component belongs to a vector
9910
! Check that there are exactly dim number of components
9911
! If so save the quantity as a vector, otherwise componentwise
9912
IF( EnforceVectors .AND. .NOT. GotIt ) THEN
9913
IF( Comp == 1 ) THEN
9914
! If we have the 1st component we need at least dim (2 or 3) components
9915
! to have a vector.
9916
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(dim),ThisOnly)
9917
9918
! However, if the 4th component also exists then this cannot be a vector
9919
IF( ASSOCIATED(Var1)) THEN
9920
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(4),ThisOnly)
9921
IsVector = .NOT. ASSOCIATED(Var1)
9922
END IF
9923
9924
ELSE IF( Comp == 2 .OR. Comp == 3 ) THEN
9925
! Associated to the previous case, cycle the other components of the vector
9926
! and cycle them if they are part of the vector that will be detected above.
9927
9928
! 2D: 2 or 3 components
9929
! 3D: 3 components
9930
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' 1',ThisOnly)
9931
IF( ASSOCIATED( Var1 ) ) THEN
9932
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(4),ThisOnly)
9933
Set = ASSOCIATED( Var1 )
9934
IF( .NOT. Set ) THEN
9935
IF( Comp == 2 .AND. dim == 3 ) THEN
9936
Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(dim),ThisOnly)
9937
Set = .NOT. ASSOCIATED( Var1 )
9938
END IF
9939
END IF
9940
END IF
9941
END IF
9942
END IF
9943
9944
! Remove the trailing numbers as they are not needed in this case.
9945
IF( Set ) THEN
9946
IF(IsVector) WRITE(VarName,'(A)') TRIM(str(1:j-2))
9947
9948
! This is a special case as historically this is saved as vector
9949
IF(VarName == 'displacement' .AND. DisplacementV ) Set = .FALSE.
9950
END IF
9951
END IF
9952
END SELECT
9953
9954
9955
9956
!---------------------------------------------------------------------------
9957
! Set the default variable names that have not been set
9958
!------------------------------------------------------------------------
9959
IF( Set ) THEN
9960
IF( UseGeneric ) THEN
9961
Nscalar = Nscalar + 1
9962
WRITE(VarStr,'(A,I0)') 'Variable ',Nscalar
9963
ELSE IF( IsVector ) THEN
9964
Nvector = Nvector + 1
9965
WRITE(VarStr,'(A,I0)') 'Vector Field ',Nvector
9966
ELSE
9967
Nscalar = Nscalar + 1
9968
WRITE(VarStr,'(A,I0)') 'Scalar Field ',Nscalar
9969
END IF
9970
CALL ListAddString( List,TRIM(VarStr),TRIM(VarName) )
9971
END IF
9972
9973
Var => Var % Next
9974
END DO
9975
9976
9977
IF( ShowVariables ) THEN
9978
CALL Info('CreateListForSaving','Field Variables for Saving')
9979
IF( UseGeneric ) THEN
9980
DO i=1,Nscalar
9981
WRITE(VarStr,'(A,I0)') 'Variable ',i
9982
VarName = ListGetString( List, VarStr,GotIt )
9983
IF( GotIt ) THEN
9984
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
9985
CALL Info('CreateListForSaving',Message,Level=6)
9986
END IF
9987
END DO
9988
ELSE
9989
DO i=1,Nscalar
9990
WRITE(VarStr,'(A,I0)') 'Scalar Field ',i
9991
VarName = ListGetString( List, VarStr,GotIt )
9992
IF( GotIt ) THEN
9993
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
9994
CALL Info('CreateListForSaving',Message,Level=6)
9995
END IF
9996
END DO
9997
9998
DO i=1,Nvector
9999
WRITE(VarStr,'(A,I0)') 'Vector Field ',i
10000
VarName = ListGetString( List, VarStr,GotIt )
10001
IF( GotIt ) THEN
10002
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
10003
CALL Info('CreateListForSaving',Message,Level=6)
10004
END IF
10005
END DO
10006
10007
DO i=1,Nvector
10008
WRITE(VarStr,'(A,I0,A)') 'Vector Field ',i,' Complement'
10009
VarName = ListGetString( List, VarStr, GotIt )
10010
IF( GotIt ) THEN
10011
WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName)
10012
CALL Info('CreateListForSaving',Message,Level=6)
10013
END IF
10014
END DO
10015
END IF
10016
END IF
10017
10018
END SUBROUTINE CreateListForSaving
10019
10020
10021
10022
!------------------------------------------------------------------------------
10023
!> A timer that uses a list structure to store the times making in
10024
!> generally applicable without any upper limit on the number of timers.
10025
!> This resets the timer.
10026
!-----------------------------------------------------------------------------
10027
10028
SUBROUTINE ResetTimer(TimerName)
10029
CHARACTER(*) :: TimerName
10030
REAL(KIND=dp) :: ct, rt
10031
LOGICAL :: Found,FirstTime=.TRUE.
10032
10033
IF( FirstTime ) THEN
10034
FirstTime=.FALSE.
10035
TimerPassive = ListGetLogical( CurrentModel % Simulation,'Timer Passive',Found)
10036
TimerCumulative = ListGetLogical( CurrentModel % Simulation,'Timer Cumulative',Found)
10037
TimerRealTime = ListGetLogical( CurrentModel % Simulation,'Timer Real Time',Found)
10038
TimerCPUTime = ListGetLogical( CurrentModel % Simulation,'Timer CPU Time',Found)
10039
IF( .NOT. (TimerRealTime .OR. TimerCPUTime ) ) TimerRealTime = .TRUE.
10040
TimerPrefix = ListGetString( CurrentModel % Simulation,'Timer Prefix',Found )
10041
IF( .NOT. Found ) THEN
10042
IF( ListGetLogical( CurrentModel % Simulation,'Timer Results',Found ) ) THEN
10043
TimerPrefix = 'res:'
10044
ELSE
10045
TimerPrefix = 'timer:'
10046
END IF
10047
END IF
10048
END IF
10049
10050
10051
IF( TimerPassive ) RETURN
10052
10053
IF( TimerCPUTime ) THEN
10054
ct = CPUTime()
10055
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' cpu time',ct )
10056
END IF
10057
10058
IF( TimerRealTime ) THEN
10059
rt = RealTime()
10060
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' real time',rt )
10061
END IF
10062
10063
IF( TimerCumulative ) THEN
10064
IF( TimerCPUTime ) THEN
10065
IF( .NOT. ListCheckPresent( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time') ) THEN
10066
CALL ListAddConstReal( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',0.0_dp )
10067
END IF
10068
END IF
10069
IF( TimerRealTime ) THEN
10070
IF( .NOT. ListCheckPresent( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time') ) THEN
10071
CALL ListAddConstReal( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',0.0_dp )
10072
END IF
10073
END IF
10074
END IF
10075
10076
END SUBROUTINE ResetTimer
10077
10078
10079
!-----------------------------------------------------------------------------
10080
!> Delete an existing timer.
10081
!----------------------------------------------------------------------------
10082
SUBROUTINE DeleteTimer(TimerName)
10083
CHARACTER(*) :: TimerName
10084
10085
IF( TimerPassive ) RETURN
10086
10087
IF( TimerCPUTime ) THEN
10088
CALL ListRemove( TimerList, TRIM(TimerName)//' cpu time' )
10089
END IF
10090
10091
IF( TimerRealTime ) THEN
10092
CALL ListRemove( TimerList, TRIM(TimerName)//' real time' )
10093
END IF
10094
10095
END SUBROUTINE DeleteTimer
10096
10097
!-----------------------------------------------------------------------------
10098
!> Check current time of the timer.
10099
!----------------------------------------------------------------------------
10100
SUBROUTINE CheckTimer(TimerName, Level, Delete, Reset)
10101
CHARACTER(*) :: TimerName
10102
INTEGER, OPTIONAL :: Level
10103
LOGICAL, OPTIONAL :: Reset, Delete
10104
10105
REAL(KIND=dp) :: ct0,rt0,ct, rt, cumct, cumrt
10106
LOGICAL :: Found
10107
10108
IF( TimerPassive ) RETURN
10109
10110
IF( TimerCPUTime ) THEN
10111
ct0 = ListGetConstReal( TimerList,TRIM(TimerName)//' cpu time',Found)
10112
IF( Found ) THEN
10113
ct = CPUTime() - ct0
10114
WRITE(Message,'(a,f10.4,a)') 'Elapsed CPU time: ',ct,' (s)'
10115
CALL Info(TRIM(TimerName),Message,Level=Level)
10116
END IF
10117
END IF
10118
10119
IF( TimerRealTime ) THEN
10120
rt0 = ListGetConstReal( TimerList,TRIM(TimerName)//' real time',Found)
10121
IF( Found ) THEN
10122
rt = RealTime() - rt0
10123
WRITE(Message,'(a,f10.4,a)') 'Elapsed REAL time: ',rt,' (s)'
10124
CALL Info(TRIM(TimerName),Message,Level=Level)
10125
END IF
10126
END IF
10127
10128
10129
IF( TimerCPUTime ) THEN
10130
IF( TimerCumulative ) THEN
10131
cumct = ListGetConstReal(CurrentModel % Simulation,&
10132
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',Found)
10133
IF( Found ) THEN
10134
ct = ct + cumct
10135
WRITE(Message,'(a,f10.4,a)') 'Elapsed CPU time cumulative: ',ct,' (s)'
10136
CALL Info(TRIM(TimerName),Message,Level=Level)
10137
ELSE
10138
CALL Warn('CheckTimer',&
10139
'Requesting previous CPU time from non-existing timer: '//TRIM(TimerName) )
10140
END IF
10141
END IF
10142
CALL ListAddConstReal(CurrentModel % Simulation,&
10143
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',ct)
10144
10145
END IF
10146
IF( TimerRealTime ) THEN
10147
IF( TimerCumulative ) THEN
10148
cumrt = ListGetConstReal(CurrentModel % Simulation,&
10149
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',Found)
10150
IF( Found ) THEN
10151
rt = rt + cumrt
10152
WRITE(Message,'(a,f10.4,a)') 'Elapsed real time cumulative: ',rt,' (s)'
10153
CALL Info(TRIM(TimerName),Message,Level=Level)
10154
ELSE
10155
CALL Warn('CheckTimer',&
10156
'Requesting previous real time from non-existing timer: '//TRIM(TimerName) )
10157
END IF
10158
END IF
10159
CALL ListAddConstReal(CurrentModel % Simulation,&
10160
TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',rt)
10161
END IF
10162
10163
10164
IF( PRESENT( Reset ) ) THEN
10165
IF( Reset ) THEN
10166
IF( TimerCPUTime ) THEN
10167
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' cpu time',ct )
10168
END IF
10169
IF( TimerRealTime ) THEN
10170
CALL ListAddConstReal( TimerList,TRIM(TimerName)//' real time',rt )
10171
END IF
10172
END IF
10173
END IF
10174
10175
IF( PRESENT( Delete ) ) THEN
10176
IF( Delete ) CALL DeleteTimer( TimerName )
10177
END IF
10178
10179
END SUBROUTINE CheckTimer
10180
10181
10182
!> Returns the angular frequency
10183
FUNCTION ListGetAngularFrequency(ValueList,Found,UElement) RESULT(w)
10184
REAL(KIND=dp) :: w
10185
TYPE(ValueList_t), OPTIONAL, POINTER :: ValueList
10186
LOGICAL, OPTIONAL :: Found
10187
LOGICAL :: GotIt
10188
TYPE(Element_t), TARGET :: UElement
10189
TYPE(Element_t), POINTER :: Element
10190
OPTIONAL :: UElement
10191
INTEGER :: elem_id,eq_id,mat_id
10192
10193
! This is rather complicated since it should replace all the various strategies
10194
! that have been used in different solvers.
10195
!------------------------------------------------------------------------------
10196
10197
! The only way frequency may depend on element is that it sits in equation block
10198
!--------------------------------------------------------------------------------
10199
IF( PRESENT( ValueList ) ) THEN
10200
w = 2 * PI * ListGetCReal( ValueList,'Frequency',GotIt)
10201
IF(.NOT. GotIt) w = ListGetCReal( ValueList,'Angular Frequency',GotIt)
10202
ELSE
10203
GotIt = .FALSE.
10204
END IF
10205
10206
! It seems that the equation section is used to allow compliance with ElmerGUI
10207
!------------------------------------------------------------------------------
10208
IF( .NOT. GotIt ) THEN
10209
IF(PRESENT(UElement)) THEN
10210
Element => UElement
10211
eq_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Equation')
10212
w = 2 * PI * ListGetCReal( &
10213
CurrentModel % Equations(eq_id) % Values,'Frequency',GotIt)
10214
IF(.NOT. GotIt) w = ListGetCReal( &
10215
CurrentModel % Equations(eq_id) % Values,'Angular Frequency',GotIt)
10216
END IF
10217
END IF
10218
10219
! Check also the material section of the given element...
10220
!------------------------------------------------------------------------------
10221
IF( .NOT. GotIt ) THEN
10222
IF(PRESENT(UElement)) THEN
10223
Element => UElement
10224
mat_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Material',GotIt)
10225
IF( GotIt ) THEN
10226
w = 2 * PI * ListGetCReal( &
10227
CurrentModel % Materials(mat_id) % Values,'Frequency',GotIt)
10228
IF(.NOT. GotIt) w = ListGetCReal( &
10229
CurrentModel % Materials(mat_id) % Values,'Angular Frequency',GotIt)
10230
END IF
10231
END IF
10232
END IF
10233
10234
! Normally the constant frequency is given in Simulation (or solver) block
10235
!-------------------------------------------------------------------------
10236
IF(.NOT. GotIt) w = 2 * PI * ListGetCReal( &
10237
CurrentModel % Simulation,'Frequency',GotIt)
10238
IF(.NOT. GotIt ) w = ListGetCReal( &
10239
CurrentModel % Simulation,'Angular Frequency',GotIt)
10240
10241
IF(.NOT. GotIt ) w = 2 * PI * ListGetCReal( &
10242
CurrentModel % Solver % Values,'Frequency',GotIt)
10243
IF(.NOT. GotIt ) w = ListGetCReal( &
10244
CurrentModel % Solver % Values,'Angular Frequency',GotIt)
10245
10246
! It seems that the equation section is used to allow compliance with ElmerGUI
10247
! If element given, don't do this as it has been done before already.
10248
!------------------------------------------------------------------------------
10249
IF( .NOT. GotIt ) THEN
10250
IF(.NOT. PRESENT(UElement)) THEN
10251
elem_id = CurrentModel % Solver % ActiveElements(1)
10252
Element => CurrentModel % Elements(elem_id)
10253
eq_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Equation')
10254
w = 2 * PI * ListGetCReal( &
10255
CurrentModel % Equations(eq_id) % Values,'Frequency',GotIt)
10256
IF(.NOT. GotIt) w = ListGetCReal( &
10257
CurrentModel % Equations(eq_id) % Values,'Angular Frequency',GotIt)
10258
END IF
10259
END IF
10260
10261
! Check also the material section of the 1st element, if not element given.
10262
!------------------------------------------------------------------------------
10263
IF( .NOT. GotIt ) THEN
10264
IF(.NOT. PRESENT(UElement)) THEN
10265
elem_id = CurrentModel % Solver % ActiveElements(1)
10266
Element => CurrentModel % Elements(elem_id)
10267
mat_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Material',GotIt)
10268
IF(GotIt) THEN
10269
w = 2 * PI * ListGetCReal( &
10270
CurrentModel % Materials(mat_id) % Values,'Frequency',GotIt)
10271
IF(.NOT. GotIt) w = ListGetCReal( &
10272
CurrentModel % Materials(mat_id) % Values,'Angular Frequency',GotIt)
10273
END IF
10274
END IF
10275
END IF
10276
10277
IF( PRESENT( Found ) ) THEN
10278
Found = GotIt
10279
ELSE IF(.NOT. GotIt ) THEN
10280
CALL Warn('ListGetAngularFrequency','Angular frequency could not be determined!')
10281
END IF
10282
END FUNCTION ListGetAngularFrequency
10283
10284
10285
!------------------------------------------------------------------------------
10286
!> Returns handle to the Solver value list of the active solver
10287
FUNCTION ListGetSolverParams(Solver) RESULT(SolverParam)
10288
!------------------------------------------------------------------------------
10289
TYPE(ValueList_t), POINTER :: SolverParam
10290
TYPE(Solver_t), OPTIONAL :: Solver
10291
10292
IF ( PRESENT(Solver) ) THEN
10293
SolverParam => Solver % Values
10294
ELSE
10295
SolverParam => CurrentModel % Solver % Values
10296
END IF
10297
!------------------------------------------------------------------------------
10298
END FUNCTION ListGetSolverParams
10299
!------------------------------------------------------------------------------
10300
10301
!-------------------------------------------------------------------------------
10302
!> evaluates lua string to real array
10303
!-------------------------------------------------------------------------------
10304
SUBROUTINE ElmerEvalLuaT(L, ptr, T, F, varcount)
10305
!-------------------------------------------------------------------------------
10306
TYPE(LuaState_t) :: L
10307
TYPE(ValueListEntry_t), POINTER :: ptr
10308
REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:)
10309
REAL(KIND=C_DOUBLE), INTENT(OUT) :: F(:,:)
10310
INTEGER :: VARCOUNT
10311
!-------------------------------------------------------------------------------
10312
integer :: lstat
10313
10314
#ifdef HAVE_LUA
10315
L % tx(1:varcount) = T(1:varcount) ! this should be superfluous
10316
call lua_exec_fun(L, ptr % cvalue, 0, size(F,1)*size(F,2))
10317
CALL lua_poptensor(L, F)
10318
#else
10319
CALL Fatal('ElmerEvalLuaT', 'Lua not compiled in.')
10320
#endif
10321
10322
!-------------------------------------------------------------------------------
10323
END SUBROUTINE ElmerEvalLuaT
10324
!-------------------------------------------------------------------------------
10325
10326
!-------------------------------------------------------------------------------
10327
!> evaluates lua string to real vector
10328
!-------------------------------------------------------------------------------
10329
SUBROUTINE ElmerEvalLuaV(L, ptr, T, F, varcount)
10330
!-------------------------------------------------------------------------------
10331
TYPE(LuaState_t) :: L
10332
TYPE(ValueListEntry_t), POINTER :: ptr
10333
REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:)
10334
REAL(KIND=C_DOUBLE), INTENT(INOUT) :: F(:)
10335
INTEGER :: VARCOUNT
10336
!-------------------------------------------------------------------------------
10337
integer :: lstat
10338
10339
#ifdef HAVE_LUA
10340
L % tx(1:varcount) = T(1:varcount) ! this should be superfluous
10341
call lua_exec_fun(L, ptr % cvalue, 0, size(F,1))
10342
CALL lua_popvector(L, F)
10343
#else
10344
CALL Fatal('ElmerEvalLuaV', 'Lua not compiled in.')
10345
#endif
10346
10347
!-------------------------------------------------------------------------------
10348
END SUBROUTINE ElmerEvalLuaV
10349
!-------------------------------------------------------------------------------
10350
10351
!-------------------------------------------------------------------------------
10352
!> evaluates lua string to real scalar
10353
!-------------------------------------------------------------------------------
10354
SUBROUTINE ElmerEvalLuaS(L, ptr, T, F, varcount)
10355
!-------------------------------------------------------------------------------
10356
TYPE(LuaState_t) :: L
10357
TYPE(ValueListEntry_t), POINTER :: ptr
10358
REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:)
10359
REAL(KIND=C_DOUBLE), INTENT(OUT) :: F
10360
INTEGER :: VARCOUNT
10361
!-------------------------------------------------------------------------------
10362
integer :: lstat
10363
10364
#ifdef HAVE_LUA
10365
L % tx(1:varcount) = T(1:varcount) ! this should be superfluous
10366
call lua_exec_fun(L, ptr % cvalue, 0, 1)
10367
F = lua_popnumber(LuaState)
10368
#else
10369
CALL Fatal('ElmerEvalLuaV', 'Lua not compiled in.')
10370
#endif
10371
!-------------------------------------------------------------------------------
10372
END SUBROUTINE ElmerEvalLuaS
10373
!-------------------------------------------------------------------------------
10374
10375
10376
#if defined DEVEL_LISTCOUNTER || defined DEVEL_LISTUSAGE
10377
10378
!------------------------------------------------------------------------------
10379
!> Go through the lists and for each lists show call counts.
10380
!------------------------------------------------------------------------------
10381
SUBROUTINE ReportListCounters( Model, ReportMode )
10382
TYPE(Model_t) :: Model
10383
INTEGER :: ReportMode
10384
10385
CHARACTER(LEN=MAX_NAME_LEN) :: dirname,filename
10386
INTEGER :: i, totcount, nelem, ReportUnit
10387
LOGICAL :: Unused, GotFile
10388
10389
IF(ReportMode == 1 ) THEN
10390
! Just initialize the lists from -1 to 0 such that only orginal keywords will be
10391
! reported in mode 2.
10392
GOTO 100
10393
END IF
10394
10395
filename = ListGetString( Model % Simulation,'List Counter File',GotFile )
10396
IF(.NOT. GotFile ) filename = '../listcounter.dat'
10397
10398
! We may toggle this to enable is disable automatic writing to file
10399
! For example, when we want to collect data automatically from tests.
10400
!GotFile = .TRUE.
10401
10402
IF( GotFile ) THEN
10403
CALL Info('ReportListCounters','Saving ListGet operations counts')
10404
ReportUnit = 10
10405
!IF( ParEnv % PEs > 1 ) THEN
10406
! filename = TRIM(filename)//'.'//I2S(ParEnv % MyPe)
10407
!END IF
10408
OPEN( 10,File=filename,STATUS='UNKNOWN',POSITION='APPEND' )
10409
CALL GETCWD(dirname)
10410
10411
! These are only for reference if writing lot of data to same file
10412
WRITE( ReportUnit,'(A)') 'Working directory: '//TRIM(dirname)
10413
nelem = Model % Mesh % NumberOfBulkElements
10414
WRITE( ReportUnit,'(T4,A)') 'Number of elements: '//I2S(nelem)
10415
WRITE( ReportUnit,'(T4,A)') 'Number of nodes: '//I2S(Model % Mesh % NumberOfNodes)
10416
ELSE
10417
! IF( ParEnv % MyPe /= 0) RETURN
10418
ReportUnit = 6
10419
END IF
10420
10421
! In the first round write the unused keywords
10422
! On the 2nd round write the keywords that
10423
Unused = .TRUE.
10424
totcount = 0
10425
10426
100 IF( ReportMode == 1 ) THEN
10427
CONTINUE
10428
ELSE IF( Unused ) THEN
10429
WRITE( ReportUnit,'(T4,A)') 'Unused keywords:'
10430
ELSE
10431
WRITE( ReportUnit,'(T4,A)') 'Used keywords:'
10432
END IF
10433
10434
CALL ReportList('Simulation', Model % Simulation, Unused )
10435
CALL ReportList('Constants', Model % Constants, Unused )
10436
DO i=1,Model % NumberOfEquations
10437
CALL ReportList('Equation '//I2S(i), Model % Equations(i) % Values, Unused )
10438
END DO
10439
DO i=1,Model % NumberOfComponents
10440
CALL ReportList('Component '//I2S(i), Model % Components(i) % Values, Unused )
10441
END DO
10442
DO i=1,Model % NumberOfBodyForces
10443
CALL ReportList('Body Force '//I2S(i), Model % BodyForces(i) % Values, Unused )
10444
END DO
10445
DO i=1,Model % NumberOfICs
10446
CALL ReportList('Initial Condition '//I2S(i), Model % ICs(i) % Values, Unused )
10447
END DO
10448
DO i=1,Model % NumberOfBCs
10449
CALL ReportList('Boundary Condition '//I2S(i), Model % BCs(i) % Values, Unused )
10450
END DO
10451
DO i=1,Model % NumberOfMaterials
10452
CALL ReportList('Material '//I2S(i), Model % Materials(i) % Values, Unused )
10453
END DO
10454
DO i=1,Model % NumberOfBoundaries
10455
CALL ReportList('Boundary '//I2S(i), Model % Boundaries(i) % Values, Unused )
10456
END DO
10457
DO i=1,Model % NumberOfSolvers
10458
CALL ReportList('Solver '//I2S(i), Model % Solvers(i) % Values, Unused )
10459
END DO
10460
10461
IF( ReportMode == 3 ) THEN
10462
IF( Unused ) THEN
10463
Unused = .FALSE.
10464
GOTO 100
10465
END IF
10466
CALL Info('ReportListCounters','List operations total count:'//I2S(totcount))
10467
END IF
10468
10469
IF (ReportMode /= 1) THEN
10470
IF( GotFile ) CLOSE(ReportUnit)
10471
END IF
10472
CONTAINS
10473
10474
10475
!------------------------------------------------------------------------------
10476
! Plot the number of times that the list entries have been called.
10477
!------------------------------------------------------------------------------
10478
SUBROUTINE ReportList( SectionName, List, Unused )
10479
TYPE(ValueList_t), POINTER :: List
10480
CHARACTER(LEN=*) :: SectionName
10481
LOGICAL :: Unused
10482
!------------------------------------------------------------------------------
10483
TYPE(ValueListEntry_t), POINTER :: ptr
10484
INTEGER :: n, m
10485
10486
IF(.NOT.ASSOCIATED(List)) RETURN
10487
10488
Ptr => List % Head
10489
DO WHILE( ASSOCIATED(ptr) )
10490
n = ptr % NameLen
10491
m = ptr % Counter
10492
10493
IF(ReportMode == 1 ) THEN
10494
! Change existing keywords tag from 0 to -1
10495
ptr % Counter = -1
10496
ELSE IF(ReportMode == 2 .AND. m == -1 ) THEN
10497
! Do not report "name" as it makes sense to have one.
10498
IF( ptr % Name == 'name' ) THEN
10499
CONTINUE
10500
ELSE
10501
WRITE( ReportUnit,'(T8,A,T30,A)') TRIM(SectionName),ptr % Name(1:n)
10502
END IF
10503
ELSE IF( ReportMode == 3 ) THEN
10504
IF( Unused .AND. m == 0 ) THEN
10505
WRITE( ReportUnit,'(T8,A,T30,A)') TRIM(SectionName),ptr % Name(1:n)
10506
ELSE IF(.NOT. Unused .AND. m > 0 ) THEN
10507
WRITE( ReportUnit,'(T8,A,T30,I0,T40,A)') TRIM(SectionName),m,ptr % Name(1:n)
10508
totcount = totcount + m
10509
END IF
10510
END IF
10511
ptr => ptr % Next
10512
END DO
10513
10514
END SUBROUTINE ReportList
10515
!------------------------------------------------------------------------------
10516
10517
END SUBROUTINE ReportListCounters
10518
!------------------------------------------------------------------------------
10519
10520
#else
10521
10522
SUBROUTINE ReportListCounters( Model )
10523
TYPE(Model_t) :: Model
10524
10525
CALL Info('ReportListCounter','List counters are not activated!')
10526
END SUBROUTINE ReportListCounters
10527
10528
#endif
10529
10530
10531
10532
10533
END MODULE Lists
10534
10535
!> \} ElmerLib
10536
10537