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: Juha.Ruokolainen@csc.fi 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 47MODULE Lists 48 49 USE Messages 50 USE GeneralUtils 51 USE LoadMod 52 53 IMPLICIT NONE 54 55 INTEGER, PARAMETER :: LIST_TYPE_LOGICAL = 1 56 INTEGER, PARAMETER :: LIST_TYPE_STRING = 2 57 INTEGER, PARAMETER :: LIST_TYPE_INTEGER = 3 58 INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR = 4 59 INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_SCALAR = 5 60 INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR_STR = 6 61 INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_SCALAR_STR = 7 62 INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_SCALAR_PROC = 8 63 INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_TENSOR = 9 64 INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_TENSOR = 10 65 INTEGER, PARAMETER :: LIST_TYPE_CONSTANT_TENSOR_STR = 11 66 INTEGER, PARAMETER :: LIST_TYPE_VARIABLE_TENSOR_STR = 12 67 68 INTEGER, PARAMETER :: SECTION_TYPE_BODY = 1 69 INTEGER, PARAMETER :: SECTION_TYPE_MATERIAL = 2 70 INTEGER, PARAMETER :: SECTION_TYPE_BF = 3 71 INTEGER, PARAMETER :: SECTION_TYPE_IC = 4 72 INTEGER, PARAMETER :: SECTION_TYPE_BC = 5 73 INTEGER, PARAMETER :: SECTION_TYPE_COMPONENT = 6 74 INTEGER, PARAMETER :: SECTION_TYPE_SIMULATION = 7 75 INTEGER, PARAMETER :: SECTION_TYPE_CONSTANTS = 8 76 INTEGER, PARAMETER :: SECTION_TYPE_EQUATION = 9 77 78 79 INTEGER, PARAMETER :: MAX_FNC = 32 80 81#ifdef HAVE_LUA 82 interface ElmerEvalLua 83 module procedure ElmerEvalLuaS, ElmerEvalLuaT, ElmerEvalLuaV 84 end INTERFACE 85#endif 86 87 TYPE String_stack_t 88 TYPE(Varying_string) :: Name 89 TYPE(String_stack_t), POINTER :: Next => Null() 90 END TYPE String_stack_t 91 92 CHARACTER(:), ALLOCATABLE, SAVE, PRIVATE :: Namespace 93 !$OMP THREADPRIVATE(NameSpace) 94 95 TYPE(String_stack_t), SAVE, PRIVATE, POINTER :: Namespace_stack => Null() 96 !$OMP THREADPRIVATE(NameSpace_stack) 97 98 CHARACTER(:), ALLOCATABLE, SAVE, PRIVATE :: ActiveListName 99 !$OMP THREADPRIVATE(ActiveListName) 100 101 TYPE(String_stack_t), SAVE, PRIVATE, POINTER :: Activename_stack => Null() 102 !$OMP THREADPRIVATE(Activename_stack) 103 104 TYPE(ValueList_t), POINTER, SAVE, PRIVATE :: TimerList => NULL() 105 LOGICAL, SAVE, PRIVATE :: TimerPassive, TimerCumulative, TimerRealTime, TimerCPUTime 106 CHARACTER(LEN=MAX_NAME_LEN), SAVE, PRIVATE :: TimerPrefix 107 108 109 LOGICAL, PRIVATE :: DoNamespaceCheck = .FALSE. 110 111CONTAINS 112 113!> Tag the active degrees of freedom and number them in order of appearance. 114!------------------------------------------------------------------------------ 115 FUNCTION InitialPermutation( Perm,Model,Solver,Mesh, & 116 Equation,DGSolver,GlobalBubbles ) RESULT(k) 117!------------------------------------------------------------------------------ 118 USE PElementMaps 119 TYPE(Model_t) :: Model 120 TYPE(Mesh_t) :: Mesh 121 TYPE(Solver_t), TARGET :: Solver 122 INTEGER :: Perm(:) 123 CHARACTER(LEN=*) :: Equation 124 LOGICAL, OPTIONAL :: DGSolver, GlobalBubbles 125!------------------------------------------------------------------------------ 126 INTEGER i,j,l,t,n,e,k,k1,EDOFs, FDOFs, BDOFs, ndofs, el_id 127 INTEGER :: Indexes(128) 128 INTEGER, POINTER :: Def_Dofs(:) 129 INTEGER, ALLOCATABLE :: EdgeDOFs(:), FaceDOFs(:) 130 LOGICAL :: FoundDG, DG, DB, GB, Found, Radiation 131 TYPE(Element_t),POINTER :: Element, Edge, Face 132 CHARACTER(*), PARAMETER :: Caller = 'InitialPermutation' 133 !------------------------------------------------------------------------------ 134 Perm = 0 135 k = 0 136 EDOFs = Mesh % MaxEdgeDOFs 137 FDOFs = Mesh % MaxFaceDOFs 138 BDOFs = Mesh % MaxBDOFs 139 140 GB = .FALSE. 141 IF ( PRESENT(GlobalBubbles) ) GB=GlobalBubbles 142 143 DG = .FALSE. 144 IF ( PRESENT(DGSolver) ) DG=DGSolver 145 FoundDG = .FALSE. 146 147 IF( DG ) THEN 148 DB = ListGetLogical( Solver % Values,'DG Reduced Basis',Found ) 149 ELSE 150 DB = .FALSE. 151 END IF 152 153 ! Discontinuous bodies need special body-wise numbering 154 IF ( DB ) THEN 155 BLOCK 156 INTEGER, ALLOCATABLE :: NodeIndex(:) 157 INTEGER :: body_id, MaxGroup, group0, group 158 INTEGER, POINTER :: DgMap(:), DgMaster(:), DgSlave(:) 159 LOGICAL :: GotDgMap, GotMaster, GotSlave 160 161 DgMap => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Mapping',GotDgMap ) 162 DgMaster => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Master Bodies',GotMaster ) 163 DgSlave => ListGetIntegerArray( Solver % Values,'DG Reduced Basis Slave Bodies',GotSlave ) 164 165 IF( GotDgMap ) THEN 166 IF( SIZE( DgMap ) /= Model % NumberOfBodies ) THEN 167 CALL Fatal('InitialPermutation','Invalid size of > Dg Reduced Basis Mapping <') 168 END IF 169 MaxGroup = MAXVAL( DgMap ) 170 ELSE IF( GotMaster ) THEN 171 MaxGroup = 2 172 ELSE 173 MaxGroup = Model % NumberOfBodies 174 END IF 175 176 ALLOCATE( NodeIndex( Mesh % NumberOfNodes ) ) 177 178 DO group0 = 1, MaxGroup 179 180 ! If we have master-slave lists then nullify the slave nodes at the master 181 ! interface since we want new indexes here. 182 IF( GotSlave .AND. group0 == 2 ) THEN 183 DO t=1,Mesh % NumberOfBulkElements 184 Element => Mesh % Elements(t) 185 group = Element % BodyId 186 IF( ANY( DgSlave == group ) ) THEN 187 NodeIndex( Element % NodeIndexes ) = 0 188 END IF 189 END DO 190 ELSE 191 ! In generic case nullify all indexes already set 192 NodeIndex = 0 193 END IF 194 195 k1 = k 196 197 CALL Info('InitialPermutation',& 198 'Group '//TRIM(I2S(group0))//' starts from index '//TRIM(I2S(k1)),Level=10) 199 200 DO t=1,Mesh % NumberOfBulkElements 201 Element => Mesh % Elements(t) 202 203 group = Element % BodyId 204 205 IF( GotMaster ) THEN 206 IF( group0 == 1 ) THEN 207 ! First loop number dofs in "master bodies" only 208 IF( .NOT. ANY( DgMaster == group ) ) CYCLE 209 ELSE 210 ! Second loop number dofs in all bodies except "master bodies" 211 IF( ANY( DgMaster == group ) ) CYCLE 212 END IF 213 ELSE IF( GotDgMap ) THEN 214 group = DgMap( group ) 215 IF( group0 /= group ) CYCLE 216 ELSE 217 IF( group0 /= group ) CYCLE 218 END IF 219 220 IF ( CheckElementEquation(Model,Element,Equation) ) THEN 221 FoundDG = FoundDG .OR. Element % DGDOFs > 0 222 DO i=1,Element % DGDOFs 223 j = Element % NodeIndexes(i) 224 IF( NodeIndex(j) == 0 ) THEN 225 k = k + 1 226 NodeIndex(j) = k 227 END IF 228 Perm( Element % DGIndexes(i) ) = NodeIndex(j) 229 END DO 230 END IF 231 END DO 232 233 IF( k > k1 ) THEN 234 CALL Info( Caller,'Group '//TRIM(I2S(group0))//& 235 ' has '//TRIM(I2S(k-k1))//' db dofs',Level=15) 236 END IF 237 END DO 238 239 CALL Info(Caller,'Numbered '//TRIM(I2S(k))//& 240 ' db nodes from bulk hits',Level=15) 241 242 IF ( FoundDG ) THEN 243 RETURN ! Discontinuous bodies !!! 244 END IF 245 END BLOCK 246 END IF 247 248 249 IF ( DG ) THEN 250 DO t=1,Mesh % NumberOfEdges 251 n = 0 252 Element => Mesh % Edges(t) % BoundaryInfo % Left 253 IF ( ASSOCIATED( Element ) ) THEN 254 IF ( CheckElementEquation(Model,Element,Equation) ) THEN 255 FoundDG = FoundDG .OR. Element % DGDOFs > 0 256 DO j=1,Element % DGDOFs 257 n = n + 1 258 Indexes(n) = Element % DGIndexes(j) 259 END DO 260 END IF 261 END IF 262 263 Element => Mesh % Edges(t) % BoundaryInfo % Right 264 IF ( ASSOCIATED( Element ) ) THEN 265 IF ( CheckElementEquation(Model,Element,Equation) ) THEN 266 FoundDG = FoundDG .OR. Element % DGDOFs > 0 267 DO j=1,Element % DGDOFs 268 n = n + 1 269 Indexes(n) = Element % DGIndexes(j) 270 END DO 271 END IF 272 END IF 273 274 DO i=1,n 275 j = Indexes(i) 276 IF ( Perm(j) == 0 ) THEN 277 k = k + 1 278 Perm(j) = k 279 END IF 280 END DO 281 END DO 282 283 CALL Info(Caller,'Numbered '//TRIM(I2S(k))//& 284 ' nodes from face hits',Level=15) 285 k1 = k 286 287 288 DO t=1,Mesh % NumberOfFaces 289 n = 0 290 Element => Mesh % Faces(t) % BoundaryInfo % Left 291 IF ( ASSOCIATED( Element ) ) THEN 292 IF ( CheckElementEquation(Model,Element,Equation) ) THEN 293 FoundDG = FoundDG .OR. Element % DGDOFs > 0 294 DO j=1,Element % DGDOFs 295 n = n + 1 296 Indexes(n) = Element % DGIndexes(j) 297 END DO 298 END IF 299 END IF 300 301 Element => Mesh % Faces(t) % BoundaryInfo % Right 302 IF ( ASSOCIATED( Element ) ) THEN 303 IF ( CheckElementEquation(Model,Element,Equation) ) THEN 304 FoundDG = FoundDG .OR. Element % DGDOFs > 0 305 DO j=1,Element % DGDOFs 306 n = n + 1 307 Indexes(n) = Element % DGIndexes(j) 308 END DO 309 END IF 310 END IF 311 312 DO i=1,n 313 j = Indexes(i) 314 IF ( Perm(j) == 0 ) THEN 315 k = k + 1 316 Perm(j) = k 317 END IF 318 END DO 319 END DO 320 321 CALL Info(Caller,'Numbered '//TRIM(I2S(k-k1))//& 322 ' nodes from bulk hits',Level=15) 323 324 IF ( FoundDG ) THEN 325 RETURN ! Discontinuous galerkin !!! 326 END IF 327 END IF 328 329 330 IF ( ANY(Solver % Def_Dofs(:,:,6)>=0) ) THEN 331 IF ( Mesh % NumberOFEdges>0 ) THEN 332 ALLOCATE(EdgeDOFs(Mesh % NumberOfEdges)) 333 EdgeDOFs=0; 334 END IF 335 336 IF ( Mesh % NumberOFFaces>0 ) THEN 337 ALLOCATE(FaceDOFs(Mesh % NumberOfFaces)) 338 FaceDOFs=0; 339 END IF 340 341 n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements 342 t = 1 343 DO WHILE( t <= n ) 344 DO WHILE( t<=n ) 345 Element => Mesh % Elements(t) 346 IF ( CheckElementEquation( Model, Element, Equation ) ) EXIT 347 t = t + 1 348 END DO 349 IF ( t>n ) EXIT 350 351 el_id = Element % TYPE % ElementCode / 100 352 353 Def_Dofs => Solver % Def_Dofs(el_id,Element % BodyId,:) 354 IF ( ASSOCIATED(Element % EdgeIndexes) ) THEN 355 DO i=1,Element % TYPE % NumberOfEdges 356 j = Element % EdgeIndexes(i) 357 EdgeDOFs(j)=MAX(EdgeDOFs(j),getEdgeDOFs(Element,Def_Dofs(6))) 358 END DO 359 END IF 360 361 IF ( ASSOCIATED(Element % FaceIndexes) ) THEN 362 DO i=1,Element % TYPE % NumberOfFaces 363 j = Element % FaceIndexes(i) 364 FaceDOFs(j)=MAX(FaceDOFs(j),getFaceDOFs(Element,Def_Dofs(6),i)) 365 END DO 366 END IF 367 t=t+1 368 END DO 369 END IF 370 371 372 n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements 373 t = 1 374 DO WHILE( t <= n ) 375 376 DO WHILE( t<=n ) 377 Element => Mesh % Elements(t) 378 IF ( CheckElementEquation( Model, Element, Equation ) ) EXIT 379 t = t + 1 380 END DO 381 382 IF ( t > n ) EXIT 383 384 el_id = Element % TYPE % ElementCode / 100 385 Def_Dofs => Solver % Def_Dofs(el_id,Element % BodyId,:) 386 ndofs = Element % NDOFs 387 IF ( Def_Dofs(1) >= 0 ) ndofs=Def_Dofs(1)*Element % TYPE % NumberOfNodes 388 DO i=1,ndofs 389 j = Element % NodeIndexes(i) 390 IF ( Perm(j) == 0 ) THEN 391 k = k + 1 392 Perm(j) = k 393 END IF 394 END DO 395 396 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 397 DO i=1,Element % TYPE % NumberOfEdges 398 Edge => Mesh % Edges( Element % EdgeIndexes(i) ) 399 ndofs = 0 400 IF ( Def_Dofs(2) >= 0) THEN 401 ndofs = Def_Dofs(2) 402 ELSE IF (Def_Dofs(6)>=0) THEN 403 ndofs = EdgeDOFs(Element % EdgeIndexes(i)) 404! IF (Def_Dofs(6)==0) ndofs = MAX(Edge % BDOFs,ndofs) 405 ndofs = MAX(Edge % BDOFs,ndofs) 406 END IF 407 408 DO e=1,ndofs 409 j = Mesh % NumberOfNodes + EDOFs*(Element % EdgeIndexes(i)-1) + e 410 IF ( Perm(j) == 0 ) THEN 411 k = k + 1 412 Perm(j) = k 413 END IF 414 END DO 415 END DO 416 END IF 417 418 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 419 DO i=1,Element % TYPE % NumberOfFaces 420 Face => Mesh % Faces( Element % FaceIndexes(i) ) 421 l = MAX(0,Def_Dofs(3)) 422 j = Face % TYPE % ElementCode/100 423 IF(l==0) THEN 424 IF (ASSOCIATED(Face % BoundaryInfo % Left)) THEN 425 e = Face % BoundaryInfo % Left % BodyId 426 l = MAX(0,Solver % Def_Dofs(j+6,e,5)) 427 END IF 428 IF (ASSOCIATED(Face % BoundaryInfo % Right)) THEN 429 e = Face % BoundaryInfo % Right % BodyId 430 l = MAX(l,Solver % Def_Dofs(j+6,e,5)) 431 END IF 432 END IF 433 ndofs = 0 434 IF ( l >= 0) THEN 435 ndofs = l 436 ELSE IF (Def_Dofs(6)>=0) THEN 437 ndofs = FaceDOFs(Element % FaceIndexes(i)) 438! IF ( Def_Dofs(6)==0 ) ndofs = MAX(Face % BDOFs,ndofs) 439 ndofs = MAX(Face % BDOFs,ndofs) 440 END IF 441 442 DO e=1,ndofs 443 j = Mesh % NumberOfNodes + EDOFs*Mesh % NumberOfEdges + & 444 FDOFs*(Element % FaceIndexes(i)-1) + e 445 IF ( Perm(j) == 0 ) THEN 446 k = k + 1 447 Perm(j) = k 448 END IF 449 END DO 450 END DO 451 END IF 452 453 IF ( GB .AND. ASSOCIATED(Element % BubbleIndexes) ) THEN 454 ndofs = 0 455 IF ( Def_Dofs(5) >= 0) THEN 456 ndofs = Def_Dofs(5) 457 ELSE IF (Def_Dofs(6)>=0) THEN 458 ndofs = GetBubbleDOFs(Element, Def_Dofs(6)) 459 IF ( Def_Dofs(6)==0 ) ndofs = MAX(Element % BDOFs,ndofs) 460 END IF 461 462 DO i=1,ndofs 463 j = Mesh % NumberOfNodes + EDOFs*Mesh % NumberOfEdges + & 464 FDOFs*Mesh % NumberOfFaces + Element % BubbleIndexes(i) 465 IF ( Perm(j) == 0 ) THEN 466 k = k + 1 467 Perm(j) = k 468 END IF 469 END DO 470 END IF 471 472 t = t + 1 473 END DO 474 475 Radiation = ListGetLogical( Solver % Values, 'Radiation Solver', Found ) 476 IF ( Radiation .OR. Equation == 'heat equation' ) THEN 477 t = Mesh % NumberOfBulkElements + 1 478 n = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 479 DO WHILE( t<= n ) 480 Element => Mesh % Elements(t) 481 IF ( ASSOCIATED( Element % BoundaryInfo % GebhardtFactors) ) THEN 482 DO i=1,Element % TYPE % NumberOfNodes 483 j = Element % NodeIndexes(i) 484 IF ( Perm(j) == 0 ) THEN 485 k = k + 1 486 Perm(j) = k 487 END IF 488 END DO 489 END IF 490 t = t + 1 491 END DO 492 END IF 493 494 t = Mesh % NumberOfBulkElements + 1 495 n = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 496 DO WHILE( t<= n ) 497 Element => Mesh % Elements(t) 498 IF ( Element % TYPE % ElementCode == 102 ) THEN 499 DO i=1,Element % TYPE % NumberOfNodes 500 j = Element % NodeIndexes(i) 501 IF ( Perm(j) == 0 ) THEN 502 k = k + 1 503 Perm(j) = k 504 END IF 505 END DO 506 END IF 507 t = t + 1 508 END DO 509 510 ! Here we create the initial permutation such that the conforming dofs are eliminated. 511 IF( ListGetLogical( Solver % Values,'Apply Conforming BCs',Found ) ) THEN 512 Solver % PeriodicFlipActive = .FALSE. 513 n = 0 514 IF( ASSOCIATED( Mesh % PeriodicPerm ) ) THEN 515 ! Set the eliminated dofs to zero and renumber 516 WHERE( Mesh % PeriodicPerm > 0 ) Perm = -Perm 517 518 k = 0 519 DO i=1,SIZE( Perm ) 520 IF( Perm(i) > 0 ) THEN 521 k = k + 1 522 Perm(i) = k 523 END IF 524 END DO 525 526 DO i=1,SIZE( Mesh % PeriodicPerm ) 527 j = Mesh % PeriodicPerm(i) 528 IF( j > 0 .AND. Perm(i) /= 0 ) THEN 529 Perm(i) = Perm(j) 530 IF(Mesh % PeriodicFlip(i)) n = n + 1 531 END IF 532 END DO 533 534 Solver % PeriodicFlipActive = ( n > 0 ) 535 CALL Info('InitialPermutation','Number of periodic flips in the field: '//TRIM(I2S(n)),Level=8) 536 END IF 537 END IF 538 539 IF ( ALLOCATED(EdgeDOFs) ) DEALLOCATE(EdgeDOFs) 540 IF ( ALLOCATED(FaceDOFs) ) DEALLOCATE(FaceDOFs) 541!------------------------------------------------------------------------------ 542 END FUNCTION InitialPermutation 543!------------------------------------------------------------------------------ 544 545 546!--------------------------------------------------------------------------- 547!> Check if given element belongs to a body for which given equation 548!> should be solved. 549!--------------------------------------------------------------------------- 550 FUNCTION CheckElementEquation( Model,Element,Equation ) RESULT(Flag) 551 TYPE(Element_t), POINTER :: Element 552 TYPE(Model_t) :: Model 553 CHARACTER(LEN=*) :: Equation 554 CHARACTER(LEN=MAX_NAME_LEN) :: PrevEquation 555 556 LOGICAL :: Flag,Found,PrevFlag 557 558 INTEGER :: k,body_id,prev_body_id = -1 559 560 SAVE Prev_body_id, PrevEquation, PrevFlag 561!$OMP THREADPRIVATE(Prev_body_id, PrevEquation, PrevFlag) 562 563 body_id = Element % BodyId 564 565 IF( body_id == prev_body_id) THEN 566 IF (Equation == PrevEquation) THEN 567 Flag = PrevFlag 568 RETURN 569 END IF 570 END IF 571 572 prev_body_id = body_id 573 PrevEquation = Equation 574 575 Flag = .FALSE. 576 IF ( body_id > 0 .AND. body_id <= Model % NumberOfBodies ) THEN 577 k = ListGetInteger( Model % Bodies(body_id) % Values, 'Equation', Found, & 578 minv=1, maxv=Model % NumberOFEquations ) 579 IF ( k > 0 ) THEN 580 Flag = ListGetLogical(Model % Equations(k) % Values,Equation,Found) 581 END IF 582 END IF 583 PrevFlag = Flag 584 585!--------------------------------------------------------------------------- 586 END FUNCTION CheckElementEquation 587!--------------------------------------------------------------------------- 588 589 590!------------------------------------------------------------------------------ 591!> Changes the string to all lower case to allow string comparison. 592!------------------------------------------------------------------------------ 593 FUNCTION StringToLowerCase( to,from,same_len ) RESULT(n) 594!------------------------------------------------------------------------------ 595 CHARACTER(LEN=*), INTENT(in) :: from 596 CHARACTER(LEN=*), INTENT(out) :: to 597 LOGICAL, OPTIONAL, INTENT(in) :: same_len 598!------------------------------------------------------------------------------ 599 INTEGER :: n 600 INTEGER :: i,j,nlen 601 INTEGER, PARAMETER :: A=ICHAR('A'),Z=ICHAR('Z'),U2L=ICHAR('a')-ICHAR('A') 602 603 n = LEN(to) 604 IF (.NOT.PRESENT(same_len)) THEN 605 DO i=LEN(from),1,-1 606 IF ( from(i:i) /= ' ' ) EXIT 607 END DO 608 IF ( n>i ) THEN 609 to(i+1:n) = ' ' 610 n=i 611 END IF 612 END IF 613 614 nlen = n 615 DO i=1,nlen 616 j = ICHAR( from(i:i) ) 617 IF ( j >= A .AND. j <= Z ) THEN 618 to(i:i) = CHAR(j+U2L) 619 ELSE 620 to(i:i) = from(i:i) 621 IF ( to(i:i)=='[') n=i-1 622 END IF 623 END DO 624 END FUNCTION StringToLowerCase 625!------------------------------------------------------------------------------ 626 627 628!------------------------------------------------------------------------------ 629!> Adds a new variable to the list of variables. 630!> The structures need to be allocated externally beforehand. 631!------------------------------------------------------------------------------ 632 SUBROUTINE VariableAdd( Variables,Mesh,Solver,Name,DOFs,Values,& 633 Perm,Output,Secondary, TYPE ) 634!------------------------------------------------------------------------------ 635 TYPE(Variable_t), POINTER :: Variables 636 TYPE(Mesh_t), TARGET :: Mesh 637 TYPE(Solver_t), TARGET, OPTIONAL :: Solver 638 CHARACTER(LEN=*) :: Name 639 INTEGER :: DOFs 640 INTEGER, OPTIONAL :: TYPE 641 REAL(KIND=dp), POINTER :: Values(:) 642 LOGICAL, OPTIONAL :: Output 643 INTEGER, OPTIONAL, POINTER :: Perm(:) 644 LOGICAL, OPTIONAL :: Secondary 645!------------------------------------------------------------------------------ 646 LOGICAL :: stat 647 TYPE(Variable_t), POINTER :: ptr,ptr1,ptr2 648 TYPE(Solver_t), POINTER :: VSolver 649!------------------------------------------------------------------------------ 650 651 CALL Info('VariableAdd','Adding variable > '//TRIM(Name)//& 652 ' < of size '//TRIM(I2S(SIZE(Values))),Level=15) 653 654 NULLIFY(VSolver) 655 IF (PRESENT(Solver)) VSolver => Solver 656 657 IF ( .NOT.ASSOCIATED(Variables) ) THEN 658 ALLOCATE(Variables) 659 ptr => Variables 660 ELSE 661 ALLOCATE( ptr ) 662 END IF 663 664 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 665 666 IF ( .NOT. ASSOCIATED(ptr, Variables) ) THEN 667 ptr1 => Variables 668 ptr2 => Variables 669 DO WHILE( ASSOCIATED( ptr1 ) ) 670 IF ( ptr % Name == ptr1 % Name ) THEN 671 DEALLOCATE( ptr ) 672 RETURN 673 END IF 674 ptr2 => ptr1 675 ptr1 => ptr1 % Next 676 END DO 677 ptr2 % Next => ptr 678 END IF 679 ptr % Next => NULL() 680 681 ptr % DOFs = DOFs 682 IF ( PRESENT( Perm ) ) THEN 683 ptr % Perm => Perm 684 ELSE 685 ptr % Perm => NULL() 686 END IF 687 ptr % Norm = 0.0d0 688 ptr % PrevNorm = 0.0d0 689 ptr % Values => Values 690 NULLIFY( ptr % PrevValues ) 691 NULLIFY( ptr % EigenValues, ptr % EigenVectors ) 692 693 ptr % NonlinChange = 0.0_dp 694 ptr % SteadyChange = 0.0_dp 695 ptr % NonlinValues => NULL() 696 ptr % SteadyValues => NULL() 697 ptr % NonlinIter = 0 698 699 ptr % Solver => VSolver 700 ptr % PrimaryMesh => Mesh 701 702 ptr % Valid = .TRUE. 703 ptr % Output = .TRUE. 704 ptr % Secondary = .FALSE. 705 ptr % ValuesChanged = .TRUE. 706 707! Converged information undefined = -1, not = 0, yes = 1 708 ptr % NonlinConverged = -1 709 ptr % SteadyConverged = -1 710 711 IF ( PRESENT( Secondary ) ) THEN 712 ptr % Secondary = Secondary 713 END IF 714 715 IF ( PRESENT( TYPE ) ) ptr % TYPE = TYPE 716 IF ( PRESENT( Output ) ) ptr % Output = Output 717!------------------------------------------------------------------------------ 718 END SUBROUTINE VariableAdd 719!------------------------------------------------------------------------------ 720 721 722!------------------------------------------------------------------------------ 723 SUBROUTINE ReleaseVariableList( VariableList ) 724!------------------------------------------------------------------------------ 725use spariterglobals 726 TYPE(Variable_t), POINTER :: VariableList 727!------------------------------------------------------------------------------ 728 REAL(KIND=dp), POINTER :: Ptr(:) 729 LOGICAL :: GotValues 730 INTEGER :: i, n, m 731 TYPE(Variable_t), POINTER :: Var, Var1 732!------------------------------------------------------------------------------ 733 734 Var => VariableList 735 DO WHILE( ASSOCIATED( Var ) ) 736 737! This is used to skip variables such as time, timestep, timestep size etc. 738 IF (ASSOCIATED(Var % Values) ) THEN 739 IF( SIZE( Var % Values ) == Var % DOFs ) THEN 740 Var => Var % Next 741 CYCLE 742 END IF 743 END IF 744 745 SELECT CASE( Var % Name ) 746 CASE( 'coordinate 1', 'coordinate 2', 'coordinate 3' ) 747 Var => Var % Next 748 CYCLE 749 END SELECT 750 751 IF( Var % Secondary ) THEN 752 Var => Var % Next 753 CYCLE 754 END IF 755 756 IF (Var % DOFs > 1) THEN 757 Var => Var % Next 758 CYCLE 759 END IF 760! 761! Check that the variable is actually allocated, 762! not pointer to some other variables memory: 763! ---------------------------------------------- 764 765 GotValues = .TRUE. 766 Var1 => VariableList 767 DO WHILE( ASSOCIATED( Var1 ) ) 768 IF (.NOT.ASSOCIATED(Var,Var1)) THEN 769 IF ( ASSOCIATED(Var1 % Values) ) THEN 770 DO i=1,Var1 % DOFs 771 ptr => Var1 % Values(i::Var1 % DOFs) 772 IF ( ASSOCIATED(Var % Values,ptr) ) THEN 773 GotValues = .FALSE. 774 EXIT 775 END IF 776 END DO 777 END IF 778 END IF 779 IF (.NOT. GotValues) EXIT 780 Var1 => Var1 % Next 781 END DO 782 783 IF(SIZE(Var % Values)<=0) GotValues = .FALSE. 784 785 IF (ASSOCIATED(Var % Perm)) THEN 786 Var1 => VariableList 787 DO WHILE(ASSOCIATED(Var1)) 788 IF (.NOT.ASSOCIATED(Var,Var1)) THEN 789 IF (ASSOCIATED(Var % Perm,Var1 % Perm)) & 790 Var1 % Perm => NULL() 791 END IF 792 Var1 => Var1 % Next 793 END DO 794 795 IF(SIZE(Var % Perm)>0) THEN 796 DEALLOCATE( Var % Perm) 797 ELSE 798 GotValues = .FALSE. 799 END IF 800 END IF 801 802 IF ( GotValues ) THEN 803 IF ( ASSOCIATED( Var % Values ) ) & 804 DEALLOCATE( Var % Values ) 805 806 IF ( ASSOCIATED( Var % PrevValues ) ) & 807 DEALLOCATE( Var % PrevValues ) 808 809 IF ( ASSOCIATED( Var % EigenValues ) ) & 810 DEALLOCATE( Var % EigenValues ) 811 812 IF ( ASSOCIATED( Var % EigenVectors ) ) & 813 DEALLOCATE( Var % EigenVectors ) 814 815 IF ( ASSOCIATED( Var % SteadyValues ) ) & 816 DEALLOCATE( Var % SteadyValues ) 817 818 IF ( ASSOCIATED( Var % NonlinValues ) ) & 819 DEALLOCATE( Var % NonlinValues ) 820 END IF 821 NULLIFY( Var % EigenVectors, Var % EigenValues ) 822 NULLIFY( Var % Values, Var % PrevValues, Var % Perm ) 823 NULLIFY( Var % SteadyValues, Var % NonlinValues ) 824 825 Var => Var % Next 826 END DO 827 828 Var => VariableList 829 DO WHILE( ASSOCIATED( Var ) ) 830 IF ( Var % Secondary ) THEN 831 Var => Var % Next 832 CYCLE 833 END IF 834 835 IF ( Var % DOFs > 1 ) THEN 836 IF ( ASSOCIATED( Var % Values ) ) & 837 DEALLOCATE( Var % Values ) 838 839 IF ( ASSOCIATED( Var % Perm ) ) & 840 DEALLOCATE( Var % Perm ) 841 842 IF ( ASSOCIATED( Var % PrevValues ) ) & 843 DEALLOCATE( Var % PrevValues ) 844 845 IF ( ASSOCIATED( Var % EigenValues ) ) & 846 DEALLOCATE( Var % EigenValues ) 847 848 IF ( ASSOCIATED( Var % EigenVectors ) ) & 849 DEALLOCATE( Var % EigenVectors ) 850 851 IF ( ASSOCIATED( Var % NonlinValues ) ) & 852 DEALLOCATE( Var % NonlinValues ) 853 END IF 854 NULLIFY( Var % EigenVectors, Var % EigenValues ) 855 NULLIFY( Var % Values, Var % PrevValues, Var % Perm ) 856 NULLIFY( Var % SteadyValues, Var % NonlinValues ) 857 858 Var => Var % Next 859 END DO 860 861 862! Deallocate mesh variable list: 863! ------------------------------ 864 Var => VariableList 865 DO WHILE( ASSOCIATED( Var ) ) 866 Var1 => Var % Next 867 DEALLOCATE( Var ) 868 Var => Var1 869 END DO 870!------------------------------------------------------------------------------ 871 END SUBROUTINE ReleaseVariableList 872!------------------------------------------------------------------------------ 873 874 875!------------------------------------------------------------------------------ 876!> Deletes a variable (by name) from list of variables 877!------------------------------------------------------------------------------ 878 SUBROUTINE VariableRemove(Variables, NameIn, WarnMiss) 879 880 IMPLICIT NONE 881!----------------------------------------------- 882 TYPE(Variable_t), POINTER :: Variables 883 CHARACTER(LEN=*) :: NameIn 884 LOGICAL, OPTIONAL :: WarnMiss 885!----------------------------------------------- 886 TYPE(Variable_t), POINTER :: Var, Prev, RmVar 887 CHARACTER(LEN=LEN_TRIM(NameIn)) :: Name 888 LOGICAL :: GotIt, WarnMissing 889 INTEGER :: k 890 891 GotIt = .FALSE. 892 IF(PRESENT(WarnMiss)) THEN 893 WarnMissing = WarnMiss 894 ELSE 895 WarnMissing = .TRUE. 896 END IF 897 898 Var => Variables 899 Prev => NULL() 900 k = StringToLowerCase(Name, NameIn,.TRUE.) 901 902 WRITE(Message,'(a,a)') "Removing variable: ",Name(1:k) 903 CALL Info("VariableRemove",Message, Level=10) 904 905 !Find variable by name, and hook up % Next appropriately 906 DO WHILE(ASSOCIATED(Var)) 907 IF( Var % NameLen == k ) THEN 908 IF(Var % Name(1:k) == Name(1:k)) THEN 909 GotIt = .TRUE. 910 RmVar => Var 911 IF(ASSOCIATED(Prev)) THEN 912 !Link up variables either side of removed var 913 Prev % Next => Var % Next 914 ELSE 915 !If this was the first variable, we point Variables 916 !at the next one... 917 Variables => Var % Next 918 END IF 919 EXIT 920 END IF 921 END IF 922 Prev => Var 923 Var => Prev % Next 924 END DO 925 926 IF(.NOT. GotIt) THEN 927 IF(WarnMissing) CALL Warn("VariableRemove","Couldn't find the variable, returning...") 928 RETURN 929 END IF 930 931 RmVar % Next => NULL() 932 933 !cycle other variables to check for Perm association 934 IF (ASSOCIATED(RmVar % Perm)) THEN 935 Var => Variables 936 DO WHILE(ASSOCIATED(Var)) 937 IF(ASSOCIATED(RmVar, Var)) & 938 CALL Fatal("VariableRemove", "Programming Error - Variable appears twice in list?") 939 IF (ASSOCIATED(Var % Perm,RmVar % Perm)) THEN 940 RmVar % Perm => NULL() 941 EXIT 942 END IF 943 Var => Var % Next 944 END DO 945 946 !ASSOCIATION between zero-length arrays cannot be tested 947 !so nullify it anyway, just to be safe. Technically results 948 !in a memory leak (of size zero??) 949 IF(SIZE(RmVar % Perm) == 0) RmVar % Perm => NULL() 950 END IF 951 952 953 954 !ReleaseVariableList was intended to deallocate an entire list of variables, 955 !but by nullifying RmVar % Next, we have effectively isolated RmVar in 956 !its own variable list. 957 CALL ReleaseVariableList( RmVar ) 958!------------------------------------------------------------------------------ 959 END SUBROUTINE VariableRemove 960!------------------------------------------------------------------------------ 961 962 963 964!------------------------------------------------------------------------------ 965!> For vectors the individual components are added also to the list 966!> of variables. This routine makes the addition of vectors less laborious. 967!> Also allocates the field values if not given in the parameter list. 968!------------------------------------------------------------------------------ 969 SUBROUTINE VariableAddVector( Variables,Mesh,Solver,Name,DOFs,Values,& 970 Perm,Output,Secondary,VarType,Global,InitValue,IpPoints) 971!------------------------------------------------------------------------------ 972 TYPE(Variable_t), POINTER :: Variables 973 TYPE(Mesh_t), TARGET :: Mesh 974 TYPE(Solver_t), TARGET, OPTIONAL :: Solver 975 CHARACTER(LEN=*) :: Name 976 INTEGER, OPTIONAL :: DOFs 977 REAL(KIND=dp), OPTIONAL, POINTER :: Values(:) 978 LOGICAL, OPTIONAL :: Output 979 INTEGER, OPTIONAL, POINTER :: Perm(:) 980 LOGICAL, OPTIONAL :: Secondary 981 INTEGER, OPTIONAL :: VarType 982 LOGICAL, OPTIONAL :: Global 983 REAL(KIND=dp), OPTIONAL :: InitValue 984 LOGICAL, OPTIONAL :: IpPoints 985!------------------------------------------------------------------------------ 986 CHARACTER(LEN=MAX_NAME_LEN) :: tmpname 987 REAL(KIND=dp), POINTER :: Component(:), TmpValues(:) 988 INTEGER :: i,nsize, ndofs, FieldType 989 LOGICAL :: IsPerm, IsGlobal, IsIPPoints 990!------------------------------------------------------------------------------ 991 992 IF( PRESENT( DOFs ) ) THEN 993 ndofs = Dofs 994 ELSE 995 ndofs = 1 996 END IF 997 998 IsPerm = .FALSE. 999 IsGlobal = .FALSE. 1000 IsIPPoints = .FALSE. 1001 1002 IsPerm = PRESENT( Perm ) 1003 IF( PRESENT( Global ) ) IsGlobal = Global 1004 IF( PRESENT( IPPoints ) ) IsIPPoints = IPPoints 1005 1006 IF( PRESENT( VarType ) ) THEN 1007 FieldType = VarType 1008 ELSE 1009 FieldType = variable_on_nodes 1010 END IF 1011 1012 1013 1014 CALL Info('VariableAddVector','Adding variable > '//TRIM(Name)//' < with '& 1015 //TRIM(I2S(ndofs))//' components',Level=15) 1016 1017 IF(PRESENT(Values)) THEN 1018 TmpValues => Values 1019 ELSE 1020 IF( IsPerm ) THEN 1021 nsize = MAXVAL( Perm ) 1022 ELSE IF( IsGlobal ) THEN 1023 nsize = 1 1024 ELSE IF( IsIpPoints ) THEN 1025 IF( .NOT. PRESENT( Solver ) ) THEN 1026 CALL Fatal('VariableAddVector','Integration point variable needs a Solver!') 1027 END IF 1028 IF( .NOT. ASSOCIATED( Solver % IPTable ) ) THEN 1029 CALL Fatal('VariableAddVector','Integration point variable needs an IpTable') 1030 END IF 1031 nsize = Solver % IPTable % IPCount 1032 ELSE 1033 nsize = Mesh % NumberOfNodes 1034 END IF 1035 CALL Info('VariableAddVector','Allocating field of size: '//TRIM(I2S(nsize)),Level=12) 1036 1037 NULLIFY(TmpValues) 1038 ALLOCATE(TmpValues(ndofs*nsize)) 1039 TmpValues = 0.0_dp 1040 END IF 1041 1042 IF( PRESENT( InitValue ) ) THEN 1043 TmpValues = InitValue 1044 END IF 1045 1046 IF( nDOFs > 1 ) THEN 1047 DO i=1,nDOFs 1048 tmpname = ComponentName(Name,i) 1049 Component => TmpValues(i::nDOFs) 1050 CALL VariableAdd( Variables,Mesh,Solver,TmpName,1,Component,& 1051 Perm,Output,Secondary,VarType) 1052 END DO 1053 END IF 1054 1055 CALL VariableAdd( Variables,Mesh,Solver,Name,nDOFs,TmpValues,& 1056 Perm,Output,Secondary,VarType) 1057 1058!------------------------------------------------------------------------------ 1059 END SUBROUTINE VariableAddVector 1060!------------------------------------------------------------------------------ 1061 1062 1063!------------------------------------------------------------------------------ 1064 FUNCTION MeshProjector( Mesh1, Mesh2, & 1065 UseQuadrantTree, Trans ) RESULT( ProjectorMatrix ) 1066!------------------------------------------------------------------------------ 1067 TYPE(Mesh_t) :: Mesh1, Mesh2 1068 LOGICAL, OPTIONAL :: UseQuadrantTree,Trans 1069 TYPE(Matrix_t), POINTER :: ProjectorMatrix 1070!------------------------------------------------------------------------------ 1071 TYPE(Projector_t), POINTER :: Projector 1072!------------------------------------------------------------------------------ 1073 INTERFACE 1074 SUBROUTINE InterpolateMeshToMeshQ( OldMesh, NewMesh, OldVariables, NewVariables, & 1075 UseQuadrantTree, Projector, MaskName, FoundNodes, NewMaskPerm, KeepUnfoundNodes ) 1076 USE Types 1077 TYPE(Variable_t), POINTER, OPTIONAL :: OldVariables, NewVariables 1078 TYPE(Mesh_t), TARGET :: OldMesh, NewMesh 1079 LOGICAL, OPTIONAL :: UseQuadrantTree,FoundNodes(:) 1080 CHARACTER(LEN=*),OPTIONAL :: MaskName 1081 TYPE(Projector_t), POINTER, OPTIONAL :: Projector 1082 INTEGER, OPTIONAL, POINTER :: NewMaskPerm(:) !< Mask the new variable set by the given MaskName when trying to define the interpolation. 1083 LOGICAL, OPTIONAL :: KeepUnfoundNodes !< Do not disregard unfound nodes from projector 1084 END SUBROUTINE InterpolateMeshToMeshQ 1085 END INTERFACE 1086 1087 IF ( PRESENT(UseQuadrantTree) ) THEN 1088 CALL InterpolateMeshToMeshQ( Mesh1, Mesh2, & 1089 UseQuadrantTree=UseQuadrantTree, Projector=Projector ) 1090 ELSE 1091 CALL InterpolateMeshToMeshQ( Mesh1, Mesh2, Projector=Projector ) 1092 END IF 1093 1094 ProjectorMatrix => Projector % Matrix 1095 IF ( PRESENT(Trans) ) THEN 1096 IF ( Trans ) THEN 1097 ProjectorMatrix => Projector % TMatrix 1098 END IF 1099 END IF 1100!------------------------------------------------------------------------------ 1101 END FUNCTION MeshProjector 1102!------------------------------------------------------------------------------ 1103 1104 1105!------------------------------------------------------------------------------ 1106!> Find a variable by its name from the list of variables. 1107!> If it not to be found in the current mesh, interpolation between 1108!> meshes is automatically requested for. 1109!------------------------------------------------------------------------------ 1110 RECURSIVE FUNCTION VariableGet( Variables, Name, ThisOnly, MaskName, UnfoundFatal ) RESULT(Var) 1111!------------------------------------------------------------------------------ 1112 TYPE(Variable_t), POINTER :: Variables 1113 CHARACTER(LEN=*) :: Name 1114 LOGICAL, OPTIONAL :: ThisOnly 1115 CHARACTER(LEN=*),OPTIONAL :: MaskName 1116 LOGICAL, OPTIONAL :: UnfoundFatal 1117!------------------------------------------------------------------------------ 1118 TYPE(Mesh_t), POINTER :: Mesh 1119 TYPE(Projector_t), POINTER :: Projector 1120 TYPE(Variable_t), POINTER :: Var,PVar,Tmp,AidVar 1121 REAL(KIND=dp), POINTER :: Vals(:) 1122 INTEGER :: i,k,n, DOFs 1123 LOGICAL :: Found, GlobalBubbles, UseProjector 1124 CHARACTER(LEN=LEN_TRIM(Name)) :: str 1125 CHARACTER(LEN=MAX_NAME_LEN) :: tmpname 1126 DOUBLE PRECISION :: t1 1127!------------------------------------------------------------------------------ 1128 INTERFACE 1129 SUBROUTINE InterpolateMeshToMesh( OldMesh, NewMesh, OldVariables, & 1130 NewVariables, UseQuadrantTree, Projector, MaskName, UnfoundNodes ) 1131 USE Types 1132 TYPE(Variable_t), POINTER, OPTIONAL :: OldVariables, NewVariables 1133 TYPE(Mesh_t), TARGET :: OldMesh, NewMesh 1134 LOGICAL, OPTIONAL :: UseQuadrantTree 1135 LOGICAL, POINTER, OPTIONAL :: UnfoundNodes(:) 1136 CHARACTER(LEN=*),OPTIONAL :: MaskName 1137 TYPE(Projector_t), POINTER, OPTIONAL :: Projector 1138 END SUBROUTINE InterpolateMeshToMesh 1139 END INTERFACE 1140!------------------------------------------------------------------------------ 1141 1142 k = StringToLowerCase( str,Name,.TRUE. ) 1143 1144 Tmp => Variables 1145 DO WHILE( ASSOCIATED(tmp) ) 1146 IF ( tmp % NameLen == k ) THEN 1147 IF ( tmp % Name(1:k) == str(1:k) ) THEN 1148 1149 IF ( Tmp % Valid ) THEN 1150 Var => Tmp 1151 RETURN 1152 END IF 1153 EXIT 1154 1155 END IF 1156 END IF 1157 tmp => tmp % Next 1158 END DO 1159 Var => Tmp 1160 1161 1162!------------------------------------------------------------------------------ 1163 IF ( PRESENT(ThisOnly) ) THEN 1164 IF ( ThisOnly ) THEN 1165 IF ( PRESENT(UnfoundFatal) ) THEN 1166 IF ( UnfoundFatal ) THEN 1167 CALL Fatal("VariableGet","Failed to find variable "//TRIM(Name)) 1168 END IF 1169 END IF 1170 RETURN 1171 END IF 1172 END IF 1173 1174!------------------------------------------------------------------------------ 1175 NULLIFY( PVar ) 1176 Mesh => CurrentModel % Meshes 1177 DO WHILE( ASSOCIATED( Mesh ) ) 1178 1179 IF ( .NOT.ASSOCIATED( Variables, Mesh % Variables ) ) THEN 1180 PVar => VariableGet( Mesh % Variables, Name, ThisOnly=.TRUE. ) 1181 IF ( ASSOCIATED( PVar ) ) THEN 1182 IF ( ASSOCIATED( Mesh, PVar % PrimaryMesh ) ) THEN 1183 EXIT 1184 END IF 1185 END IF 1186 END IF 1187 Mesh => Mesh % Next 1188 END DO 1189 1190 IF ( .NOT.ASSOCIATED( PVar ) ) THEN 1191 IF ( PRESENT(UnfoundFatal) ) THEN 1192 IF ( UnfoundFatal ) THEN 1193 CALL Fatal("VariableGet","Failed to find or interpolate variable: "//TRIM(Name)) 1194 END IF 1195 END IF 1196 RETURN 1197 END IF 1198 1199!------------------------------------------------------------------------------ 1200 1201 IF ( .NOT.ASSOCIATED( Tmp ) ) THEN 1202 !GlobalBubbles = ListGetLogical(Pvar % Solver % Values, & 1203 ! 'Bubbles in Global System', Found) 1204 !IF (.NOT.Found) GlobalBubbles=.TRUE. 1205 GlobalBubbles = Pvar % Solver % GlobalBubbles 1206 1207 DOFs = CurrentModel % Mesh % NumberOfNodes * PVar % DOFs 1208 IF ( GlobalBubbles ) DOFs = DOFs + CurrentModel % Mesh % MaxBDOFs * & 1209 CurrentModel % Mesh % NumberOfBulkElements * PVar % DOFs 1210 1211 ALLOCATE( Var ) 1212 ALLOCATE( Var % Values(DOFs) ) 1213 Var % Values = 0 1214 1215 NULLIFY( Var % Perm ) 1216 IF ( ASSOCIATED( PVar % Perm ) ) THEN 1217 ALLOCATE( Var % Perm( DOFs/Pvar % DOFs ) ) 1218 1219 n = InitialPermutation( Var % Perm, CurrentModel, PVar % Solver, & 1220 CurrentModel % Mesh, ListGetString(PVar % Solver % Values,'Equation'), & 1221 GlobalBubbles=GlobalBubbles ) 1222 1223 IF ( n==0 ) n=CurrentModel % Mesh % NumberOfNodes 1224 1225 IF ( n == CurrentModel % Mesh % NumberOfNodes ) THEN 1226 DO i=1,n 1227 Var % Perm(i) = i 1228 END DO 1229 END IF 1230 END IF 1231 1232 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1233 PVar % Name, PVar % DOFs, Var % Values, Var % Perm, PVar % Output ) 1234 1235 Var => VariableGet( Variables, Name, ThisOnly=.TRUE. ) 1236 1237 NULLIFY( Var % PrevValues ) 1238 IF ( ASSOCIATED( PVar % PrevValues ) ) THEN 1239 ALLOCATE( Var % PrevValues( DOFs, SIZE(PVar % PrevValues,2) ) ) 1240 END IF 1241 1242 IF ( PVar % Name(1:PVar % NameLen) == 'flow solution' ) THEN 1243 Vals => Var % Values( 1: SIZE(Var % Values) : PVar % DOFs ) 1244 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1245 'Velocity 1', 1, Vals, Var % Perm, PVar % Output ) 1246 1247 Tmp => VariableGet( Variables, 'Velocity 1', .TRUE. ) 1248 NULLIFY( Tmp % PrevValues ) 1249 IF ( ASSOCIATED( Var % PrevValues ) ) & 1250 Tmp % PrevValues => Var % PrevValues(1::PVar % DOFs,:) 1251 1252 Vals => Var % Values( 2: SIZE(Var % Values) : PVar % DOFs ) 1253 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1254 'Velocity 2', 1, Vals, Var % Perm, PVar % Output ) 1255 1256 Tmp => VariableGet( Variables, 'Velocity 2', .TRUE. ) 1257 NULLIFY( Tmp % PrevValues ) 1258 IF ( ASSOCIATED( Var % PrevValues ) ) & 1259 Tmp % PrevValues => Var % PrevValues(2::PVar % DOFs,:) 1260 1261 IF ( PVar % DOFs == 3 ) THEN 1262 Vals => Var % Values( 3 : SIZE(Var % Values) : PVar % DOFs ) 1263 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1264 'Pressure', 1, Vals, Var % Perm, PVar % Output ) 1265 ELSE 1266 Vals => Var % Values( 3: SIZE(Var % Values) : PVar % DOFs ) 1267 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1268 'Velocity 3', 1, Vals, Var % Perm, PVar % Output ) 1269 1270 Tmp => VariableGet( Variables, 'Velocity 3', .TRUE. ) 1271 NULLIFY( Tmp % PrevValues ) 1272 IF ( ASSOCIATED( Var % PrevValues ) ) & 1273 Tmp % PrevValues => Var % PrevValues(3::PVar % DOFs,:) 1274 1275 Vals => Var % Values( 4: SIZE(Var % Values) : PVar % DOFs ) 1276 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1277 'Pressure', 1, Vals, Var % Perm, PVar % Output ) 1278 END IF 1279 1280 Tmp => VariableGet( Variables, 'Pressure', .TRUE. ) 1281 NULLIFY( Tmp % PrevValues ) 1282 IF ( ASSOCIATED( Var % PrevValues ) ) & 1283 Tmp % PrevValues => Var % PrevValues(PVar % DOFs::PVar % DOFs,:) 1284 ELSE 1285 IF ( PVar % DOFs > 1 ) THEN 1286 DO i=1,PVar % DOFs 1287 Vals => Var % Values( i: SIZE(Var % Values) : PVar % DOFs ) 1288 tmpname = ComponentName( PVar % Name, i ) 1289 CALL VariableAdd( Variables, PVar % PrimaryMesh, PVar % Solver, & 1290 tmpname, 1, Vals, Var % Perm, PVar % Output ) 1291 1292 Tmp => VariableGet( Variables, tmpname, .TRUE. ) 1293 NULLIFY( Tmp % PrevValues ) 1294 IF ( ASSOCIATED( Var % PrevValues ) ) & 1295 Tmp % PrevValues => Var % PrevValues(i::PVar % DOFs,:) 1296 END DO 1297 END IF 1298 END IF 1299 1300 Var => VariableGet( Variables, Name, ThisOnly=.TRUE. ) 1301 END IF 1302 1303!------------------------------------------------------------------------------ 1304! Build a temporary variable list of variables to be interpolated 1305!------------------------------------------------------------------------------ 1306 ALLOCATE( Tmp ) 1307 Tmp = PVar 1308 Var => Tmp 1309 NULLIFY( Var % Next ) 1310 1311 IF ( PVar % Name(1:PVar % NameLen) == 'flow solution' ) THEN 1312 ALLOCATE( Var % Next ) 1313 Var => Var % Next 1314 Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 1' ) 1315 1316 ALLOCATE( Var % Next ) 1317 Var => Var % Next 1318 Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 2' ) 1319 1320 IF ( PVar % DOFs == 4 ) THEN 1321 ALLOCATE( Var % Next ) 1322 Var => Var % Next 1323 Var = VariableGet( PVar % PrimaryMesh % Variables, 'Velocity 3' ) 1324 END IF 1325 1326 ALLOCATE( Var % Next ) 1327 Var => Var % Next 1328 Var = VariableGet( PVar % PrimaryMesh % Variables, 'Pressure' ) 1329 NULLIFY( Var % Next ) 1330 Var => Tmp 1331 ELSE IF ( PVar % DOFs > 1 ) THEN 1332 DO i=1,PVar % DOFs 1333 ALLOCATE( Var % Next ) 1334 tmpname = ComponentName( PVar % Name, i ) 1335 Var % Next = VariableGet( PVar % PrimaryMesh % Variables, tmpname ) 1336 Var => Var % Next 1337 END DO 1338 NULLIFY( Var % Next ) 1339 Var => Tmp 1340 END IF 1341 1342!------------------------------------------------------------------------------ 1343! interpolation call 1344!------------------------------------------------------------------------------ 1345 t1 = CPUTime() 1346 1347 UseProjector = ListGetLogical(CurrentModel % Simulation,'Use Mesh Projector',Found) 1348 IF( .NOT. Found ) UseProjector = .TRUE. 1349 1350 IF( PRESENT( MaskName ) ) THEN 1351 CALL Info('VariableGet','Performing masked on-the-fly interpolation',Level=15) 1352 CALL InterpolateMeshToMesh( PVar % PrimaryMesh, & 1353 CurrentModel % Mesh, Var, Variables, MaskName=MaskName ) 1354 ELSE IF( UseProjector ) THEN 1355 CALL Info('VariableGet','Performing interpolation with projector',Level=15) 1356 CALL InterpolateMeshToMesh( PVar % PrimaryMesh, & 1357 CurrentModel % Mesh, Var, Variables, Projector=Projector ) 1358 ELSE 1359 CALL Info('VariableGet','Performing on-the-fly interpolation',Level=15) 1360 AidVar => VariableGet( CurrentModel % Mesh % Variables, Name, ThisOnly = .TRUE. ) 1361 IF( ASSOCIATED( AidVar ) ) THEN 1362 AidVar % Values = 0.0_dp 1363 END IF 1364 CALL InterpolateMeshToMesh( PVar % PrimaryMesh, & 1365 CurrentModel % Mesh, Var, Variables ) 1366 END IF 1367 1368 IF( InfoActive( 20 ) ) THEN 1369 AidVar => VariableGet( CurrentModel % Mesh % Variables, Name, ThisOnly = .TRUE. ) 1370 PRINT *,'Interpolation range:',TRIM(AidVar % Name),MINVAL(AidVar % Values),MAXVAL( AidVar % Values) 1371 END IF 1372 1373 WRITE( Message,'(A,ES12.3)' ) 'Interpolation time for > '//TRIM(Name)//' < :', CPUTime()-t1 1374 CALL Info( 'VariableGet', Message, Level=7 ) 1375 1376!------------------------------------------------------------------------------ 1377! free the temporary list 1378!------------------------------------------------------------------------------ 1379 DO WHILE( ASSOCIATED( Tmp ) ) 1380 Var => Tmp % Next 1381 DEALLOCATE( Tmp ) 1382 Tmp => Var 1383 END DO 1384!------------------------------------------------------------------------------ 1385 Var => VariableGet( Variables, Name, ThisOnly=.TRUE. ) 1386 Var % Valid = .TRUE. 1387 Var % ValuesChanged = .TRUE. 1388 1389 IF ( Var % Name(1:Var % NameLen) == 'flow solution' ) THEN 1390 Tmp => VariableGet( Variables, 'Velocity 1', ThisOnly=.TRUE. ) 1391 IF ( ASSOCIATED(Tmp) ) THEN 1392 Tmp % Valid = .TRUE. 1393 Tmp % ValuesChanged = .TRUE. 1394 END IF 1395 1396 Tmp => VariableGet( Variables, 'Velocity 2', ThisOnly=.TRUE. ) 1397 IF ( ASSOCIATED(Tmp) ) THEN 1398 Tmp % Valid = .TRUE. 1399 Tmp % ValuesChanged = .TRUE. 1400 END IF 1401 1402 IF ( Var % DOFs == 4 ) THEN 1403 Tmp => VariableGet( Variables, 'Velocity 3', ThisOnly=.TRUE. ) 1404 IF ( ASSOCIATED(Tmp) ) THEN 1405 Tmp % Valid = .TRUE. 1406 Tmp % ValuesChanged = .TRUE. 1407 END IF 1408 END IF 1409 1410 Tmp => VariableGet( Variables, 'Pressure', ThisOnly=.TRUE. ) 1411 IF ( ASSOCIATED(Tmp) ) THEN 1412 Tmp % Valid = .TRUE. 1413 Tmp % ValuesChanged = .TRUE. 1414 END IF 1415 ELSE IF ( Var % DOFs > 1 ) THEN 1416 DO i = 1,Var % DOFs 1417 tmpname = ComponentName( Var % Name, i ) 1418 Tmp => VariableGet( Variables, tmpname, ThisOnly=.TRUE. ) 1419 IF ( ASSOCIATED(Tmp) ) THEN 1420 Tmp % Valid = .TRUE. 1421 Tmp % ValuesChanged = .TRUE. 1422 END IF 1423 END DO 1424 END IF 1425!------------------------------------------------------------------------------ 1426 END FUNCTION VariableGet 1427!------------------------------------------------------------------------------ 1428 1429 1430!------------------------------------------------------------------------------ 1431 FUNCTION ListHead(list) RESULT(head) 1432!------------------------------------------------------------------------------ 1433 TYPE(ValueList_t) :: List 1434 TYPE(ValueListEntry_t), POINTER :: Head 1435!------------------------------------------------------------------------------ 1436 head => List % Head 1437!------------------------------------------------------------------------------ 1438 END FUNCTION ListHead 1439!------------------------------------------------------------------------------ 1440 1441!------------------------------------------------------------------------------ 1442 FUNCTION ListEmpty(list) RESULT(l) 1443!------------------------------------------------------------------------------ 1444 LOGICAL :: L 1445 TYPE(ValueList_t) :: list 1446!------------------------------------------------------------------------------ 1447 L = .NOT.ASSOCIATED(list % head) 1448!------------------------------------------------------------------------------ 1449 END FUNCTION ListEmpty 1450!------------------------------------------------------------------------------ 1451 1452 1453!------------------------------------------------------------------------------ 1454!> Allocates a new value list. 1455!------------------------------------------------------------------------------ 1456 FUNCTION ListAllocate() RESULT(ptr) 1457!------------------------------------------------------------------------------ 1458 TYPE(ValueList_t), POINTER :: ptr 1459 ALLOCATE( ptr ) 1460 ptr % Head => Null() 1461!------------------------------------------------------------------------------ 1462 END FUNCTION ListAllocate 1463!------------------------------------------------------------------------------ 1464 1465!------------------------------------------------------------------------------ 1466!> Allocates a new value list. 1467!------------------------------------------------------------------------------ 1468 FUNCTION ListEntryAllocate() RESULT(ptr) 1469!------------------------------------------------------------------------------ 1470 TYPE(ValueListEntry_t), POINTER :: ptr 1471 1472 ALLOCATE( ptr ) 1473 ptr % PROCEDURE = 0 1474 ptr % TYPE = 0 1475 ptr % Name = ' ' 1476 ptr % NameLen = 0 1477 ptr % CValue = ' ' 1478 ptr % LValue = .FALSE. 1479 NULLIFY( ptr % CubicCoeff ) 1480 NULLIFY( ptr % Cumulative ) 1481 NULLIFY( ptr % Next ) 1482 NULLIFY( ptr % FValues ) 1483 NULLIFY( ptr % TValues ) 1484 NULLIFY( ptr % IValues ) 1485!------------------------------------------------------------------------------ 1486 END FUNCTION ListEntryAllocate 1487!------------------------------------------------------------------------------ 1488 1489 1490!------------------------------------------------------------------------------ 1491!> Deletes a value list. 1492!------------------------------------------------------------------------------ 1493 SUBROUTINE ListDelete( ptr ) 1494!------------------------------------------------------------------------------ 1495 TYPE(ValueListEntry_t), POINTER :: ptr 1496 1497 IF ( ASSOCIATED(ptr % CubicCoeff) ) DEALLOCATE(ptr % CubicCoeff) 1498 IF ( ASSOCIATED(ptr % Cumulative) ) DEALLOCATE(ptr % Cumulative) 1499 IF ( ASSOCIATED(ptr % FValues) ) DEALLOCATE(ptr % FValues) 1500 IF ( ASSOCIATED(ptr % TValues) ) DEALLOCATE(ptr % TValues) 1501 IF ( ASSOCIATED(ptr % IValues) ) DEALLOCATE(ptr % IValues) 1502 DEALLOCATE( ptr ) 1503!------------------------------------------------------------------------------ 1504 END SUBROUTINE ListDelete 1505!------------------------------------------------------------------------------ 1506 1507 1508!------------------------------------------------------------------------------ 1509!> Removes an entry from the list by its name. 1510!------------------------------------------------------------------------------ 1511 SUBROUTINE ListRemove( List, Name ) 1512!------------------------------------------------------------------------------ 1513 TYPE(ValueList_t) :: List 1514 CHARACTER(LEN=*) :: Name 1515!------------------------------------------------------------------------------ 1516 CHARACTER(LEN=LEN_TRIM(Name)) :: str 1517 INTEGER :: k 1518 LOGICAL :: Found 1519 TYPE(ValueListEntry_t), POINTER :: ptr, prev 1520!------------------------------------------------------------------------------ 1521 IF ( ASSOCIATED(List % Head) ) THEN 1522 k = StringToLowerCase( str,Name,.TRUE. ) 1523 ptr => List % Head 1524 Prev => ptr 1525 DO WHILE( ASSOCIATED(ptr) ) 1526 IF ( ptr % NameLen == k .AND. ptr % Name(1:k) == str(1:k) ) THEN 1527 IF ( ASSOCIATED(ptr,List % Head) ) THEN 1528 List % Head => ptr % Next 1529 Prev => List % Head 1530 ELSE 1531 Prev % Next => ptr % Next 1532 END IF 1533 CALL ListDelete(ptr) 1534 EXIT 1535 ELSE 1536 Prev => ptr 1537 ptr => ptr % Next 1538 END IF 1539 END DO 1540 END IF 1541!------------------------------------------------------------------------------ 1542 END SUBROUTINE ListRemove 1543!------------------------------------------------------------------------------ 1544 1545 1546!------------------------------------------------------------------------------ 1547!> Adds an entry to the list by its name and returns a handle to the new entry. If the entry is 1548!> already existing return the existing one. 1549!------------------------------------------------------------------------------ 1550 FUNCTION ListAdd( List, Name ) RESULT(NEW) 1551!------------------------------------------------------------------------------ 1552 TYPE(ValueList_t), POINTER :: List 1553 CHARACTER(LEN=*) :: Name 1554 TYPE(ValueListEntry_t), POINTER :: new 1555!------------------------------------------------------------------------------ 1556 CHARACTER(LEN=LEN_TRIM(Name)) :: str 1557 INTEGER :: k 1558 LOGICAL :: Found 1559 TYPE(ValueListEntry_t), POINTER :: ptr, prev 1560!------------------------------------------------------------------------------ 1561 Prev => NULL() 1562 Found = .FALSE. 1563 1564 IF(.NOT.ASSOCIATED(List)) List => ListAllocate() 1565 New => ListEntryAllocate() 1566 1567 IF ( ASSOCIATED(List % Head) ) THEN 1568 k = StringToLowerCase( str,Name,.TRUE. ) 1569 ptr => List % Head 1570 NULLIFY( prev ) 1571 DO WHILE( ASSOCIATED(ptr) ) 1572 IF ( ptr % NameLen == k .AND. ptr % Name(1:k) == str(1:k) ) THEN 1573 Found = .TRUE. 1574 EXIT 1575 ELSE 1576 Prev => ptr 1577 ptr => ptr % Next 1578 END IF 1579 END DO 1580 1581 IF ( Found ) THEN 1582 New % Next => ptr % Next 1583 IF ( ASSOCIATED( prev ) ) THEN 1584 Prev % Next => New 1585 ELSE 1586 List % Head => New 1587 END IF 1588 CALL ListDelete( Ptr ) 1589 ELSE 1590 IF ( ASSOCIATED(prev) ) THEN 1591 prev % next => NEW 1592 ELSE 1593 NEW % Next => List % Head % Next 1594 List % Head % Next => NEW 1595 END IF 1596 END IF 1597 ELSE 1598 List % Head => NEW 1599 END IF 1600 1601#ifdef DEVEL_LISTCOUNTER 1602! IF( ASSOCIATED( new ) ) new % Counter = new % Counter + 1 1603#endif 1604 1605 1606!------------------------------------------------------------------------------ 1607 END FUNCTION ListAdd 1608!------------------------------------------------------------------------------ 1609 1610 1611!------------------------------------------------------------------------------ 1612!> Sets a namespace string that is used in all list get commands 1613!> to check for an entry with the namespace, and then continuing to check the one without. 1614!------------------------------------------------------------------------------ 1615 SUBROUTINE ListSetNamespace(str) 1616!------------------------------------------------------------------------------ 1617 CHARACTER(LEN=*) :: str 1618!------------------------------------------------------------------------------ 1619 CHARACTER(LEN=LEN_TRIM(str)) :: str_lcase 1620!------------------------------------------------------------------------------ 1621 INTEGER :: n 1622!------------------------------------------------------------------------------ 1623 1624 n = StringToLowerCase( str_lcase,str,.TRUE. ) 1625 1626 CALL Info('ListSetNamespace','Setting namespace to: '//TRIM(str_lcase),Level=15) 1627 1628 NameSpace = str_lcase 1629 1630!------------------------------------------------------------------------------ 1631 END SUBROUTINE ListSetNamespace 1632!------------------------------------------------------------------------------ 1633 1634!------------------------------------------------------------------------------ 1635!> Returns the active namespace. 1636!------------------------------------------------------------------------------ 1637 FUNCTION ListGetNamespace(str) RESULT(l) 1638!------------------------------------------------------------------------------ 1639 LOGICAL :: l 1640 CHARACTER(:), ALLOCATABLE :: str 1641!------------------------------------------------------------------------------ 1642 IF (ALLOCATED(Namespace)) THEN 1643 l = .TRUE. 1644 str = Namespace 1645 ELSE 1646 l = .FALSE. 1647 END IF 1648!------------------------------------------------------------------------------ 1649 END FUNCTION ListGetNamespace 1650!------------------------------------------------------------------------------ 1651 1652!------------------------------------------------------------------------------ 1653 SUBROUTINE ListPushNamespace(str) 1654!------------------------------------------------------------------------------ 1655 CHARACTER(LEN=*) :: str 1656!------------------------------------------------------------------------------ 1657 LOGICAL :: L 1658 CHARACTER(:), ALLOCATABLE :: tstr 1659 TYPE(String_stack_t), POINTER :: stack 1660!------------------------------------------------------------------------------ 1661 1662 CALL Info('ListPushNameSpace','Adding name space: '//TRIM(str),Level=12) 1663 1664 ALLOCATE(stack) 1665 L = ListGetNameSpace(tstr) 1666 IF(ALLOCATED(tstr)) THEN 1667 stack % name = tstr 1668 ELSE 1669 stack % name = '' 1670 END IF 1671 stack % next => Namespace_stack 1672 Namespace_stack => stack 1673 CALL ListSetNamespace(str) 1674!------------------------------------------------------------------------------ 1675 END SUBROUTINE ListPushNamespace 1676!------------------------------------------------------------------------------ 1677 1678!------------------------------------------------------------------------------ 1679 SUBROUTINE ListPopNamespace( str0 ) 1680!------------------------------------------------------------------------------ 1681 CHARACTER(LEN=*), OPTIONAL :: str0 1682 TYPE(String_stack_t), POINTER :: stack 1683 1684 1685 IF(ASSOCIATED(Namespace_stack)) THEN 1686 1687 ! This is an optional part aimed to help to code correctly the name stack. 1688 ! If one gives the namespace to be popped a Fatal will result if it is a 1689 ! wrong namespace. 1690 IF( PRESENT( str0 ) ) THEN 1691 IF( str0 /= Namespace ) THEN 1692 CALL Fatal('ListPopNamespace','Wrong namespace to pop: '& 1693 //TRIM(str0)//' vs '//TRIM(Namespace)) 1694 END IF 1695 END IF 1696 1697 Namespace = Namespace_stack % name 1698 1699 CALL Info('ListPopNameSpace','Deleting entry from name space: '& 1700 //TRIM(Namespace),Level=12) 1701 1702 stack => Namespace_stack 1703 Namespace_stack => stack % Next 1704 DEALLOCATE(stack) 1705 ELSE 1706 CALL Info('ListPopNameSpace','No namespace entry to delete',Level=20) 1707 END IF 1708!------------------------------------------------------------------------------ 1709 END SUBROUTINE ListPopNamespace 1710!------------------------------------------------------------------------------ 1711 1712!------------------------------------------------------------------------------ 1713 SUBROUTINE ListPushActivename(str) 1714!------------------------------------------------------------------------------ 1715 CHARACTER(LEN=*) :: str 1716!------------------------------------------------------------------------------ 1717 LOGICAL :: L 1718 TYPE(String_stack_t), POINTER :: stack 1719!------------------------------------------------------------------------------ 1720 ALLOCATE(stack) 1721 stack % name = ListGetActiveName() 1722 stack % next => Activename_stack 1723 Activename_stack => stack 1724 ActiveListName = str 1725!------------------------------------------------------------------------------ 1726 END SUBROUTINE ListPushActiveName 1727!------------------------------------------------------------------------------ 1728 1729!------------------------------------------------------------------------------ 1730 SUBROUTINE ListPopActiveName() 1731!------------------------------------------------------------------------------ 1732 TYPE(String_stack_t), POINTER :: stack 1733!------------------------------------------------------------------------------ 1734 IF(ASSOCIATED(Activename_stack)) THEN 1735 ActiveListName = Activename_stack % name 1736 stack => Activename_stack 1737 Activename_stack => stack % Next 1738 DEALLOCATE(stack) 1739 END IF 1740!------------------------------------------------------------------------------ 1741 END SUBROUTINE ListPopActiveName 1742!------------------------------------------------------------------------------ 1743 1744!------------------------------------------------------------------------------ 1745 FUNCTION ListGetActiveName() RESULT(str) 1746!------------------------------------------------------------------------------ 1747 CHARACTER(:), ALLOCATABLE :: str 1748!------------------------------------------------------------------------------ 1749 IF (ALLOCATED(ActiveListName)) THEN 1750 str = ActiveListName 1751 ELSE 1752 str = '' 1753 END IF 1754!------------------------------------------------------------------------------ 1755 END FUNCTION ListGetActiveName 1756!------------------------------------------------------------------------------ 1757 1758!------------------------------------------------------------------------------ 1759 SUBROUTINE SetNamespaceCheck(L) 1760!------------------------------------------------------------------------------ 1761 LOGICAL :: L 1762!------------------------------------------------------------------------------ 1763 DoNamespaceCheck = L 1764!------------------------------------------------------------------------------ 1765 END SUBROUTINE SetNamespaceCheck 1766!------------------------------------------------------------------------------ 1767 1768!------------------------------------------------------------------------------ 1769 FUNCTION GetNamespaceCheck() RESULT(L) 1770!------------------------------------------------------------------------------ 1771 LOGICAL :: L 1772!------------------------------------------------------------------------------ 1773 L = DoNameSpaceCheck 1774!------------------------------------------------------------------------------ 1775 END FUNCTION GetNamespaceCheck 1776!------------------------------------------------------------------------------ 1777 1778!------------------------------------------------------------------------------ 1779!> Finds an entry in the list by its name and returns a handle to it. 1780!------------------------------------------------------------------------------ 1781 FUNCTION ListFind( list, name, Found ) RESULT(ptr) 1782!------------------------------------------------------------------------------ 1783 TYPE(ValueListEntry_t), POINTER :: ptr 1784 TYPE(ValueList_t), POINTER :: List 1785 CHARACTER(LEN=*) :: name 1786 LOGICAL, OPTIONAL :: Found 1787!------------------------------------------------------------------------------ 1788 TYPE(String_stack_t), POINTER :: stack 1789#ifdef HAVE_LUA 1790 CHARACTER(:), ALLOCATABLE :: stra 1791#endif 1792 CHARACTER(:), ALLOCATABLE :: strn 1793 CHARACTER(LEN=LEN_TRIM(Name)) :: str 1794!------------------------------------------------------------------------------ 1795 INTEGER :: k, k1, n 1796 1797 IF(PRESENT(Found)) Found = .FALSE. 1798 ptr => NULL() 1799 IF(.NOT.ASSOCIATED(List)) RETURN 1800 1801 k = StringToLowerCase( str,Name,.TRUE. ) 1802 1803 IF( ListGetnamespace(strn) ) THEN 1804 stack => Namespace_stack 1805 DO WHILE(.TRUE.) 1806#ifdef HAVE_LUA 1807 stra = trim(strn) 1808 strn = stra //' '//str(1:k) 1809 DEALLOCATE(stra) 1810#else 1811 strn = trim(strn) // ' ' //str(1:k) 1812#endif 1813 k1 = LEN(strn) 1814 ptr => List % Head 1815 DO WHILE( ASSOCIATED(ptr) ) 1816 n = ptr % NameLen 1817 IF ( n==k1 ) THEN 1818 IF ( ptr % Name(1:n) == strn ) EXIT 1819 END IF 1820 ptr => ptr % Next 1821 END DO 1822 IF(.NOT.DoNamespaceCheck) EXIT 1823 1824 IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT 1825 IF(stack % name=='') EXIT 1826 strn = char(stack % name) 1827 stack => stack % next 1828 END DO 1829 END IF 1830 1831 IF ( .NOT. ASSOCIATED(ptr) ) THEN 1832 Ptr => List % Head 1833 DO WHILE( ASSOCIATED(ptr) ) 1834 n = ptr % NameLen 1835 IF ( n==k ) THEN 1836 IF ( ptr % Name(1:n) == str(1:n) ) EXIT 1837 END IF 1838 ptr => ptr % Next 1839 END DO 1840 END IF 1841 1842#ifdef DEVEL_LISTCOUNTER 1843 IF( ASSOCIATED( ptr ) ) THEN 1844 ptr % Counter = ptr % Counter + 1 1845 !ELSE IF( INDEX( name,': not found' ) == 0 ) THEN 1846 !CALL ListAddNewLogical( CurrentModel % Simulation, TRIM(name)//': not found',.TRUE.) 1847 END IF 1848#endif 1849 1850 IF ( PRESENT(Found) ) THEN 1851 Found = ASSOCIATED(ptr) 1852 ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN 1853 CALL Warn( 'ListFind', ' ' ) 1854 WRITE(Message,*) 'Requested property: ', '[',TRIM(Name),'], not found' 1855 CALL Warn( 'ListFind', Message ) 1856 CALL Warn( 'ListFind', ' ' ) 1857 END IF 1858!------------------------------------------------------------------------------ 1859 END FUNCTION ListFind 1860!------------------------------------------------------------------------------ 1861 1862 1863!------------------------------------------------------------------------------ 1864!> Finds an entry in the list by its name and returns a handle to it. 1865!------------------------------------------------------------------------------ 1866 SUBROUTINE ListRename( list, name, name2, Found ) 1867!------------------------------------------------------------------------------ 1868 TYPE(ValueList_t), POINTER :: List 1869 CHARACTER(LEN=*) :: name, name2 1870 LOGICAL, OPTIONAL :: Found 1871!------------------------------------------------------------------------------ 1872 TYPE(ValueListEntry_t), POINTER :: ptr 1873 CHARACTER(:), ALLOCATABLE :: strn 1874 CHARACTER(LEN=LEN_TRIM(Name)) :: str 1875 CHARACTER(LEN=LEN_TRIM(Name2)) :: str2 1876 INTEGER :: k, k2, n 1877 1878 IF(PRESENT(Found)) Found = .FALSE. 1879 1880 ptr => NULL() 1881 IF(.NOT.ASSOCIATED(List)) RETURN 1882 1883 k = StringToLowerCase( str,Name,.TRUE. ) 1884 1885 Ptr => List % Head 1886 DO WHILE( ASSOCIATED(ptr) ) 1887 n = ptr % NameLen 1888 IF ( n==k ) THEN 1889 IF ( ptr % Name(1:n) == str(1:n) ) EXIT 1890 END IF 1891 ptr => ptr % Next 1892 END DO 1893 1894 IF( ASSOCIATED( ptr ) ) THEN 1895 k2 = StringToLowerCase( str2,Name2,.TRUE. ) 1896 ptr % Name(1:k2) = str2(1:k2) 1897 ptr % NameLen = k2 1898 !PRINT *,'renaming >'//str(1:k)//'< to >'//str2(1:k2)//'<', k, k2 1899 END IF 1900 1901 IF ( PRESENT(Found) ) THEN 1902 Found = ASSOCIATED(ptr) 1903 ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN 1904 CALL Warn( 'ListRename', ' ' ) 1905 WRITE(Message,*) 'Requested property: ', '[',TRIM(Name),'], not found' 1906 CALL Warn( 'ListRename', Message ) 1907 CALL Warn( 'ListRename', ' ' ) 1908 END IF 1909!------------------------------------------------------------------------------ 1910 END SUBROUTINE ListRename 1911!------------------------------------------------------------------------------ 1912 1913 1914!------------------------------------------------------------------------------ 1915!> Rename all given keywords in BC section. 1916!------------------------------------------------------------------------------ 1917 SUBROUTINE ListRenameAllBC( Model, Name, Name2 ) 1918!------------------------------------------------------------------------------ 1919 TYPE(Model_t) :: Model 1920 CHARACTER(LEN=*) :: Name, Name2 1921 LOGICAL :: Found 1922 INTEGER :: bc, n 1923 1924 n = 0 1925 DO bc = 1,Model % NumberOfBCs 1926 CALL ListRename( Model % BCs(bc) % Values, Name, Name2, Found ) 1927 IF( Found ) n = n + 1 1928 END DO 1929 IF( n > 0 ) CALL Info('ListRenameAllBCs',& 1930 TRIM(Name)//' ranamed to '//TRIM(Name2)//' on '//TRIM(I2S(n))//' BCs',Level=6) 1931 1932!------------------------------------------------------------------------------ 1933 END SUBROUTINE ListRenameAllBC 1934!------------------------------------------------------------------------------ 1935 1936 1937 1938 1939!----------------------------------------------------------------------------- 1940!> Finds an entry in the list by its name and returns a handle to it. 1941!> This one just finds a keyword with the same start as specified by 'name'. 1942!------------------------------------------------------------------------------ 1943 FUNCTION ListFindPrefix( list, name, Found) RESULT(ptr) 1944!------------------------------------------------------------------------------ 1945 TYPE(ValueListEntry_t), POINTER :: ptr 1946 TYPE(ValueList_t), POINTER :: list 1947 CHARACTER(LEN=*) :: name 1948 LOGICAL, OPTIONAL :: Found 1949!------------------------------------------------------------------------------ 1950 TYPE(String_stack_t), POINTER :: stack 1951#ifdef HAVE_LUA 1952 CHARACTER(:), ALLOCATABLE :: stra 1953#endif 1954 CHARACTER(:), ALLOCATABLE :: strn 1955 CHARACTER(LEN=LEN_TRIM(Name)) :: str 1956!------------------------------------------------------------------------------ 1957 INTEGER :: k, k1, n, m 1958 1959 ptr => NULL() 1960 IF(.NOT.ASSOCIATED(List)) RETURN 1961 1962 k = StringToLowerCase( str,Name,.TRUE. ) 1963 IF ( ListGetNamespace(strn) ) THEN 1964 stack => Namespace_stack 1965 DO WHILE(.TRUE.) 1966#ifdef HAVE_LUA 1967 stra = trim(strn) 1968 strn = stra //' '//str(1:k) 1969 DEALLOCATE(stra) 1970#else 1971 strn = trim(strn) // ' ' //str(1:k) 1972#endif 1973 k1 = LEN(strn) 1974 ptr => List % Head 1975 DO WHILE( ASSOCIATED(ptr) ) 1976 n = ptr % NameLen 1977 IF ( n >= k1 ) THEN 1978 IF ( ptr % Name(1:k1) == strn ) EXIT 1979 END IF 1980 ptr => ptr % Next 1981 END DO 1982 IF(.NOT.DoNamespaceCheck) EXIT 1983 1984 IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT 1985 IF(stack % name=='') EXIT 1986 strn = char(stack % name) 1987 stack => stack % next 1988 END DO 1989 END IF 1990 1991 IF ( .NOT. ASSOCIATED(ptr) ) THEN 1992 Ptr => List % Head 1993 DO WHILE( ASSOCIATED(ptr) ) 1994 n = ptr % NameLen 1995 IF ( n >= k ) THEN 1996 IF ( ptr % Name(1:k) == str(1:k) ) EXIT 1997 END IF 1998 ptr => ptr % Next 1999 END DO 2000 END IF 2001 2002 IF ( PRESENT(Found) ) THEN 2003 Found = ASSOCIATED(ptr) 2004 ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN 2005 CALL Warn( 'ListFindPrefix', ' ' ) 2006 WRITE(Message,*) 'Requested prefix: ', '[',TRIM(Name),'], not found' 2007 CALL Warn( 'ListFindPrefix', Message ) 2008 CALL Warn( 'ListFindPrefix', ' ' ) 2009 END IF 2010!------------------------------------------------------------------------------ 2011 END FUNCTION ListFindPrefix 2012!------------------------------------------------------------------------------ 2013 2014 2015!------------------------------------------------------------------------------ 2016!> Finds an entry in the list by its name and returns a handle to it. 2017!> This one just finds a keyword with the same end as specified by 'name'. 2018!------------------------------------------------------------------------------ 2019 FUNCTION ListFindSuffix( list, name, Found) RESULT(ptr) 2020!------------------------------------------------------------------------------ 2021 TYPE(ValueListEntry_t), POINTER :: ptr 2022 TYPE(ValueList_t), POINTER :: list 2023 CHARACTER(LEN=*) :: name 2024 LOGICAL, OPTIONAL :: Found 2025!------------------------------------------------------------------------------ 2026 CHARACTER(LEN=LEN_TRIM(Name)) :: str 2027!------------------------------------------------------------------------------ 2028 INTEGER :: k, k1, n, m 2029 2030 ptr => Null() 2031 IF(.NOT.ASSOCIATED(List)) RETURN 2032 2033 k = StringToLowerCase( str,Name,.TRUE. ) 2034 Ptr => List % Head 2035 DO WHILE( ASSOCIATED(ptr) ) 2036 n = ptr % NameLen 2037 IF ( n >= k ) THEN 2038 IF ( ptr % Name(n-k+1:n) == str(1:k) ) EXIT 2039 END IF 2040 ptr => ptr % Next 2041 END DO 2042 2043 IF ( PRESENT(Found) ) THEN 2044 Found = ASSOCIATED(ptr) 2045 ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN 2046 CALL Warn( 'ListFindSuffix', ' ' ) 2047 WRITE(Message,*) 'Requested suffix: ', '[',TRIM(Name),'], not found' 2048 CALL Warn( 'ListFindSuffix', Message ) 2049 CALL Warn( 'ListFindSuffix', ' ' ) 2050 END IF 2051!------------------------------------------------------------------------------ 2052 END FUNCTION ListFindSuffix 2053!------------------------------------------------------------------------------ 2054 2055 2056 2057!------------------------------------------------------------------------------ 2058!> Check if the suffix exists in the list. 2059!------------------------------------------------------------------------------ 2060 FUNCTION ListCheckSuffix( List, Name ) RESULT(Found) 2061!------------------------------------------------------------------------------ 2062 TYPE(ValueList_t), POINTER :: List 2063 CHARACTER(LEN=*) :: Name 2064 LOGICAL :: Found 2065 TYPE(ValuelistEntry_t), POINTER :: ptr 2066 2067 ptr => ListFindSuffix( List, Name, Found ) 2068!------------------------------------------------------------------------------ 2069 END FUNCTION ListCheckSuffix 2070!------------------------------------------------------------------------------ 2071 2072 2073 2074!------------------------------------------------------------------------------ 2075!> Check if the keyword is with the given suffix is present in any boundary condition. 2076!------------------------------------------------------------------------------ 2077 FUNCTION ListCheckSuffixAnyBC( Model, Name ) RESULT(Found) 2078!------------------------------------------------------------------------------ 2079 TYPE(Model_t) :: Model 2080 CHARACTER(LEN=*) :: Name 2081 LOGICAL :: Found 2082 INTEGER :: bc 2083 TYPE(ValuelistEntry_t), POINTER :: ptr 2084 2085 Found = .FALSE. 2086 DO bc = 1,Model % NumberOfBCs 2087 ptr => ListFindSuffix( Model % BCs(bc) % Values, Name, Found ) 2088 IF( Found ) EXIT 2089 END DO 2090!------------------------------------------------------------------------------ 2091 END FUNCTION ListCheckSuffixAnyBC 2092!------------------------------------------------------------------------------ 2093 2094!------------------------------------------------------------------------------ 2095!> Check if the keyword is with the given suffix is present in any body. 2096!------------------------------------------------------------------------------ 2097 FUNCTION ListCheckSuffixAnyBody( Model, Name ) RESULT(Found) 2098!------------------------------------------------------------------------------ 2099 TYPE(Model_t) :: Model 2100 CHARACTER(LEN=*) :: Name 2101 LOGICAL :: Found 2102 INTEGER :: body_id 2103 TYPE(ValuelistEntry_t), POINTER :: ptr 2104 2105 Found = .FALSE. 2106 DO body_id = 1,Model % NumberOfBodies 2107 ptr => ListFindSuffix( Model % Bodies(body_id) % Values, Name, Found ) 2108 IF( Found ) EXIT 2109 END DO 2110!------------------------------------------------------------------------------ 2111 END FUNCTION ListCheckSuffixAnyBody 2112!------------------------------------------------------------------------------ 2113 2114!------------------------------------------------------------------------------ 2115!> Check if the keyword is with the given suffix is present in any material. 2116!------------------------------------------------------------------------------ 2117 FUNCTION ListCheckSuffixAnyMaterial( Model, Name ) RESULT(Found) 2118!------------------------------------------------------------------------------ 2119 TYPE(Model_t) :: Model 2120 CHARACTER(LEN=*) :: Name 2121 LOGICAL :: Found 2122 INTEGER :: mat_id 2123 TYPE(ValuelistEntry_t), POINTER :: ptr 2124 2125 Found = .FALSE. 2126 DO mat_id = 1,Model % NumberOfMaterials 2127 ptr => ListFindSuffix( Model % Materials(mat_id) % Values, Name, Found ) 2128 IF( Found ) EXIT 2129 END DO 2130!------------------------------------------------------------------------------ 2131 END FUNCTION ListCheckSuffixAnyMaterial 2132!------------------------------------------------------------------------------ 2133 2134!------------------------------------------------------------------------------ 2135!> Check if the keyword is with the given suffix is present in any body force. 2136!------------------------------------------------------------------------------ 2137 FUNCTION ListCheckSuffixAnyBodyForce( Model, Name ) RESULT(Found) 2138!------------------------------------------------------------------------------ 2139 TYPE(Model_t) :: Model 2140 CHARACTER(LEN=*) :: Name 2141 LOGICAL :: Found 2142 INTEGER :: bf_id 2143 TYPE(ValuelistEntry_t), POINTER :: ptr 2144 2145 Found = .FALSE. 2146 DO bf_id = 1,Model % NumberOfBodyForces 2147 ptr => ListFindSuffix( Model % BodyForces(bf_id) % Values, Name, Found ) 2148 IF( Found ) EXIT 2149 END DO 2150!------------------------------------------------------------------------------ 2151 END FUNCTION ListCheckSuffixAnyBodyForce 2152!------------------------------------------------------------------------------ 2153 2154!------------------------------------------------------------------------------ 2155!> Finds an entry related to vector keyword of type "name" or "name i", i=1,2,3. 2156!> This could save time since it will detect at one sweep whether the keyword 2157!> for a vector is given, and whether it is componentwise or not. 2158!> There is a caveat since currently the "i" is not checked and possibly 2159!> the user could mix the formats and the chosen one would be random. 2160!------------------------------------------------------------------------------ 2161 FUNCTION ListFindVectorPrefix( list, name, ComponentWise,Found ) RESULT(ptr) 2162!------------------------------------------------------------------------------ 2163 TYPE(ValueListEntry_t), POINTER :: ptr 2164 TYPE(ValueList_t), POINTER :: list 2165 CHARACTER(LEN=*) :: name 2166 LOGICAL :: ComponentWise 2167 LOGICAL, OPTIONAL :: Found 2168!------------------------------------------------------------------------------ 2169 TYPE(String_stack_t), POINTER :: stack 2170 CHARACTER(:), ALLOCATABLE :: strn 2171 CHARACTER(LEN=LEN_TRIM(Name)) :: str 2172!------------------------------------------------------------------------------ 2173 INTEGER :: k, k1, n, m 2174 2175 ptr => NULL() 2176 IF(.NOT.ASSOCIATED(List)) RETURN 2177 2178 k = StringToLowerCase( str,Name,.TRUE. ) 2179 2180 IF ( ListGetNamespace(strn) ) THEN 2181 stack => Namespace_stack 2182 DO WHILE(.TRUE.) 2183 strn = TRIM(strn) //' '//str(1:k) 2184 k1 = LEN(strn) 2185 ptr => List % Head 2186 DO WHILE( ASSOCIATED(ptr) ) 2187 n = ptr % NameLen 2188 IF ( n == k1 ) THEN 2189 IF ( ptr % Name(1:k1) == strn ) THEN 2190 ComponentWise = .FALSE. 2191 EXIT 2192 END IF 2193 ELSE IF( n == k1 + 2 ) THEN 2194 IF ( ptr % Name(1:k1+1) == strn//' ' ) THEN 2195 ComponentWise = .TRUE. 2196 EXIT 2197 END IF 2198 END IF 2199 ptr => ptr % Next 2200 END DO 2201 IF(.NOT.DoNamespaceCheck) EXIT 2202 2203 IF(ASSOCIATED(ptr).OR..NOT.ASSOCIATED(stack)) EXIT 2204 IF(stack % name=='') EXIT 2205 strn = char(stack % name) 2206 stack => stack % next 2207 END DO 2208 END IF 2209 2210 IF ( .NOT. ASSOCIATED(ptr) ) THEN 2211 Ptr => List % Head 2212 DO WHILE( ASSOCIATED(ptr) ) 2213 n = ptr % NameLen 2214 IF ( n == k ) THEN 2215 IF ( ptr % Name(1:k) == str(1:k) ) THEN 2216 ComponentWise = .FALSE. 2217 EXIT 2218 END IF 2219 ELSE IF( n == k + 2 ) THEN 2220 IF ( ptr % Name(1:k+1) == str(1:k)//' ' ) THEN 2221 ComponentWise = .TRUE. 2222 EXIT 2223 END IF 2224 END IF 2225 ptr => ptr % Next 2226 END DO 2227 END IF 2228 2229 IF ( PRESENT(Found) ) THEN 2230 Found = ASSOCIATED(ptr) 2231 ELSE IF (.NOT.ASSOCIATED(ptr) ) THEN 2232 CALL Warn( 'ListFindVectorPrefix', ' ' ) 2233 WRITE(Message,*) 'Requested vector prefix: ', '[',TRIM(Name),'], not found' 2234 CALL Warn( 'ListFindVectorPrefix', Message ) 2235 CALL Warn( 'ListFindVectorPrefix', ' ' ) 2236 END IF 2237!------------------------------------------------------------------------------ 2238 END FUNCTION ListFindVectorPrefix 2239!------------------------------------------------------------------------------ 2240 2241 2242 2243!------------------------------------------------------------------------------ 2244!> Finds a keyword with the given basename and normalizes it with a 2245!> constant coefficients for all future request of the keyword. 2246!------------------------------------------------------------------------------ 2247 SUBROUTINE ListSetCoefficients( list, name, coeff ) 2248!------------------------------------------------------------------------------ 2249 TYPE(ValueList_t), POINTER :: list 2250 CHARACTER(LEN=*) :: name 2251 REAL(KIND=dp) :: coeff 2252!------------------------------------------------------------------------------ 2253 TYPE(ValueListEntry_t), POINTER :: ptr, ptr2 2254 CHARACTER(LEN=LEN_TRIM(Name)) :: str 2255 INTEGER :: k, k1, n, n2, m 2256 2257 IF(.NOT.ASSOCIATED(List)) RETURN 2258 2259 k = StringToLowerCase( str,Name,.TRUE. ) 2260 2261 Ptr => list % Head 2262 DO WHILE( ASSOCIATED(ptr) ) 2263 n = ptr % NameLen 2264 IF ( n >= k ) THEN 2265 ! Did we find a keyword which has the correct suffix? 2266 IF ( ptr % Name(n-k+1:n) == str(1:k) ) THEN 2267 Ptr2 => list % Head 2268 DO WHILE( ASSOCIATED(ptr2) ) 2269 n2 = ptr2 % NameLen 2270 IF( n2 + k <= n ) THEN 2271 2272 ! Did we find the corresponding keyword without the suffix? 2273 IF ( ptr2 % Name(1:n2) == ptr % Name(1:n2) ) THEN 2274 WRITE( Message,'(A,ES12.5)') 'Normalizing > '//& 2275 TRIM( ptr2 % Name )// ' < by ',Coeff 2276 CALL Info('ListSetCoefficients',Message) 2277 ptr2 % Coeff = Coeff 2278 EXIT 2279 END IF 2280 2281 END IF 2282 ptr2 => ptr2 % Next 2283 END DO 2284 END IF 2285 END IF 2286 ptr => ptr % Next 2287 END DO 2288 2289 END SUBROUTINE ListSetCoefficients 2290 2291 2292 2293!> Copies an entry from 'ptr' to an entry in *different* list with the same content. 2294!----------------------------------------------------------------------------------- 2295 SUBROUTINE ListCopyItem( ptr, list, name ) 2296 2297 TYPE(ValueListEntry_t), POINTER :: ptr 2298 TYPE(ValueList_t), POINTER :: list 2299 CHARACTER(LEN=*), OPTIONAL :: name 2300!------------------------------------------------------------------------------ 2301 INTEGER :: i,j,k 2302 TYPE(ValueListEntry_t), POINTER :: ptrb, ptrnext 2303 2304 IF( PRESENT( name ) ) THEN 2305 ptrb => ListAdd( List, name ) 2306 ELSE 2307 ptrb => ListAdd( List, ptr % Name ) 2308 END IF 2309 2310 2311 ptrnext => ptrb % next 2312 ptrb = ptr 2313 2314 ptrb % tvalues => null() 2315 if(associated(ptr % tvalues)) then 2316 allocate( ptrb % tvalues(size(ptr % tvalues)) ) 2317 ptrb % tvalues = ptr % tvalues 2318 end if 2319 2320 ptrb % fvalues => null() 2321 if(associated(ptr % fvalues)) then 2322 i = size(ptr % fvalues,1) 2323 j = size(ptr % fvalues,2) 2324 k = size(ptr % fvalues,3) 2325 allocate( ptrb % fvalues(i,j,k) ) 2326 ptrb % fvalues = ptr % fvalues 2327 end if 2328 2329 ptrb % ivalues => null() 2330 if(associated(ptr % ivalues)) then 2331 allocate( ptrb % ivalues(size(ptr % ivalues)) ) 2332 ptrb % ivalues = ptr % ivalues 2333 end if 2334 2335 ptrb % cumulative => null() 2336 if(associated(ptr % cumulative)) then 2337 allocate( ptrb % cumulative(size(ptr % cumulative)) ) 2338 ptrb % cumulative = ptr % cumulative 2339 end if 2340 ptrb % next => ptrnext 2341 2342 ! If name is given then we have to revert the stuff from previous lines 2343 IF( PRESENT( name ) ) THEN 2344 ptrb % Name = name 2345 ptrb % Namelen = lentrim( name ) 2346 END IF 2347 2348 END SUBROUTINE ListCopyItem 2349 2350 2351!> Checks two lists for a given keyword. If it is given then 2352!> copy it as it is to the 2nd list. 2353!------------------------------------------------------------------------------ 2354 SUBROUTINE ListCompareAndCopy( list, listb, name, Found ) 2355!------------------------------------------------------------------------------ 2356 TYPE(ValueList_t), POINTER :: list, listb 2357 CHARACTER(LEN=*) :: name 2358 LOGICAL :: Found 2359!------------------------------------------------------------------------------ 2360 TYPE(ValueListEntry_t), POINTER :: ptr 2361 CHARACTER(LEN=LEN_TRIM(Name)) :: str 2362 INTEGER :: k, n 2363 2364 k = StringToLowerCase( str,Name,.TRUE. ) 2365 Found = .FALSE. 2366 2367 ! Find the keyword from the 1st list 2368 Ptr => List % Head 2369 DO WHILE( ASSOCIATED(ptr) ) 2370 n = ptr % NameLen 2371 IF ( n==k ) THEN 2372 IF ( ptr % Name(1:n) == str(1:n) ) EXIT 2373 END IF 2374 ptr => ptr % Next 2375 END DO 2376 2377 IF(.NOT. ASSOCIATED( ptr ) ) RETURN 2378 2379 ! Add the same entry to the 2nd list 2380 CALL ListCopyItem( ptr, listb ) 2381 Found = .TRUE. 2382 2383 END SUBROUTINE ListCompareAndCopy 2384 2385 2386!> Goes through one list and checks whether it includes any keywords with give prefix. 2387!> All keywords found are copied to the 2nd list without the prefix. 2388!------------------------------------------------------------------------------ 2389 SUBROUTINE ListCopyPrefixedKeywords( list, listb, prefix ) 2390!------------------------------------------------------------------------------ 2391 TYPE(ValueList_t), POINTER :: list, listb 2392 CHARACTER(LEN=*) :: prefix 2393!------------------------------------------------------------------------------ 2394 TYPE(ValueListEntry_t), POINTER :: ptr 2395 CHARACTER(LEN=LEN_TRIM(prefix)) :: str 2396 INTEGER :: k, l, n, ncopy 2397 2398 k = StringToLowerCase( str,prefix,.TRUE. ) 2399 ncopy = 0 2400 2401 ! Find the keyword from the 1st list 2402 Ptr => List % Head 2403 DO WHILE( ASSOCIATED(ptr) ) 2404 n = ptr % NameLen 2405 IF( n > k ) THEN 2406 IF( ptr % Name(1:k) == str(1:k) ) THEN 2407 l = k+1 2408 ! Remove the extra blanco after prefix if present 2409 ! Here we just assume one possible blanco as that is most often the case 2410 IF( ptr % Name(l:l) == ' ') l = l+1 2411 CALL Info('ListCopyPrefixedKeywords',& 2412 'Prefix: '//TRIM(prefix)// ' Keyword: '//TRIM(ptr % Name(l:n)),Level=12) 2413 CALL ListCopyItem( ptr, listb, ptr % Name(l:n) ) 2414 ncopy = ncopy + 1 2415 END IF 2416 END IF 2417 ptr => ptr % Next 2418 END DO 2419 2420 IF( ncopy > 0 ) THEN 2421 CALL Info('ListCopyPrefixedKeywords',& 2422 'Copied '//TRIM(I2S(ncopy))//' keywords with prefix: '//TRIM(prefix),Level=6) 2423 END IF 2424 2425 END SUBROUTINE ListCopyPrefixedKeywords 2426 2427 2428!> Goes through one list and copies all keywords to a second list. 2429!------------------------------------------------------------------------------ 2430 SUBROUTINE ListCopyAllKeywords( list, listb ) 2431!------------------------------------------------------------------------------ 2432 TYPE(ValueList_t), POINTER :: list, listb 2433!------------------------------------------------------------------------------ 2434 TYPE(ValueListEntry_t), POINTER :: ptr 2435 INTEGER :: ncopy 2436 2437 ncopy = 0 2438 2439 ! Find the keyword from the 1st list 2440 Ptr => List % Head 2441 DO WHILE( ASSOCIATED(ptr) ) 2442 CALL ListCopyItem( ptr, listb, ptr % Name ) 2443 ncopy = ncopy + 1 2444 ptr => ptr % Next 2445 END DO 2446 2447 IF( ncopy > 0 ) THEN 2448 CALL Info('ListCopyAllKeywords',& 2449 'Copied '//TRIM(I2S(ncopy))//' keywords to new list',Level=6) 2450 END IF 2451 2452 END SUBROUTINE ListCopyAllKeywords 2453 2454 2455!------------------------------------------------------------------------------ 2456!> Just checks if a entry is present in the list. 2457!------------------------------------------------------------------------------ 2458 FUNCTION ListCheckPresent( List,Name ) RESULT(Found) 2459!------------------------------------------------------------------------------ 2460 TYPE(ValueList_t), POINTER :: List 2461 CHARACTER(LEN=*) :: Name 2462 LOGICAL :: Found 2463!------------------------------------------------------------------------------ 2464 TYPE(ValueListEntry_t), POINTER :: ptr 2465!------------------------------------------------------------------------------ 2466 ptr => ListFind(List,Name,Found) 2467!------------------------------------------------------------------------------ 2468 END FUNCTION ListCheckPresent 2469!------------------------------------------------------------------------------ 2470 2471 2472!------------------------------------------------------------------------------ 2473!> Just checks if there is a untreated keyword in the routine in the list. 2474!> In case there is return a warning. 2475!------------------------------------------------------------------------------ 2476 SUBROUTINE ListUntreatedWarn( List, Name, Caller ) 2477!------------------------------------------------------------------------------ 2478 TYPE(ValueList_t), POINTER :: List 2479 CHARACTER(LEN=*) :: Name 2480 CHARACTER(LEN=*), OPTIONAL :: Caller 2481!------------------------------------------------------------------------------ 2482 IF( ListCheckPresent( List, Name ) ) THEN 2483 IF( PRESENT( Caller ) ) THEN 2484 CALL Warn(Caller,'Untreated keyword may cause problems: '//TRIM(Name)) 2485 ELSE 2486 CALL Warn('ListUntreatedWarn','Untreated keyword may cause problems: '//TRIM(Name)) 2487 END IF 2488 END IF 2489!------------------------------------------------------------------------------ 2490 END SUBROUTINE ListUntreatedWarn 2491!------------------------------------------------------------------------------ 2492 2493!------------------------------------------------------------------------------ 2494!> Just checks if there is a untreated keyword in the routine in the list. 2495!> In case there is return a Fatal. 2496!------------------------------------------------------------------------------ 2497 SUBROUTINE ListUntreatedFatal( List, Name, Caller ) 2498!------------------------------------------------------------------------------ 2499 TYPE(ValueList_t), POINTER :: List 2500 CHARACTER(LEN=*) :: Name 2501 CHARACTER(LEN=*), OPTIONAL :: Caller 2502!------------------------------------------------------------------------------ 2503 IF( ListCheckPresent( List, Name ) ) THEN 2504 IF( PRESENT( Caller ) ) THEN 2505 CALL Fatal(Caller,'Untreated keyword: '//TRIM(Name)) 2506 ELSE 2507 CALL Fatal('ListUntreatedFatal','Untreated keyword: '//TRIM(Name)) 2508 END IF 2509 END IF 2510!------------------------------------------------------------------------------ 2511 END SUBROUTINE ListUntreatedFatal 2512!------------------------------------------------------------------------------ 2513 2514!------------------------------------------------------------------------------ 2515!> Just checks if a prefix is present in the list. 2516!------------------------------------------------------------------------------ 2517 FUNCTION ListCheckPrefix( List,Name ) RESULT(Found) 2518!------------------------------------------------------------------------------ 2519 TYPE(ValueList_t), POINTER :: List 2520 CHARACTER(LEN=*) :: Name 2521 LOGICAL :: Found 2522!------------------------------------------------------------------------------ 2523 TYPE(ValueListEntry_t), POINTER :: ptr 2524!------------------------------------------------------------------------------ 2525 ptr => ListFindPrefix(List,Name,Found) 2526!------------------------------------------------------------------------------ 2527 END FUNCTION ListCheckPrefix 2528!------------------------------------------------------------------------------ 2529 2530!------------------------------------------------------------------------------ 2531!> Check if the keyword is with the given prefix is present in any boundary condition. 2532!------------------------------------------------------------------------------ 2533 FUNCTION ListCheckPrefixAnyBC( Model, Name ) RESULT(Found) 2534!------------------------------------------------------------------------------ 2535 TYPE(Model_t) :: Model 2536 CHARACTER(LEN=*) :: Name 2537 LOGICAL :: Found 2538 INTEGER :: bc 2539 TYPE(ValuelistEntry_t), POINTER :: ptr 2540 2541 Found = .FALSE. 2542 DO bc = 1,Model % NumberOfBCs 2543 ptr => ListFindPrefix( Model % BCs(bc) % Values, Name, Found ) 2544 IF( Found ) EXIT 2545 END DO 2546!------------------------------------------------------------------------------ 2547 END FUNCTION ListCheckPrefixAnyBC 2548!------------------------------------------------------------------------------ 2549 2550!------------------------------------------------------------------------------ 2551!> Check if the keyword is with the given prefix is present in any body. 2552!------------------------------------------------------------------------------ 2553 FUNCTION ListCheckPrefixAnyBody( Model, Name ) RESULT(Found) 2554!------------------------------------------------------------------------------ 2555 TYPE(Model_t) :: Model 2556 CHARACTER(LEN=*) :: Name 2557 LOGICAL :: Found 2558 INTEGER :: body_id 2559 TYPE(ValuelistEntry_t), POINTER :: ptr 2560 2561 Found = .FALSE. 2562 DO body_id = 1,Model % NumberOfBodies 2563 ptr => ListFindPrefix( Model % Bodies(body_id) % Values, Name, Found ) 2564 IF( Found ) EXIT 2565 END DO 2566!------------------------------------------------------------------------------ 2567 END FUNCTION ListCheckPrefixAnyBody 2568!------------------------------------------------------------------------------ 2569 2570!------------------------------------------------------------------------------ 2571!> Check if the keyword is with the given prefix is present in any material. 2572!------------------------------------------------------------------------------ 2573 FUNCTION ListCheckPrefixAnyMaterial( Model, Name ) RESULT(Found) 2574!------------------------------------------------------------------------------ 2575 TYPE(Model_t) :: Model 2576 CHARACTER(LEN=*) :: Name 2577 LOGICAL :: Found 2578 INTEGER :: mat_id 2579 TYPE(ValuelistEntry_t), POINTER :: ptr 2580 2581 Found = .FALSE. 2582 DO mat_id = 1,Model % NumberOfMaterials 2583 ptr => ListFindPrefix( Model % Materials(mat_id) % Values, Name, Found ) 2584 IF( Found ) EXIT 2585 END DO 2586!------------------------------------------------------------------------------ 2587 END FUNCTION ListCheckPrefixAnyMaterial 2588!------------------------------------------------------------------------------ 2589 2590!------------------------------------------------------------------------------ 2591!> Check if the keyword is with the given prefix is present in any body force. 2592!------------------------------------------------------------------------------ 2593 FUNCTION ListCheckPrefixAnyBodyForce( Model, Name ) RESULT(Found) 2594!------------------------------------------------------------------------------ 2595 TYPE(Model_t) :: Model 2596 CHARACTER(LEN=*) :: Name 2597 LOGICAL :: Found 2598 INTEGER :: bf_id 2599 TYPE(ValuelistEntry_t), POINTER :: ptr 2600 2601 Found = .FALSE. 2602 DO bf_id = 1,Model % NumberOfBodyForces 2603 ptr => ListFindPrefix( Model % BodyForces(bf_id) % Values, Name, Found ) 2604 IF( Found ) EXIT 2605 END DO 2606!------------------------------------------------------------------------------ 2607 END FUNCTION ListCheckPrefixAnyBodyForce 2608!------------------------------------------------------------------------------ 2609 2610 2611 2612!------------------------------------------------------------------------------ 2613!> Adds a string to the list. 2614!------------------------------------------------------------------------------ 2615 SUBROUTINE ListAddString( List,Name,CValue,CaseConversion ) 2616!------------------------------------------------------------------------------ 2617 TYPE(ValueList_t), POINTER :: List 2618 CHARACTER(LEN=*) :: Name 2619 CHARACTER(LEN=*) :: CValue 2620 LOGICAL, OPTIONAL :: CaseConversion 2621!------------------------------------------------------------------------------ 2622 INTEGER :: k 2623 LOGICAL :: DoCase 2624 TYPE(ValueListEntry_t), POINTER :: ptr 2625!------------------------------------------------------------------------------ 2626 ptr => ListAdd( List, Name ) 2627 2628 DoCase = .TRUE. 2629 IF ( PRESENT(CaseConversion) ) DoCase = CaseConversion 2630 2631 IF ( DoCase ) THEN 2632 k = StringToLowerCase( ptr % CValue,CValue ) 2633 ELSE 2634 k = MIN( MAX_NAME_LEN,LEN(CValue) ) 2635 ptr % CValue(1:k) = CValue(1:k) 2636 END IF 2637 2638 ptr % TYPE = LIST_TYPE_STRING 2639 ptr % NameLen = StringToLowerCase( Ptr % Name,Name ) 2640!------------------------------------------------------------------------------ 2641 END SUBROUTINE ListAddString 2642!------------------------------------------------------------------------------ 2643 2644 2645!------------------------------------------------------------------------------ 2646!> Adds a logical entry to the list. 2647!------------------------------------------------------------------------------ 2648 SUBROUTINE ListAddLogical( List,Name,LValue ) 2649!------------------------------------------------------------------------------ 2650 TYPE(ValueList_t), POINTER :: List 2651 CHARACTER(LEN=*) :: Name 2652 LOGICAL :: LValue 2653!------------------------------------------------------------------------------ 2654 TYPE(ValueListEntry_t), POINTER :: ptr 2655!------------------------------------------------------------------------------ 2656 ptr => ListAdd( List, Name ) 2657 Ptr % LValue = LValue 2658 Ptr % TYPE = LIST_TYPE_LOGICAL 2659 2660 Ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2661 END SUBROUTINE ListAddLogical 2662!------------------------------------------------------------------------------ 2663 2664 2665!------------------------------------------------------------------------------ 2666!> Adds an integer to the list. 2667!------------------------------------------------------------------------------ 2668 SUBROUTINE ListAddInteger( List,Name,IValue,Proc ) 2669!------------------------------------------------------------------------------ 2670 TYPE(ValueList_t), POINTER :: List 2671 CHARACTER(LEN=*) :: Name 2672 INTEGER :: IValue 2673 INTEGER(Kind=AddrInt), OPTIONAL :: Proc 2674!------------------------------------------------------------------------------ 2675 TYPE(ValueListEntry_t), POINTER :: ptr 2676!------------------------------------------------------------------------------ 2677 ptr => ListAdd( List, Name ) 2678 IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc 2679 2680 ALLOCATE( ptr % IValues(1) ) 2681 ptr % IValues(1) = IValue 2682 ptr % TYPE = LIST_TYPE_INTEGER 2683 2684 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2685 END SUBROUTINE ListAddInteger 2686!------------------------------------------------------------------------------ 2687 2688 2689!------------------------------------------------------------------------------ 2690!> Adds an integer array to the list. 2691!------------------------------------------------------------------------------ 2692 SUBROUTINE ListAddIntegerArray( List,Name,N,IValues,Proc ) 2693!------------------------------------------------------------------------------ 2694 TYPE(ValueList_t), POINTER :: List 2695 CHARACTER(LEN=*) :: Name 2696 INTEGER :: N 2697 INTEGER :: IValues(N) 2698 INTEGER(KIND=AddrInt), OPTIONAL :: Proc 2699!------------------------------------------------------------------------------ 2700 TYPE(ValueListEntry_t), POINTER :: ptr 2701!------------------------------------------------------------------------------ 2702 ptr => ListAdd( List, Name ) 2703 2704 ALLOCATE( ptr % IValues(N) ) 2705 2706 IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc 2707 2708 IF( n == 1 ) THEN 2709 ptr % TYPE = LIST_TYPE_INTEGER 2710 ELSE 2711 ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR 2712 END IF 2713 2714 ptr % IValues(1:n) = IValues(1:n) 2715 2716 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2717 END SUBROUTINE ListAddIntegerArray 2718!------------------------------------------------------------------------------ 2719 2720!------------------------------------------------------------------------------ 2721!> Adds a constant real value to the list. 2722!------------------------------------------------------------------------------ 2723 SUBROUTINE ListAddConstReal( List,Name,FValue,Proc,CValue ) 2724!------------------------------------------------------------------------------ 2725 TYPE(ValueList_t), POINTER :: List 2726 CHARACTER(LEN=*) :: Name 2727 CHARACTER(LEN=*), OPTIONAL :: Cvalue 2728 REAL(KIND=dp) :: FValue 2729 INTEGER(KIND=AddrInt), OPTIONAL :: Proc 2730!------------------------------------------------------------------------------ 2731 TYPE(ValueListEntry_t), POINTER :: ptr 2732!------------------------------------------------------------------------------ 2733 ptr => ListAdd( List, Name ) 2734 2735 NULLIFY( ptr % TValues ) 2736 ALLOCATE( ptr % FValues(1,1,1) ) 2737 2738 ptr % FValues = FValue 2739 ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR 2740 2741 IF ( PRESENT(Proc) ) THEN 2742 ptr % PROCEDURE = Proc 2743 IF( Proc /= 0 ) THEN 2744 ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_PROC 2745 END IF 2746 END IF 2747 2748 IF ( PRESENT( CValue ) ) THEN 2749 ptr % Cvalue = CValue 2750 ptr % TYPE = LIST_TYPE_CONSTANT_SCALAR_STR 2751 END IF 2752 2753 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2754 END SUBROUTINE ListAddConstReal 2755!------------------------------------------------------------------------------ 2756 2757 2758!------------------------------------------------------------------------------ 2759!> Adds a linear dependency defined by a table of values, [x,y] to the list. 2760!------------------------------------------------------------------------------ 2761 SUBROUTINE ListAddDepReal(List,Name,DependName,N,TValues, & 2762 FValues,Proc,CValue,CubicTable, Monotone) 2763!------------------------------------------------------------------------------ 2764 TYPE(ValueList_t), POINTER :: List 2765 CHARACTER(LEN=*) :: Name,DependName 2766 CHARACTER(LEN=*), OPTIONAL :: Cvalue 2767 INTEGER :: N 2768 LOGICAL, OPTIONAL :: CubicTable, Monotone 2769 REAL(KIND=dp) :: FValues(N) 2770 REAL(KIND=dp) :: TValues(N) 2771 INTEGER(KIND=AddrInt), OPTIONAL :: Proc 2772!------------------------------------------------------------------------------ 2773 TYPE(ValueListEntry_t), POINTER :: ptr 2774!------------------------------------------------------------------------------ 2775 ptr => ListAdd( List, Name ) 2776 IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc 2777 2778 ALLOCATE( ptr % FValues(1,1,n),ptr % TValues(n) ) 2779 2780 ! The (x,y) table should be such that values of x are increasing in size 2781 IF( .NOT. CheckMonotone( n, TValues ) ) THEN 2782 CALL Fatal('ListAddDepReal',& 2783 'Values x in > '//TRIM(Name)//' < not monotonically ordered!') 2784 END IF 2785 2786 ptr % TValues = TValues(1:n) 2787 ptr % FValues(1,1,:) = FValues(1:n) 2788 ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR 2789 2790 IF ( n>3 .AND. PRESENT(CubicTable)) THEN 2791 IF ( CubicTable ) THEN 2792 ALLOCATE(ptr % CubicCoeff(n)) 2793 CALL CubicSpline(n,ptr % TValues,Ptr % Fvalues(1,1,:), & 2794 Ptr % CubicCoeff, Monotone ) 2795 END IF 2796 END IF 2797 2798 ALLOCATE(ptr % Cumulative(n)) 2799 CALL CumulativeIntegral(ptr % TValues, Ptr % FValues(1,1,:), & 2800 Ptr % CubicCoeff, Ptr % Cumulative ) 2801 2802 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2803 ptr % DepNameLen = StringToLowerCase( ptr % DependName,DependName ) 2804 2805 IF ( PRESENT( Cvalue ) ) THEN 2806 ptr % CValue = CValue 2807 ptr % TYPE = LIST_TYPE_VARIABLE_SCALAR_STR 2808 END IF 2809 2810 END SUBROUTINE ListAddDepReal 2811!------------------------------------------------------------------------------ 2812 2813 2814!------------------------------------------------------------------------------ 2815!> Adds a constant real valued array to the list. 2816!------------------------------------------------------------------------------ 2817 SUBROUTINE ListAddConstRealArray( List,Name,N,M,FValues,Proc,CValue ) 2818!------------------------------------------------------------------------------ 2819 TYPE(ValueList_t), POINTER :: List 2820 CHARACTER(LEN=*) :: Name 2821 CHARACTER(LEN=*), OPTIONAL :: Cvalue 2822 INTEGER :: N,M 2823 REAL(KIND=dp) :: FValues(:,:) 2824 INTEGER(KIND=AddrInt), OPTIONAL :: Proc 2825!------------------------------------------------------------------------------ 2826 TYPE(ValueListEntry_t), POINTER :: ptr 2827!------------------------------------------------------------------------------ 2828 ptr => ListAdd( List, Name ) 2829 2830 NULLIFY( ptr % TValues ) 2831 ALLOCATE( ptr % FValues(N,M,1) ) 2832 2833 ptr % Fdim = 0 2834 IF( N > 1 ) ptr % Fdim = 1 2835 IF( M > 1 ) ptr % Fdim = ptr % Fdim + 1 2836 2837 ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR 2838 ptr % FValues(1:n,1:m,1) = FValues(1:n,1:m) 2839 2840 IF ( PRESENT(Proc) ) THEN 2841 ptr % PROCEDURE = Proc 2842 END IF 2843 2844 IF ( PRESENT( Cvalue ) ) THEN 2845 ptr % CValue = CValue 2846 ptr % TYPE = LIST_TYPE_CONSTANT_TENSOR_STR 2847 END IF 2848 2849 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2850 END SUBROUTINE ListAddConstRealArray 2851!------------------------------------------------------------------------------ 2852 2853 2854!------------------------------------------------------------------------------ 2855!> Adds a real array where the components are linearly dependent. 2856!------------------------------------------------------------------------------ 2857 SUBROUTINE ListAddDepRealArray(List,Name,DependName, & 2858 N,TValues,N1,N2,FValues,Proc,Cvalue) 2859!------------------------------------------------------------------------------ 2860 TYPE(ValueList_t), POINTER :: List 2861 CHARACTER(LEN=*) :: Name,DependName 2862 CHARACTER(LEN=*), OPTIONAL :: Cvalue 2863 INTEGER :: N,N1,N2 2864 REAL(KIND=dp) :: FValues(:,:,:) 2865 REAL(KIND=dp) :: TValues(N) 2866 INTEGER(KIND=AddrInt), OPTIONAL :: Proc 2867!------------------------------------------------------------------------------ 2868 TYPE(ValueListEntry_t), POINTER :: ptr 2869!------------------------------------------------------------------------------ 2870 2871 ptr => ListAdd( List, Name ) 2872 IF ( PRESENT(Proc) ) ptr % PROCEDURE = Proc 2873 2874 ALLOCATE( ptr % FValues(n1,n2,N),ptr % TValues(N) ) 2875 2876 ptr % TValues = TValues(1:N) 2877 ptr % FValues = FValues(1:n1,1:n2,1:N) 2878 ptr % TYPE = LIST_TYPE_VARIABLE_TENSOR 2879 2880 ptr % fdim = 0 2881 IF( n1 > 1 ) ptr % fdim = 1 2882 IF( n2 > 1 ) ptr % fdim = ptr % fdim + 1 2883 2884 IF ( PRESENT( Cvalue ) ) THEN 2885 ptr % CValue = CValue 2886 ptr % TYPE = LIST_TYPE_VARIABLE_TENSOR_STR 2887 END IF 2888 2889 ptr % NameLen = StringToLowerCase( ptr % Name,Name ) 2890 ptr % DepNameLen = StringToLowerCase( ptr % DependName,DependName ) 2891!------------------------------------------------------------------------------ 2892 END SUBROUTINE ListAddDepRealArray 2893!------------------------------------------------------------------------------ 2894 2895 2896!------------------------------------------------------------------------------ 2897!> Adds a logical entry to the list if it does not exist previously. 2898!------------------------------------------------------------------------------ 2899 SUBROUTINE ListAddNewLogical( List,Name,LValue ) 2900!------------------------------------------------------------------------------ 2901 TYPE(ValueList_t), POINTER :: List 2902 CHARACTER(LEN=*) :: Name 2903 LOGICAL :: LValue 2904!------------------------------------------------------------------------------ 2905 TYPE(ValueListEntry_t), POINTER :: ptr 2906!------------------------------------------------------------------------------ 2907 IF( ListCheckPresent( List, Name ) ) RETURN 2908 2909 CALL ListAddLogical( List,Name,LValue ) 2910 2911 END SUBROUTINE ListAddNewLogical 2912!------------------------------------------------------------------------------ 2913 2914 2915!------------------------------------------------------------------------------ 2916!> Adds an integer to the list when not present previously. 2917!------------------------------------------------------------------------------ 2918 SUBROUTINE ListAddNewInteger( List,Name,IValue,Proc ) 2919!------------------------------------------------------------------------------ 2920 TYPE(ValueList_t), POINTER :: List 2921 CHARACTER(LEN=*) :: Name 2922 INTEGER :: IValue 2923 INTEGER(Kind=AddrInt), OPTIONAL :: Proc 2924!------------------------------------------------------------------------------ 2925 TYPE(ValueListEntry_t), POINTER :: ptr 2926!------------------------------------------------------------------------------ 2927 IF( ListCheckPresent( List, Name ) ) RETURN 2928 2929 CALL ListAddInteger( List,Name,IValue,Proc ) 2930 2931 END SUBROUTINE ListAddNewInteger 2932!------------------------------------------------------------------------------ 2933 2934 2935!------------------------------------------------------------------------------ 2936!> Adds a constant real value to the list if not present. 2937!------------------------------------------------------------------------------ 2938 SUBROUTINE ListAddNewConstReal( List,Name,FValue,Proc,CValue ) 2939!------------------------------------------------------------------------------ 2940 TYPE(ValueList_t), POINTER :: List 2941 CHARACTER(LEN=*) :: Name 2942 CHARACTER(LEN=*), OPTIONAL :: Cvalue 2943 REAL(KIND=dp) :: FValue 2944 INTEGER(KIND=AddrInt), OPTIONAL :: Proc 2945!------------------------------------------------------------------------------ 2946 TYPE(ValueListEntry_t), POINTER :: ptr 2947!------------------------------------------------------------------------------ 2948 IF( ListCheckPresent( List, Name ) ) RETURN 2949 2950 CALL ListAddConstReal( List,Name,FValue,Proc,CValue ) 2951 2952 END SUBROUTINE ListAddNewConstReal 2953!------------------------------------------------------------------------------ 2954 2955 2956 2957!------------------------------------------------------------------------------ 2958!> Add a string value to the list if not present. 2959!------------------------------------------------------------------------------ 2960 SUBROUTINE ListAddNewString( List,Name,CValue,CaseConversion ) 2961!------------------------------------------------------------------------------ 2962 TYPE(ValueList_t), POINTER :: List 2963 CHARACTER(LEN=*) :: Name 2964 CHARACTER(LEN=*) :: CValue 2965 LOGICAL, OPTIONAL :: CaseConversion 2966 2967 IF( ListCheckPresent( List, Name ) ) RETURN 2968 2969 CALL ListAddString( List,Name,CValue,CaseConversion ) 2970 2971 END SUBROUTINE ListAddNewString 2972!------------------------------------------------------------------------------ 2973 2974 2975!------------------------------------------------------------------------------ 2976!> Gets a integer value from the list. 2977!------------------------------------------------------------------------------ 2978 RECURSIVE FUNCTION ListGetInteger( List,Name,Found,minv,maxv,UnfoundFatal ) RESULT(L) 2979!------------------------------------------------------------------------------ 2980 TYPE(ValueList_t), POINTER :: List 2981 CHARACTER(LEN=*) :: Name 2982 INTEGER :: L 2983 LOGICAL, OPTIONAL :: Found, UnfoundFatal 2984 INTEGER, OPTIONAL :: minv,maxv 2985!------------------------------------------------------------------------------ 2986 TYPE(ValueListEntry_t), POINTER :: ptr 2987!------------------------------------------------------------------------------ 2988 L = 0 2989 ptr => ListFind(List,Name,Found) 2990 IF (.NOT.ASSOCIATED(ptr) ) THEN 2991 IF(PRESENT(UnfoundFatal)) THEN 2992 IF(UnfoundFatal) THEN 2993 WRITE(Message, '(A,A)') "Failed to find integer: ",Name 2994 CALL Fatal("ListGetInteger", Message) 2995 END IF 2996 END IF 2997 RETURN 2998 END IF 2999 3000 IF( ptr % type /= LIST_TYPE_INTEGER ) THEN 3001 CALL Fatal('ListGetInteger','Invalid list type for: '//TRIM(Name)) 3002 END IF 3003 3004 IF ( ptr % PROCEDURE /= 0 ) THEN 3005 CALL ListPushActiveName(Name) 3006 L = ExecIntFunction( ptr % PROCEDURE, CurrentModel ) 3007 CALL ListPopActiveName() 3008 ELSE 3009 IF ( .NOT. ASSOCIATED(ptr % IValues) ) THEN 3010 WRITE(Message,*) 'Value type for property [', TRIM(Name), & 3011 '] not used consistently.' 3012 CALL Fatal( 'ListGetInteger', Message ) 3013 RETURN 3014 END IF 3015 3016 L = ptr % IValues(1) 3017 END IF 3018 3019 IF ( PRESENT( minv ) ) THEN 3020 IF ( L < minv ) THEN 3021 WRITE( Message, '(A,I0,A,I0)') 'Given value ',L,' for property: ['//TRIM(Name)//& 3022 '] smaller than given minimum: ', minv 3023 CALL Fatal( 'ListGetInteger', Message ) 3024 END IF 3025 END IF 3026 3027 IF ( PRESENT( maxv ) ) THEN 3028 IF ( L > maxv ) THEN 3029 WRITE( Message, '(A,I0,A,I0)') 'Given value ',L,' for property: ['//TRIM(Name)//& 3030 '] larger than given maximum: ', maxv 3031 CALL Fatal( 'ListGetInteger', Message ) 3032 END IF 3033 END IF 3034!------------------------------------------------------------------------------ 3035 END FUNCTION ListGetInteger 3036!------------------------------------------------------------------------------ 3037 3038 3039!------------------------------------------------------------------------------ 3040!> Gets a integer array from the list. 3041!------------------------------------------------------------------------------ 3042 RECURSIVE FUNCTION ListGetIntegerArray( List,Name,Found,UnfoundFatal ) RESULT( IValues ) 3043!------------------------------------------------------------------------------ 3044 TYPE(ValueList_t), POINTER :: List 3045 CHARACTER(LEN=*) :: Name 3046 LOGICAL, OPTIONAL :: Found, UnfoundFatal 3047!------------------------------------------------------------------------------ 3048 TYPE(ValueListEntry_t), POINTER :: ptr 3049 INTEGER :: i,n 3050 INTEGER, POINTER :: IValues(:) 3051!------------------------------------------------------------------------------ 3052 NULLIFY( IValues ) 3053 ptr => ListFind(List,Name,Found) 3054 IF (.NOT.ASSOCIATED(ptr) ) THEN 3055 IF(PRESENT(UnfoundFatal)) THEN 3056 IF(UnfoundFatal) THEN 3057 WRITE(Message, '(A,A)') "Failed to find integer array: ",Name 3058 CALL Fatal("ListGetIntegerArray", Message) 3059 END IF 3060 END IF 3061 RETURN 3062 END IF 3063 3064 IF ( .NOT. ASSOCIATED(ptr % IValues) ) THEN 3065 WRITE(Message,*) 'Value type for property [', TRIM(Name), & 3066 '] not used consistently.' 3067 CALL Fatal( 'ListGetIntegerArray', Message ) 3068 END IF 3069 3070 n = SIZE(ptr % IValues) 3071 IValues => Ptr % IValues(1:n) 3072 3073 IF ( ptr % PROCEDURE /= 0 ) THEN 3074 CALL ListPushActiveName(Name) 3075 IValues = 0 3076 DO i=1,N 3077 Ivalues(i) = ExecIntFunction( ptr % PROCEDURE, CurrentModel ) 3078 END DO 3079 CALL ListPopActiveName() 3080 END IF 3081!------------------------------------------------------------------------------ 3082 END FUNCTION ListGetIntegerArray 3083!------------------------------------------------------------------------------ 3084 3085 3086!------------------------------------------------------------------------------ 3087!> Check whether the keyword is associated to an integer or real array. 3088!------------------------------------------------------------------------------ 3089 RECURSIVE FUNCTION ListCheckIsArray( List,Name,Found ) RESULT( IsArray ) 3090!------------------------------------------------------------------------------ 3091 TYPE(ValueList_t), POINTER :: List 3092 CHARACTER(LEN=*) :: Name 3093 LOGICAL, OPTIONAL :: Found 3094 LOGICAL :: IsArray 3095!------------------------------------------------------------------------------ 3096 TYPE(ValueListEntry_t), POINTER :: ptr 3097 INTEGER :: n 3098!------------------------------------------------------------------------------ 3099 3100 ptr => ListFind(List,Name,Found) 3101 IsArray = .FALSE. 3102 IF(.NOT. ASSOCIATED( ptr ) ) RETURN 3103 3104 n = 0 3105 IF ( ASSOCIATED(ptr % IValues) ) THEN 3106 n = SIZE(ptr % IValues) 3107 END IF 3108 IF( ASSOCIATED( ptr % FValues ) ) THEN 3109 n = SIZE(ptr % FValues) 3110 END IF 3111 3112 IsArray = ( n > 1 ) 3113 3114!------------------------------------------------------------------------------ 3115 END FUNCTION ListCheckIsArray 3116!------------------------------------------------------------------------------ 3117 3118 3119 3120!------------------------------------------------------------------------------ 3121!> Gets a logical value from the list, if not found return False. 3122!------------------------------------------------------------------------------ 3123 RECURSIVE FUNCTION ListGetLogical( List,Name,Found,UnfoundFatal ) RESULT(L) 3124!------------------------------------------------------------------------------ 3125 TYPE(ValueList_t), POINTER :: List 3126 CHARACTER(LEN=*) :: Name 3127 LOGICAL :: L 3128 LOGICAL, OPTIONAL :: Found, UnfoundFatal 3129!------------------------------------------------------------------------------ 3130 TYPE(ValueListEntry_t), POINTER :: ptr 3131!------------------------------------------------------------------------------ 3132 L = .FALSE. 3133 ptr => ListFind(List,Name,Found) 3134 IF (.NOT.ASSOCIATED(ptr) ) THEN 3135 IF(PRESENT(UnfoundFatal)) THEN 3136 IF(UnfoundFatal) THEN 3137 WRITE(Message, '(A,A)') "Failed to find logical: ",Name 3138 CALL Fatal("ListGetLogical", Message) 3139 END IF 3140 END IF 3141 RETURN 3142 END IF 3143 3144 IF(ptr % TYPE == LIST_TYPE_LOGICAL ) THEN 3145 L = ptr % Lvalue 3146 ELSE 3147 CALL Fatal('ListGetLogical','Invalid list type for: '//TRIM(Name)) 3148 END IF 3149 3150!------------------------------------------------------------------------------ 3151 END FUNCTION ListGetLogical 3152!------------------------------------------------------------------------------ 3153 3154 3155 3156!------------------------------------------------------------------------------ 3157!> A generalized version of ListGetLogical. Uses logical, only if the keyword is 3158!> of type locical, if the type is real it return True for positive values, 3159!> and otherwise returns True IF the keyword is present. 3160!> Since the absence if a sign of False there is no separate Found flag. 3161!------------------------------------------------------------------------------ 3162 RECURSIVE FUNCTION ListGetLogicalGen( List, Name) RESULT(L) 3163!------------------------------------------------------------------------------ 3164 TYPE(ValueList_t), POINTER :: List 3165 CHARACTER(LEN=*) :: Name 3166 LOGICAL :: L 3167!------------------------------------------------------------------------------ 3168 TYPE(ValueListEntry_t), POINTER :: ptr 3169 LOGICAL :: Found 3170 REAL(KIND=dp) :: Rval 3171!------------------------------------------------------------------------------ 3172 3173 L = .FALSE. 3174 3175 ptr => ListFind(List,Name,Found) 3176 IF ( .NOT. ASSOCIATED(ptr) ) RETURN 3177 3178 IF(ptr % TYPE == LIST_TYPE_LOGICAL ) THEN 3179 L = ptr % Lvalue 3180 3181 ELSE IF ( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR .OR. & 3182 ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_STR .OR. & 3183 ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN 3184 3185 RVal = ListGetConstReal( List, Name ) 3186 L = ( RVal > 0.0_dp ) 3187 ELSE 3188 L = .TRUE. 3189 !Mere presence implies true mask 3190 !CALL Fatal('ListGetLogicalGen','Invalid list type for: '//TRIM(Name)) 3191 END IF 3192 3193!------------------------------------------------------------------------------ 3194 END FUNCTION ListGetLogicalGen 3195!------------------------------------------------------------------------------ 3196 3197 3198 3199!------------------------------------------------------------------------------ 3200!> Gets a string from the list by its name, if not found return empty string. 3201!------------------------------------------------------------------------------ 3202 RECURSIVE FUNCTION ListGetString( List,Name,Found,UnfoundFatal ) RESULT(S) 3203!------------------------------------------------------------------------------ 3204 TYPE(ValueList_t), POINTER :: List 3205 CHARACTER(LEN=*) :: Name 3206 LOGICAL, OPTIONAL :: Found,UnfoundFatal 3207 CHARACTER(LEN=MAX_NAME_LEN) :: S 3208!------------------------------------------------------------------------------ 3209 TYPE(ValueListEntry_t), POINTER :: ptr 3210!------------------------------------------------------------------------------ 3211 S = ' ' 3212 ptr => ListFind(List,Name,Found) 3213 IF (.NOT.ASSOCIATED(ptr) ) THEN 3214 IF(PRESENT(UnfoundFatal)) THEN 3215 IF(UnfoundFatal) THEN 3216 WRITE(Message, '(A,A)') "Failed to find string: ",Name 3217 CALL Fatal("ListGetString", Message) 3218 END IF 3219 END IF 3220 RETURN 3221 END IF 3222 3223 IF( ptr % Type == LIST_TYPE_STRING ) THEN 3224 S = ptr % Cvalue 3225 ELSE 3226 CALL Fatal('ListGetString','Invalid list type: '//TRIM(Name)) 3227 END IF 3228 3229!------------------------------------------------------------------------------ 3230 END FUNCTION ListGetString 3231!------------------------------------------------------------------------------ 3232 3233 3234!------------------------------------------------------------------------------ 3235!> Get a constant real from the list by its name. 3236!------------------------------------------------------------------------------ 3237 RECURSIVE FUNCTION ListGetConstReal( List,Name,Found,x,y,z,minv,maxv,UnfoundFatal ) RESULT(F) 3238!------------------------------------------------------------------------------ 3239 TYPE(ValueList_t), POINTER :: List 3240 CHARACTER(LEN=*) :: Name 3241 REAL(KIND=dp) :: F 3242 LOGICAL, OPTIONAL :: Found,UnfoundFatal 3243 REAL(KIND=dp), OPTIONAL :: x,y,z 3244 REAL(KIND=dp), OPTIONAL :: minv,maxv 3245!------------------------------------------------------------------------------ 3246 TYPE(Variable_t), POINTER :: Variable 3247 TYPE(ValueListEntry_t), POINTER :: ptr 3248 REAL(KIND=dp) :: xx,yy,zz 3249 INTEGER :: i,j,k,n 3250 CHARACTER(LEN=MAX_NAME_LEN) :: cmd,tmp_str 3251!------------------------------------------------------------------------------ 3252 F = 0.0_dp 3253 3254 ptr => ListFind(List,Name,Found) 3255 IF (.NOT.ASSOCIATED(ptr) ) THEN 3256 IF(PRESENT(UnfoundFatal)) THEN 3257 IF(UnfoundFatal) THEN 3258 WRITE(Message, '(A,A)') "Failed to find constant real: ",Name 3259 CALL Fatal("ListGetConstReal", Message) 3260 END IF 3261 END IF 3262 RETURN 3263 END IF 3264 3265 SELECT CASE(ptr % TYPE) 3266 3267 CASE( LIST_TYPE_CONSTANT_SCALAR ) 3268 3269 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 3270 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 3271 '] not used consistently.' 3272 CALL Fatal( 'ListGetConstReal', Message ) 3273 END IF 3274 F = ptr % Coeff * ptr % Fvalues(1,1,1) 3275 3276 CASE( LIST_TYPE_CONSTANT_SCALAR_STR ) 3277 3278 cmd = ptr % CValue 3279 k = LEN_TRIM( ptr % CValue ) 3280 CALL matc( cmd, tmp_str, k ) 3281 READ( tmp_str(1:k), * ) F 3282 F = ptr % Coeff * F 3283 3284 CASE( LIST_TYPE_CONSTANT_SCALAR_PROC ) 3285 3286 IF ( ptr % PROCEDURE == 0 ) THEN 3287 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 3288 '] not used consistently.' 3289 CALL Fatal( 'ListGetConstReal', Message ) 3290 END IF 3291 3292 xx = 0.0_dp 3293 yy = 0.0_dp 3294 zz = 0.0_dp 3295 IF ( PRESENT(x) ) xx = x 3296 IF ( PRESENT(y) ) yy = y 3297 IF ( PRESENT(z) ) zz = z 3298 CALL ListPushActiveName(Name) 3299 F = Ptr % Coeff * & 3300 ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,xx,yy,zz ) 3301 CALL ListPopActiveName() 3302 3303 CASE( LIST_TYPE_VARIABLE_SCALAR, LIST_TYPE_VARIABLE_SCALAR_STR ) 3304 CALL Fatal('ListGetConstReal','Constant cannot depend on variables: '//TRIM(Name)) 3305 3306 CASE DEFAULT 3307 CALL Fatal('ListGetConstReal','Invalid list type for: '//TRIM(Name)) 3308 3309 END SELECT 3310 3311 IF ( PRESENT( minv ) ) THEN 3312 IF ( F < minv ) THEN 3313 WRITE( Message, *) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', & 3314 ' smaller than given minimum: ', minv 3315 CALL Fatal( 'ListGetInteger', Message ) 3316 END IF 3317 END IF 3318 3319 IF ( PRESENT( maxv ) ) THEN 3320 IF ( F > maxv ) THEN 3321 WRITE( Message, *) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', & 3322 ' larger than given maximum: ', maxv 3323 CALL Fatal( 'ListGetInteger', Message ) 3324 END IF 3325 END IF 3326!------------------------------------------------------------------------------ 3327 END FUNCTION ListGetConstReal 3328!------------------------------------------------------------------------------ 3329 3330 3331!------------------------------------------------------------------------------ 3332!> Returns a scalar real value, that may depend on other scalar values such as 3333!> time or timestep size etc. 3334!------------------------------------------------------------------------------ 3335 RECURSIVE FUNCTION ListGetCReal( List, Name, Found, UnfoundFatal) RESULT(s) 3336!------------------------------------------------------------------------------ 3337 TYPE(ValueList_t), POINTER :: List 3338 CHARACTER(LEN=*) :: Name 3339 LOGICAL, OPTIONAL :: Found,UnfoundFatal 3340 INTEGER, TARGET :: Dnodes(1) 3341 INTEGER, POINTER :: NodeIndexes(:) 3342 3343 REAL(KIND=dp) :: s 3344 REAL(KIND=dp) :: x(1) 3345 TYPE(Element_t), POINTER :: Element 3346 3347 INTEGER :: n, istat 3348 3349 IF ( PRESENT( Found ) ) Found = .FALSE. 3350 3351 NodeIndexes => Dnodes 3352 n = 1 3353 NodeIndexes(n) = 1 3354 3355 x = 0.0_dp 3356 IF ( ASSOCIATED(List % head) ) THEN 3357 IF ( PRESENT( Found ) ) THEN 3358 x(1:n) = ListGetReal( List, Name, n, NodeIndexes, Found, UnfoundFatal=UnfoundFatal ) 3359 ELSE 3360 x(1:n) = ListGetReal( List, Name, n, NodeIndexes, UnfoundFatal=UnfoundFatal) 3361 END IF 3362 END IF 3363 s = x(1) 3364!------------------------------------------------------------------------------ 3365 END FUNCTION ListGetCReal 3366!------------------------------------------------------------------------------ 3367 3368!------------------------------------------------------------------------------ 3369!> Returns a scalar real value, that may depend on other scalar values such as 3370!> time or timestep size etc. 3371!------------------------------------------------------------------------------ 3372 RECURSIVE FUNCTION ListGetRealAtNode( List, Name, Node, Found, UnfoundFatal ) RESULT(s) 3373!------------------------------------------------------------------------------ 3374 TYPE(ValueList_t), POINTER :: List 3375 CHARACTER(LEN=*) :: Name 3376 INTEGER :: Node 3377 LOGICAL, OPTIONAL :: Found, UnfoundFatal 3378 REAL(KIND=dp) :: s 3379!----------------------------------------------------------------------------- 3380 INTEGER, TARGET, SAVE :: Dnodes(1) 3381 INTEGER, POINTER :: NodeIndexes(:) 3382 REAL(KIND=dp) :: x(1) 3383 INTEGER, PARAMETER :: one = 1 3384 3385 IF ( PRESENT( Found ) ) Found = .FALSE. 3386 3387 IF ( ASSOCIATED(List % Head) ) THEN 3388 NodeIndexes => Dnodes 3389 NodeIndexes(one) = Node 3390 3391 x(1:one) = ListGetReal( List, Name, one, NodeIndexes, Found, UnfoundFatal=UnfoundFatal) 3392 s = x(one) 3393 ELSE 3394 s = 0.0_dp 3395 END IF 3396 3397!------------------------------------------------------------------------------ 3398 END FUNCTION ListGetRealAtNode 3399!------------------------------------------------------------------------------ 3400 3401 3402!> Get pointer to list of section 3403!------------------------------------------------------------------------------ 3404 FUNCTION ListGetSection( Element, SectionName, Found ) RESULT(lst) 3405!------------------------------------------------------------------------------ 3406 TYPE(ValueList_t), POINTER :: Lst 3407 CHARACTER(LEN=*) :: SectionName 3408 LOGICAL, OPTIONAL :: Found 3409 TYPE(Element_t) :: Element 3410!------------------------------------------------------------------------------ 3411 TYPE(ValueList_t), POINTER :: BodyLst 3412 INTEGER :: id 3413 LOGICAL :: LFound 3414 3415 id = Element % BodyId 3416 IF( id > 0 ) THEN 3417 bodylst => CurrentModel % Bodies(id) % Values 3418 ELSE 3419 NULLIFY( bodylst ) 3420 END IF 3421 LFound = .FALSE. 3422 3423 NULLIFY( lst ) 3424 3425 SELECT CASE ( SectionName ) 3426 3427 CASE( 'body' ) 3428 lst => bodylst 3429 Lfound = ASSOCIATED( lst ) 3430 3431 CASE( 'material' ) 3432 id = ListGetInteger( bodylst, SectionName, LFound ) 3433 IF( LFound ) lst => CurrentModel % Materials(id) % Values 3434 3435 CASE( 'body force' ) 3436 id = ListGetInteger( bodylst, SectionName, LFound ) 3437 IF( LFound ) lst => CurrentModel % BodyForces(id) % Values 3438 3439 CASE( 'initial condition' ) 3440 id = ListGetInteger( bodylst, SectionName, LFound ) 3441 IF( LFound ) lst => CurrentModel % ICs(id) % Values 3442 3443 CASE( 'equation' ) 3444 id = ListGetInteger( bodylst, SectionName, LFound ) 3445 IF( LFound ) lst => CurrentModel % Equations(id) % Values 3446 3447 CASE( 'boundary condition' ) 3448 IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN 3449 id = Element % BoundaryInfo % Constraint 3450 IF( id > 0 ) THEN 3451 lst => CurrentModel % BCs(id) % Values 3452 LFound = .TRUE. 3453 END IF 3454 END IF 3455 3456 CASE DEFAULT 3457 CALL Fatal('ListGetSection','Unknown section name: '//TRIM(SectionName)) 3458 3459 END SELECT 3460 3461 IF( PRESENT( Found ) ) Found = LFound 3462 3463!------------------------------------------------------------------------------ 3464 END FUNCTION ListGetSection 3465!------------------------------------------------------------------------------ 3466 3467 3468 SUBROUTINE ListWarnUnsupportedKeyword( SectionName, Keyword, Found, FatalFound ) 3469 3470 CHARACTER(LEN=*) :: SectionName, Keyword 3471 3472 LOGICAL, OPTIONAL :: Found, FatalFound 3473 LOGICAL :: LFound, LFatal 3474 CHARACTER(LEN=MAX_NAME_LEN) :: str 3475 INTEGER :: k 3476 3477 k = StringToLowerCase( str,SectionName ) 3478 3479 LFatal = .FALSE. 3480 IF( PRESENT( FatalFound ) ) LFatal = FatalFound 3481 3482 SELECT CASE ( str ) !TRIM( str ) ) 3483 3484 CASE( 'body' ) 3485 LFound = ListCheckPresentAnyBody( CurrentModel, Keyword ) 3486 3487 CASE( 'material' ) 3488 LFound = ListCheckPresentAnyMaterial( CurrentModel, Keyword ) 3489 3490 CASE( 'body force' ) 3491 LFound = ListCheckPresentAnyBodyForce( CurrentModel, Keyword ) 3492 3493 CASE( 'solver' ) 3494 LFound = ListCheckPresentAnySolver( CurrentModel, Keyword ) 3495 3496 CASE( 'equation' ) 3497 LFound = ListCheckPresentAnyEquation( CurrentModel, Keyword ) 3498 3499 CASE( 'boundary condition' ) 3500 LFound = ListCheckPresentAnyBC( CurrentModel, Keyword ) 3501 3502 CASE( 'simulation' ) 3503 LFound = ListCheckPresent( CurrentModel % Simulation, Keyword ) 3504 3505 CASE( 'constants' ) 3506 LFound = ListCheckPresent( CurrentModel % Constants, Keyword ) 3507 3508 CASE DEFAULT 3509 CALL Fatal('ListWarnUnsupportedKeyword',& 3510 'Unknown section for "'//TRIM(Keyword)//'": '//TRIM(SectionName)) 3511 3512 END SELECT 3513 3514 IF( LFound ) THEN 3515 IF( LFatal ) THEN 3516 CALL Fatal('ListWarnUnsupportedKeyword',& 3517 'Keyword in section "'//TRIM(SectionName)//'" not supported: '//TRIM(Keyword) ) 3518 ELSE 3519 CALL Warn('ListWarnUnsupportedKeyword',& 3520 'Keyword in section "'//TRIM(SectionName)//'" not supported: '//TRIM(Keyword) ) 3521 END IF 3522 END IF 3523 3524 IF( PRESENT( Found ) ) Found = LFound 3525 3526 END SUBROUTINE ListWarnUnsupportedKeyword 3527 3528 3529!> Get pointer to list of section 3530!------------------------------------------------------------------------------ 3531 FUNCTION ListGetSectionId( Element, SectionName, Found ) RESULT(id) 3532!------------------------------------------------------------------------------ 3533 INTEGER :: id 3534 CHARACTER(LEN=*) :: SectionName 3535 LOGICAL, OPTIONAL :: Found 3536 TYPE(Element_t) :: Element 3537!------------------------------------------------------------------------------ 3538 TYPE(ValueList_t), POINTER :: BodyLst 3539 INTEGER :: body_id 3540 LOGICAL :: LFound 3541 3542 id = 0 3543 3544 body_id = Element % BodyId 3545 IF( body_id > 0 ) THEN 3546 bodylst => CurrentModel % Bodies(body_id) % Values 3547 ELSE 3548 NULLIFY( bodylst ) 3549 END IF 3550 LFound = .FALSE. 3551 3552 SELECT CASE ( SectionName ) 3553 3554 CASE( 'body' ) 3555 id = body_id 3556 3557 CASE( 'material' ) 3558 id = ListGetInteger( bodylst, SectionName, LFound ) 3559 3560 CASE( 'body force' ) 3561 id = ListGetInteger( bodylst, SectionName, LFound ) 3562 3563 CASE( 'initial condition' ) 3564 id = ListGetInteger( bodylst, SectionName, LFound ) 3565 3566 CASE( 'equation' ) 3567 id = ListGetInteger( bodylst, SectionName, LFound ) 3568 3569 CASE( 'boundary condition' ) 3570 IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN 3571 id = Element % BoundaryInfo % Constraint 3572 END IF 3573 3574 CASE DEFAULT 3575 CALL Fatal('ListGetSection','Unknown section name: '//TRIM(SectionName)) 3576 3577 END SELECT 3578 3579 IF( PRESENT( Found ) ) Found = ( id > 0 ) 3580 3581!------------------------------------------------------------------------------ 3582 END FUNCTION ListGetSectionId 3583!------------------------------------------------------------------------------ 3584 3585 3586 3587!------------------------------------------------------------------------------ 3588!> Given a string containing comma-separated variablenames, reads the strings 3589!> and obtains the corresponding variables to a table. 3590!------------------------------------------------------------------------------ 3591 SUBROUTINE ListParseStrToVars( str, slen, name, count, VarTable, & 3592 SomeAtIp, SomeAtNodes, AllGlobal ) 3593!------------------------------------------------------------------------------ 3594 CHARACTER(LEN=*) :: str, name 3595 INTEGER :: slen, count 3596 TYPE(VariableTable_t) :: VarTable(:) 3597 LOGICAL :: SomeAtIp, SomeAtNodes, AllGlobal 3598!------------------------------------------------------------------------------ 3599 INTEGER :: i,j,k,n,k1,l,l0,l1 3600 TYPE(Variable_t), POINTER :: Var 3601 3602 SomeAtIp = .FALSE. 3603 SomeAtNodes = .FALSE. 3604 AllGlobal = .TRUE. 3605 3606 count=0 3607 l0=1 3608 IF(slen<=0) RETURN 3609 3610 DO WHILE( .TRUE. ) 3611 ! Remove zeros ahead 3612 DO WHILE( str(l0:l0) == ' ' ) 3613 l0 = l0 + 1 3614 IF ( l0 > slen ) EXIT 3615 END DO 3616 IF ( l0 > slen ) EXIT 3617 3618 ! Scan only until next comma 3619 l1 = INDEX( str(l0:slen),',') 3620 IF ( l1 > 0 ) THEN 3621 l1=l0+l1-2 3622 ELSE 3623 l1=slen 3624 END IF 3625 3626 IF ( str(l0:l1) == 'coordinate' ) THEN 3627 VarTable(count+1) % Variable => VariableGet( CurrentModel % Variables,"coordinate 1") 3628 VarTable(count+2) % Variable => VariableGet( CurrentModel % Variables,"coordinate 2") 3629 VarTable(count+3) % Variable => VariableGet( CurrentModel % Variables,"coordinate 3") 3630 count = count + 3 3631 SomeAtNodes = .TRUE. 3632 AllGlobal = .FALSE. 3633 ELSE 3634 Var => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) ) 3635 IF ( .NOT. ASSOCIATED( Var ) ) THEN 3636 CALL Info('ListParseStrToVars','Parsed variable '//TRIM(I2S(count+1))//' of '//str(1:slen),Level=3) 3637 CALL Info('ListParseStrToVars','Parse counters: '& 3638 //TRIM(I2S(l0))//', '//TRIM(I2S(l1))//', '//TRIM(I2S(slen)),Level=10) 3639 CALL Fatal('ListParseStrToVars', 'Can''t find independent variable:['// & 3640 TRIM(str(l0:l1))//'] for dependent variable:['//TRIM(Name)//']' ) 3641 END IF 3642 count = count + 1 3643 VarTable(count) % Variable => Var 3644 3645 IF( SIZE( Var % Values ) > Var % Dofs ) AllGlobal = .FALSE. 3646 3647 IF( Var % TYPE == Variable_on_gauss_points ) THEN 3648 SomeAtIp = .TRUE. 3649 ELSE 3650 SomeAtNodes = .TRUE. 3651 END IF 3652 3653 END IF 3654 3655 ! New start after the comma 3656 l0 = l1+2 3657 IF ( l0 > slen ) EXIT 3658 END DO 3659 3660!------------------------------------------------------------------------------ 3661 END SUBROUTINE ListParseStrToVars 3662!------------------------------------------------------------------------------ 3663 3664!------------------------------------------------------------------------------------- 3665!> Given a table of variables and a node index return the variable values on the node. 3666!------------------------------------------------------------------------------------- 3667 SUBROUTINE VarsToValuesOnNodes( VarCount, VarTable, ind, T, count ) 3668!------------------------------------------------------------------------------ 3669 INTEGER :: Varcount 3670 TYPE(VariableTable_t) :: VarTable(:) 3671 INTEGER :: ind 3672 INTEGER :: count 3673 REAL(KIND=dp) :: T(:) 3674!------------------------------------------------------------------------------ 3675 TYPE(Element_t), POINTER :: Element 3676 INTEGER :: i,j,k,n,k1,l,varsize,vari 3677 TYPE(Variable_t), POINTER :: Var 3678 LOGICAL :: Failed 3679 3680 count = 0 3681 Failed = .FALSE. 3682 3683 DO Vari = 1, VarCount 3684 3685 Var => VarTable(Vari) % Variable 3686 3687 Varsize = SIZE( Var % Values ) / Var % Dofs 3688 3689 IF( Varsize == 1 ) THEN 3690 DO l=1,Var % DOFs 3691 count = count + 1 3692 T(count) = Var % Values(l) 3693 END DO 3694 ELSE 3695 k1 = ind 3696 3697 IF ( Var % TYPE == Variable_on_gauss_points ) THEN 3698 count = count + Var % DOFs 3699 CYCLE 3700 ELSE IF( Var % TYPE == Variable_on_elements ) THEN 3701 Element => CurrentModel % CurrentElement 3702 IF( ASSOCIATED( Element ) ) THEN 3703 k1 = Element % ElementIndex 3704 ELSE 3705 CALL Fatal('VarsToValuesOnNodes','CurrentElement not associated!') 3706 END IF 3707 ELSE IF ( Var % TYPE == Variable_on_nodes_on_elements ) THEN 3708 Element => CurrentModel % CurrentElement 3709 IF ( ASSOCIATED(Element) ) THEN 3710 k1 = 0 3711 IF ( ASSOCIATED(Element % DGIndexes) ) THEN 3712 n = Element % TYPE % NumberOfNodes 3713 IF ( SIZE(Element % DGIndexes)==n ) THEN 3714 DO i=1,n 3715 IF ( Element % NodeIndexes(i)==ind ) THEN 3716 k1 = Element % DGIndexes(i) 3717 EXIT 3718 END IF 3719 END DO 3720 END IF 3721 END IF 3722 IF( k1 == 0 ) THEN 3723 CALL Fatal('VarsToValueOnNodes','Could not find index '//TRIM(I2S(ind))//& 3724 ' in element '//TRIM(I2S(Element % ElementIndex))) 3725 END IF 3726 ELSE 3727 CALL Fatal('VarsToValuesOnNodes','CurrentElement not associated!') 3728 END IF 3729 END IF 3730 3731 IF ( ASSOCIATED(Var % Perm) ) k1 = Var % Perm(k1) 3732 3733 IF ( k1 > 0 .AND. k1 <= VarSize ) THEN 3734 DO l=1,Var % DOFs 3735 count = count + 1 3736 T(count) = Var % Values(Var % Dofs*(k1-1)+l) 3737 END DO 3738 ELSE 3739 Failed = .TRUE. 3740 DO l=1,Var % DOFs 3741 count = count + 1 3742 T(count) = HUGE(1.0_dp) 3743 END DO 3744 RETURN 3745 END IF 3746 END IF 3747 END DO 3748 3749 END SUBROUTINE VarsToValuesOnNodes 3750 !------------------------------------------------------------------------------ 3751 3752 3753!------------------------------------------------------------------------------------- 3754!> Given a table of variables return the variable values on the gauss point. 3755!> This only deals with the gauss point variables, all other are already treated. 3756!------------------------------------------------------------------------------------- 3757 SUBROUTINE VarsToValuesOnIps( VarCount, VarTable, ind, T, count ) 3758!------------------------------------------------------------------------------ 3759 INTEGER :: Varcount 3760 TYPE(VariableTable_t) :: VarTable(:) 3761 INTEGER :: ind 3762 INTEGER :: count 3763 REAL(KIND=dp) :: T(:) 3764!------------------------------------------------------------------------------ 3765 TYPE(Element_t), POINTER :: Element 3766 INTEGER :: i,j,k,n,k1,l,varsize,vari 3767 TYPE(Variable_t), POINTER :: Var 3768 LOGICAL :: Failed 3769 3770 count = 0 3771 Failed = .FALSE. 3772 3773 DO Vari = 1, VarCount 3774 Var => VarTable(Vari) % Variable 3775 Varsize = SIZE( Var % Values ) / Var % Dofs 3776 3777 k1 = 0 3778 IF ( Var % TYPE == Variable_on_gauss_points ) THEN 3779 Element => CurrentModel % CurrentElement 3780 IF ( ASSOCIATED(Element) ) THEN 3781 k1 = Var % Perm( Element % ElementIndex ) + ind 3782 END IF 3783 END IF 3784 3785 IF ( k1 > 0 .AND. k1 <= VarSize ) THEN 3786 DO l=1,Var % DOFs 3787 count = count + 1 3788 T(count) = Var % Values(Var % Dofs*(k1-1)+l) 3789 END DO 3790 ELSE 3791 count = count + Var % Dofs 3792 END IF 3793 END DO 3794 3795 END SUBROUTINE VarsToValuesOnIps 3796 !------------------------------------------------------------------------------ 3797 3798 3799 3800!------------------------------------------------------------------------------ 3801 SUBROUTINE ListParseStrToValues( str, slen, ind, name, T, count, AllGlobal ) 3802!------------------------------------------------------------------------------ 3803 CHARACTER(LEN=*) :: str, name 3804 REAL(KIND=dp) :: T(:) 3805 INTEGER :: slen, count, ind 3806 LOGICAL :: AllGlobal 3807!------------------------------------------------------------------------------ 3808 TYPE(Element_t), POINTER :: Element 3809 INTEGER :: i,j,k,n,k1,l,l0,l1 3810 TYPE(Variable_t), POINTER :: Variable, CVar 3811 3812 AllGlobal = .TRUE. 3813 3814 count=0 3815 l0=1 3816 IF(slen<=0) RETURN 3817 3818 DO WHILE( .TRUE. ) 3819 DO WHILE( str(l0:l0) == ' ' ) 3820 l0 = l0 + 1 3821 IF ( l0 > slen ) EXIT 3822 END DO 3823 IF ( l0 > slen ) EXIT 3824 3825 l1 = INDEX( str(l0:slen),',') 3826 IF ( l1 > 0 ) THEN 3827 l1=l0+l1-2 3828 ELSE 3829 l1=slen 3830 END IF 3831 3832 IF ( str(l0:l1) /= 'coordinate' ) THEN 3833 Variable => VariableGet( CurrentModel % Variables,TRIM(str(l0:l1)) ) 3834 IF ( .NOT. ASSOCIATED( Variable ) ) THEN 3835 CALL Info('ListParseStrToValues','Parsed variable '//TRIM(I2S(count+1))//' of '//str(1:slen),Level=3) 3836 CALL Info('ListParseStrToValues','Parse counters: '& 3837 //TRIM(I2S(l0))//', '//TRIM(I2S(l1))//', '//TRIM(I2S(slen)),Level=10) 3838 CALL Fatal('ListParseStrToValues','Can''t find independent variable:['// & 3839 TRIM(str(l0:l1))//'] for dependent variable:['//TRIM(Name)//']') 3840 END IF 3841 IF( SIZE( Variable % Values ) > Variable % Dofs ) AllGlobal = .FALSE. 3842 ELSE 3843 AllGlobal = .FALSE. 3844 Variable => VariableGet( CurrentModel % Variables,'Coordinate 1' ) 3845 END IF 3846 3847 IF( Variable % TYPE == Variable_on_gauss_points ) THEN 3848 DO l=1,Variable % DOFs 3849 count = count + 1 3850 T(count) = HUGE(1.0_dp) 3851 END DO 3852 3853 l0 = l1+2 3854 IF ( l0 > slen ) EXIT 3855 CYCLE 3856 END IF 3857 3858 k1 = ind 3859 3860 IF ( Variable % TYPE == Variable_on_nodes_on_elements ) THEN 3861 Element => CurrentModel % CurrentElement 3862 IF ( ASSOCIATED(Element) ) THEN 3863 IF ( ASSOCIATED(Element % DGIndexes) ) THEN 3864 n = Element % TYPE % NumberOfNodes 3865 IF ( SIZE(Element % DGIndexes)==n ) THEN 3866 DO i=1,n 3867 IF ( Element % NodeIndexes(i)==ind ) THEN 3868 k1 = Element % DGIndexes(i) 3869 EXIT 3870 END IF 3871 END DO 3872 END IF 3873 END IF 3874 END IF 3875 END IF 3876 IF ( ASSOCIATED(Variable % Perm) ) k1 = Variable % Perm(k1) 3877 3878 IF ( k1>0 .AND. k1<=SIZE(Variable % Values) ) THEN 3879 IF ( str(l0:l1) == 'coordinate' ) THEN 3880 CVar => VariableGet( CurrentModel % Variables, 'Coordinate 1' ) 3881 count = count + 1 3882 T(1) = CVar % Values(k1) 3883 CVar => VariableGet( CurrentModel % Variables, 'Coordinate 2' ) 3884 count = count + 1 3885 T(2) = CVar % Values(k1) 3886 CVar => VariableGet( CurrentModel % Variables, 'Coordinate 3' ) 3887 count = count + 1 3888 T(3) = CVar % Values(k1) 3889 ELSE 3890 IF ( Variable % DOFs == 1 ) THEN 3891 count = count + 1 3892 T(count) = Variable % Values(k1) 3893 ELSE 3894 DO l=1,Variable % DOFs 3895 count = count + 1 3896 T(count) = Variable % Values(Variable % DOFs*(k1-1)+l) 3897 END DO 3898 END IF 3899 END IF 3900 ELSE 3901 3902 count = count + 1 3903 IF ( ASSOCIATED(Variable % Perm) ) THEN 3904 T(count) = HUGE(1.0_dp) 3905 EXIT 3906 ELSE 3907 T(count) = Variable % Values(1) 3908 END IF 3909 END IF 3910 3911 l0 = l1+2 3912 IF ( l0 > slen ) EXIT 3913 END DO 3914 3915!------------------------------------------------------------------------------ 3916 END SUBROUTINE ListParseStrToValues 3917!------------------------------------------------------------------------------ 3918 3919 3920 !------------------------------------------------------------------------------ 3921 FUNCTION ListCheckGlobal( ptr ) RESULT ( IsGlobal ) 3922!------------------------------------------------------------------------------ 3923 TYPE(ValueListEntry_t), POINTER :: ptr 3924 LOGICAL :: IsGlobal 3925!------------------------------------------------------------------------------ 3926 TYPE(Element_t), POINTER :: Element 3927 INTEGER :: ind,i,j,k,n,k1,l,l0,l1,ll,count 3928 TYPE(Variable_t), POINTER :: Variable, CVar 3929 INTEGER :: slen 3930 3931 IsGlobal = .TRUE. 3932 3933 IF(.NOT.ASSOCIATED(ptr)) THEN 3934 CALL Warn('ListCheckGlobal','ptr not associated!') 3935 RETURN 3936 END IF 3937 3938 3939 IF( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_STR ) THEN 3940 RETURN 3941 3942 ELSE IF( ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR .OR. & 3943 ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. & 3944 ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN 3945 3946 3947 IF ( ptr % PROCEDURE /= 0 ) THEN 3948 IsGlobal = .FALSE. 3949 RETURN 3950 END IF 3951 3952 slen = ptr % DepNameLen 3953 3954 IF( slen > 0 ) THEN 3955 count = 0 3956 l0 = 1 3957 DO WHILE( .TRUE. ) 3958 3959 DO WHILE( ptr % DependName(l0:l0) == ' ' ) 3960 l0 = l0 + 1 3961 END DO 3962 IF ( l0 > slen ) EXIT 3963 3964 l1 = INDEX( ptr % DependName(l0:slen),',') 3965 IF ( l1 > 0 ) THEN 3966 l1=l0+l1-2 3967 ELSE 3968 l1=slen 3969 END IF 3970 3971 count = count + 1 3972 3973 IF ( ptr % DependName(l0:l1) /= 'coordinate' ) THEN 3974 Variable => VariableGet( CurrentModel % Variables,TRIM(ptr % DependName(l0:l1)) ) 3975 IF ( .NOT. ASSOCIATED( Variable ) ) THEN 3976 CALL Info('ListCheckGlobal','Parsed variable '//TRIM(I2S(count))//' of '& 3977 //ptr % DependName(1:slen),Level=3) 3978 CALL Info('ListCheckGlobal','Parse counters: '& 3979 //TRIM(I2S(l0))//', '//TRIM(I2S(l1))//', '//TRIM(I2S(slen)),Level=10) 3980 3981 WRITE( Message, * ) 'Can''t find independent variable:[', & 3982 TRIM(ptr % DependName(l0:l1)),']' 3983 CALL Fatal( 'ListCheckGlobal', Message ) 3984 END IF 3985 3986 IF( SIZE( Variable % Values ) > 1 ) THEN 3987 IsGlobal = .FALSE. 3988 RETURN 3989 END IF 3990 3991 ELSE 3992 IsGlobal = .FALSE. 3993 EXIT 3994 END IF 3995 3996 l0 = l1+2 3997 IF ( l0 > slen ) EXIT 3998 END DO 3999 ELSE 4000 IsGlobal = .FALSE. 4001 END IF 4002 END IF 4003 4004 4005!------------------------------------------------------------------------------ 4006 END FUNCTION ListCheckGlobal 4007!------------------------------------------------------------------------------ 4008 4009 4010 4011!------------------------------------------------------------------------------ 4012 FUNCTION ListCheckAllGlobal( List, name ) RESULT ( AllGlobal ) 4013!------------------------------------------------------------------------------ 4014 TYPE(ValueList_t), POINTER :: List 4015 CHARACTER(LEN=*) :: name 4016 LOGICAL :: AllGlobal 4017!------------------------------------------------------------------------------ 4018 TYPE(ValueListEntry_t), POINTER :: ptr 4019 TYPE(Element_t), POINTER :: Element 4020 INTEGER :: ind,i,j,k,n,k1,l,l0,l1 4021 TYPE(Variable_t), POINTER :: Variable, CVar 4022 INTEGER :: slen 4023 4024 AllGlobal = .TRUE. 4025 4026 IF(.NOT.ASSOCIATED(List)) RETURN 4027 4028 ptr => List % Head 4029 IF(.NOT.ASSOCIATED(ptr)) RETURN 4030 4031 AllGlobal = ListCheckGlobal( ptr ) 4032 4033!------------------------------------------------------------------------------ 4034 END FUNCTION ListCheckAllGlobal 4035!------------------------------------------------------------------------------ 4036 4037 4038 4039 4040!------------------------------------------------------------------------------ 4041!> Gets a real valued parameter in each node of an element. 4042!------------------------------------------------------------------------------ 4043 RECURSIVE FUNCTION ListGetReal( List,Name,N,NodeIndexes,Found,minv,maxv,UnfoundFatal ) RESULT(F) 4044!------------------------------------------------------------------------------ 4045 TYPE(ValueList_t), POINTER :: List 4046 CHARACTER(LEN=*) :: Name 4047 INTEGER :: N,NodeIndexes(:) 4048 REAL(KIND=dp) :: F(N) 4049 LOGICAL, OPTIONAL :: Found, UnfoundFatal 4050 REAL(KIND=dp), OPTIONAL :: minv,maxv 4051!------------------------------------------------------------------------------ 4052 TYPE(Variable_t), POINTER :: Variable, CVar, TVar 4053 TYPE(ValueListEntry_t), POINTER :: ptr 4054 REAL(KIND=dp) :: T(MAX_FNC) 4055 TYPE(VariableTable_t) :: VarTable(MAX_FNC) 4056 INTEGER :: i,j,k,k1,l,l0,l1,lsize, VarCount 4057 CHARACTER(LEN=MAX_NAME_LEN) :: cmd, tmp_str 4058 LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes 4059 ! INTEGER :: TID, OMP_GET_THREAD_NUM 4060!------------------------------------------------------------------------------ 4061 ! TID = 0 4062 ! !$ TID=OMP_GET_THREAD_NUM() 4063 F = 0.0_dp 4064 ptr => ListFind(List,Name,Found) 4065 IF (.NOT.ASSOCIATED(ptr) ) THEN 4066 IF(PRESENT(UnfoundFatal)) THEN 4067 IF(UnfoundFatal) THEN 4068 WRITE(Message, '(A,A)') "Failed to find real: ",Name 4069 CALL Fatal("ListGetReal", Message) 4070 END IF 4071 END IF 4072 RETURN 4073 END IF 4074 4075 SELECT CASE(ptr % TYPE) 4076 4077 CASE( LIST_TYPE_CONSTANT_SCALAR ) 4078 4079 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 4080 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 4081 '] not used consistently.' 4082 CALL Fatal( 'ListGetReal', Message ) 4083 RETURN 4084 END IF 4085 F = ptr % Coeff * ptr % Fvalues(1,1,1) 4086 4087 4088 CASE( LIST_TYPE_VARIABLE_SCALAR ) 4089 4090 CALL ListPushActiveName(Name) 4091 4092 CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, VarTable, & 4093 SomeAtIp, SomeAtNodes, AllGlobal ) 4094 IF( SomeAtIp ) THEN 4095 CALL Fatal('ListGetReal','Function cannot deal with variables on IPs!') 4096 END IF 4097 4098 DO i=1,n 4099 k = NodeIndexes(i) 4100 4101 CALL VarsToValuesOnNodes( VarCount, VarTable, k, T, j ) 4102 4103 IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN 4104 IF ( ptr % PROCEDURE /= 0 ) THEN 4105 F(i) = ptr % Coeff * & 4106 ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T ) 4107 ELSE 4108 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 4109 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 4110 '] not used consistently.' 4111 CALL Fatal( 'ListGetReal', Message ) 4112 RETURN 4113 END IF 4114 F(i) = ptr % Coeff * & 4115 InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), & 4116 T(1), ptr % CubicCoeff ) 4117 IF( AllGlobal) THEN 4118 F(2:n) = F(1) 4119 EXIT 4120 END IF 4121 END IF 4122 END IF 4123 END DO 4124 CALL ListPopActiveName() 4125 4126 4127 CASE( LIST_TYPE_CONSTANT_SCALAR_STR ) 4128 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 4129 WRITE( cmd, '(a,e15.8)' ) 'st = ', TVar % Values(1) 4130 k = LEN_TRIM(cmd) 4131 CALL matc( cmd, tmp_str, k ) 4132 4133 cmd = ptr % CValue 4134 k = LEN_TRIM(cmd) 4135 CALL matc( cmd, tmp_str, k ) 4136 READ( tmp_str(1:k), * ) F(1) 4137 F(1) = ptr % Coeff * F(1) 4138 F(2:n) = F(1) 4139 4140 CASE( LIST_TYPE_VARIABLE_SCALAR_STR ) 4141 4142 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 4143 WRITE( cmd, * ) 'tx=0; st = ', TVar % Values(1) 4144 k = LEN_TRIM(cmd) 4145 CALL matc( cmd, tmp_str, k ) 4146 4147 CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, Name, VarCount, & 4148 VarTable, SomeAtIp, SomeAtNodes, AllGlobal ) 4149 IF( SomeAtIp ) THEN 4150 CALL Fatal('ListGetReal','Function cannot deal with variables on IPs!') 4151 END IF 4152 4153 4154 DO i=1,n 4155 k = NodeIndexes(i) 4156 4157 CALL VarsToValuesOnNodes( VarCount, VarTable, k, T, j ) 4158 4159#ifdef HAVE_LUA 4160 IF ( .NOT. ptr % LuaFun ) THEN 4161#endif 4162 IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN 4163 DO l=1,j 4164 WRITE( cmd, * ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 4165 k1 = LEN_TRIM(cmd) 4166 CALL matc( cmd, tmp_str, k1 ) 4167 END DO 4168 4169 cmd = ptr % CValue 4170 k1 = LEN_TRIM(cmd) 4171 CALL matc( cmd, tmp_str, k1 ) 4172 READ( tmp_str(1:k1), * ) F(i) 4173 F(i) = Ptr % Coeff * F(i) 4174 END IF 4175 4176#ifdef HAVE_LUA 4177 ELSE 4178 CALL ElmerEvalLua(LuaState, ptr, T, F(i), j ) 4179 END IF 4180#endif 4181 IF( AllGlobal ) THEN 4182 F(2:n) = F(1) 4183 EXIT 4184 END IF 4185 4186 END DO 4187 4188 CASE( LIST_TYPE_CONSTANT_SCALAR_PROC ) 4189 4190 IF ( ptr % PROCEDURE == 0 ) THEN 4191 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 4192 '] not used consistently.' 4193 CALL Fatal( 'ListGetReal', Message ) 4194 RETURN 4195 END IF 4196 4197 CALL ListPushActiveName(name) 4198 DO i=1,n 4199 F(i) = Ptr % Coeff * & 4200 ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, & 4201 CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), & 4202 CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), & 4203 CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) ) 4204 END DO 4205 CALL ListPopActiveName() 4206 4207 END SELECT 4208 4209 IF ( PRESENT( minv ) ) THEN 4210 IF ( MINVAL(F(1:n)) < minv ) THEN 4211 WRITE( Message,*) 'Given VALUE ', MINVAL(F(1:n)), ' for property: ', '[', TRIM(Name),']', & 4212 ' smaller than given minimum: ', minv 4213 CALL Fatal( 'ListGetReal', Message ) 4214 END IF 4215 END IF 4216 4217 IF ( PRESENT( maxv ) ) THEN 4218 IF ( MAXVAL(F(1:n)) > maxv ) THEN 4219 WRITE( Message,*) 'Given VALUE ', MAXVAL(F(1:n)), ' for property: ', '[', TRIM(Name),']', & 4220 ' larger than given maximum ', maxv 4221 CALL Fatal( 'ListGetReal', Message ) 4222 END IF 4223 END IF 4224 END FUNCTION ListGetReal 4225!------------------------------------------------------------------------------ 4226 4227 4228 4229!------------------------------------------------------------------------------ 4230!> Gets a real valued parameter in one single point with value x. 4231!> Optionally also computes the derivative at that point. 4232!> Note that this uses same logical on sif file as ListGetReal 4233!> but the variable is just a dummy as the dependent function is 4234!> assumed to be set inside the code. This should be used with caution 4235!> is it sets some confusing limitations to the user. The main limitation 4236!> is the use of just one dependent variable. 4237!------------------------------------------------------------------------------ 4238 RECURSIVE FUNCTION ListGetFun( List,Name,x,Found,minv,maxv,dFdx,eps ) RESULT(F) 4239!------------------------------------------------------------------------------ 4240 TYPE(ValueList_t), POINTER :: List 4241 REAL(KIND=dp), OPTIONAL :: x 4242 REAL(KIND=dp) :: f 4243 CHARACTER(LEN=*), OPTIONAL :: Name 4244 LOGICAL, OPTIONAL :: Found 4245 REAL(KIND=dp), OPTIONAL :: minv,maxv 4246 REAL(KIND=dp), OPTIONAL :: dFdx, eps 4247!------------------------------------------------------------------------------ 4248 TYPE(Variable_t), POINTER :: Variable, CVar, TVar 4249 TYPE(ValueListEntry_t), POINTER :: ptr 4250 REAL(KIND=dp) :: T(1) 4251 INTEGER :: i,j,k,k1,l,l0,l1,lsize 4252 CHARACTER(LEN=MAX_NAME_LEN) :: cmd, tmp_str 4253 LOGICAL :: AllGlobal 4254 REAL(KIND=dp) :: xeps, F2, F1 4255!------------------------------------------------------------------------------ 4256 4257 F = 0.0_dp 4258 IF( PRESENT( Name ) ) THEN 4259 ptr => ListFind(List,Name,Found) 4260 IF ( .NOT.ASSOCIATED(ptr) ) RETURN 4261 ELSE 4262 IF(.NOT.ASSOCIATED(List)) RETURN 4263 ptr => List % Head 4264 IF ( .NOT.ASSOCIATED(ptr) ) THEN 4265 CALL Warn('ListGetFun','List entry not associated') 4266 RETURN 4267 END IF 4268 END IF 4269 4270 ! Node number not applicable, hence set to zero 4271 k = 0 4272 T(1) = x 4273 4274 SELECT CASE(ptr % TYPE) 4275 4276 CASE( LIST_TYPE_CONSTANT_SCALAR ) 4277 4278 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 4279 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 4280 '] not used consistently.' 4281 CALL Fatal( 'ListGetReal', Message ) 4282 RETURN 4283 END IF 4284 F = ptr % Coeff * ptr % Fvalues(1,1,1) 4285 IF( PRESENT( dFdx ) ) THEN 4286 dFdx = 0.0_dp 4287 END IF 4288 4289 4290 CASE( LIST_TYPE_VARIABLE_SCALAR ) 4291 4292 IF ( ptr % PROCEDURE /= 0 ) THEN 4293 CALL ListPushActiveName(name) 4294 F = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) ) 4295 4296 ! Compute derivative at the point if requested 4297 ! Numerical central difference scheme is used for accuracy. 4298 IF( PRESENT( dFdx ) ) THEN 4299 IF( PRESENT( eps ) ) THEN 4300 xeps = eps 4301 ELSE 4302 xeps = 1.0d-8 4303 END IF 4304 T(1) = x - xeps 4305 F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) ) 4306 T(1) = x + xeps 4307 F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, k, T(1) ) 4308 dFdx = ( F2 - F1 ) / (2*xeps) 4309 END IF 4310 CALL ListPopActiveName() 4311 ELSE 4312 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 4313 WRITE(Message,*) 'VALUE TYPE for property [', TRIM(Name), & 4314 '] not used consistently.' 4315 CALL Fatal( 'ListGetFun', Message ) 4316 RETURN 4317 END IF 4318 F = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), & 4319 x, ptr % CubicCoeff ) 4320 ! Compute the derivative symbolically from the table values. 4321 IF( PRESENT( dFdx ) ) THEN 4322 dFdx = DerivateCurve(ptr % TValues,ptr % FValues(1,1,:), & 4323 x, ptr % CubicCoeff ) 4324 END IF 4325 END IF 4326 4327 4328 CASE( LIST_TYPE_VARIABLE_SCALAR_STR ) 4329 WRITE( cmd, * ) 'tx=', X 4330 k1 = LEN_TRIM(cmd) 4331 CALL matc( cmd, tmp_str, k1 ) 4332 4333 cmd = ptr % CValue 4334 k1 = LEN_TRIM(cmd) 4335 CALL matc( cmd, tmp_str, k1 ) 4336 READ( tmp_str(1:k1), * ) F 4337 4338 ! This is really expensive. 4339 ! For speed also one sided difference could be considered. 4340 IF( PRESENT( dFdx ) ) THEN 4341 IF( PRESENT( eps ) ) THEN 4342 xeps = eps 4343 ELSE 4344 xeps = 1.0d-8 4345 END IF 4346 4347 WRITE( cmd, * ) 'tx=', x-xeps 4348 k1 = LEN_TRIM(cmd) 4349 CALL matc( cmd, tmp_str, k1 ) 4350 4351 cmd = ptr % CValue 4352 k1 = LEN_TRIM(cmd) 4353 CALL matc( cmd, tmp_str, k1 ) 4354 READ( tmp_str(1:k1), * ) F1 4355 4356 WRITE( cmd, * ) 'tx=', x+xeps 4357 k1 = LEN_TRIM(cmd) 4358 CALL matc( cmd, tmp_str, k1 ) 4359 4360 cmd = ptr % CValue 4361 k1 = LEN_TRIM(cmd) 4362 CALL matc( cmd, tmp_str, k1 ) 4363 READ( tmp_str(1:k1), * ) F2 4364 4365 dFdx = (F2-F1) / (2*xeps) 4366 END IF 4367 4368 CASE DEFAULT 4369 CALL Fatal('ListGetFun','LIST_TYPE not implemented!') 4370 4371 END SELECT 4372 4373 IF ( PRESENT( minv ) ) THEN 4374 IF ( F < minv ) THEN 4375 WRITE( Message,*) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', & 4376 ' smaller than given minimum: ', minv 4377 CALL Fatal( 'ListGetFun', Message ) 4378 END IF 4379 END IF 4380 4381 IF ( PRESENT( maxv ) ) THEN 4382 IF ( F > maxv ) THEN 4383 WRITE( Message,*) 'Given VALUE ', F, ' for property: ', '[', TRIM(Name),']', & 4384 ' larger than given maximum ', maxv 4385 CALL Fatal( 'ListGetFun', Message ) 4386 END IF 4387 END IF 4388 4389 END FUNCTION ListGetFun 4390!------------------------------------------------------------------------------ 4391 4392 RECURSIVE SUBROUTINE ListInitHandle( Handle ) 4393 4394 TYPE(ValueHandle_t) :: Handle 4395 4396 Handle % ValueType = -1 4397 Handle % SectionType = -1 4398 Handle % ListId = -1 4399 Handle % Element => NULL() 4400 Handle % List => NULL() 4401 Handle % Ptr => NULL() 4402 Handle % Nodes => NULL() 4403 Handle % Indexes => NULL() 4404 Handle % nValuesVec = 0 4405 Handle % ValuesVec => NULL() 4406 Handle % Values => NULL() 4407 Handle % ParValues => NULL() 4408 Handle % ParNo = 0 4409 Handle % DefIValue = 0 4410 Handle % DefRValue = 0.0_dp 4411 Handle % Rdim = 0 4412 Handle % RTensor => NULL() 4413 Handle % RTensorValues => NULL() 4414 Handle % DefLValue = .FALSE. 4415 Handle % Initialized = .FALSE. 4416 Handle % AllocationsDone = .FALSE. 4417 Handle % ConstantEverywhere = .FALSE. 4418 Handle % GlobalEverywhere = .FALSE. 4419 Handle % GlobalInList = .FALSE. 4420 Handle % EvaluateAtIP = .FALSE. 4421 Handle % SomeVarAtIp = .FALSE. 4422 Handle % SomewhereEvaluateAtIP = .FALSE. 4423 Handle % NotPresentAnywhere = .FALSE. 4424 Handle % UnfoundFatal = .FALSE. 4425 Handle % GotMinv = .FALSE. 4426 Handle % GotMaxv = .FALSE. 4427 Handle % VarCount = 0 4428 Handle % HandleIm => NULL() 4429 Handle % Handle2 => NULL() 4430 Handle % Handle3 => NULL() 4431 4432 END SUBROUTINE ListInitHandle 4433 4434 4435!------------------------------------------------------------------------------ 4436!> Initializes the handle to save just a little bit for constant valued. 4437!> This is not mandatory but may still be used. 4438!------------------------------------------------------------------------------ 4439 RECURSIVE SUBROUTINE ListInitElementKeyword( Handle,Section,Name,minv,maxv,& 4440 DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,& 4441 FoundSomewhere,InitIm,InitVec3D) 4442!------------------------------------------------------------------------------ 4443 TYPE(ValueHandle_t) :: Handle 4444 CHARACTER(LEN=*) :: Section,Name 4445 REAL(KIND=dp), OPTIONAL :: minv,maxv 4446 REAL(KIND=dp), OPTIONAL :: DefRValue 4447 INTEGER, OPTIONAL :: DefIValue 4448 LOGICAL, OPTIONAL :: DefLValue 4449 LOGICAL, OPTIONAL :: UnfoundFatal 4450 LOGICAL, OPTIONAL :: EvaluateAtIp 4451 LOGICAL, OPTIONAL :: FoundSomewhere 4452 LOGICAL, OPTIONAL :: InitIm 4453 LOGICAL, OPTIONAL :: InitVec3D 4454 !------------------------------------------------------------------------------ 4455 TYPE(ValueList_t), POINTER :: List 4456 TYPE(ValueListEntry_t), POINTER :: ptr 4457 INTEGER :: i, n, NoVal, ValueType, IValue, dim, n1, n2, maxn1, maxn2 4458 TYPE(Model_t), POINTER :: Model 4459 REAL(KIND=dp) :: val, Rvalue 4460 CHARACTER(LEN=MAX_NAME_LEN) :: CValue 4461 LOGICAL :: ConstantEverywhere, NotPresentAnywhere, Lvalue, FirstList, Found 4462 REAL(KIND=dp), POINTER :: Basis(:) 4463 INTEGER, POINTER :: NodeIndexes(:) 4464 TYPE(Element_t), POINTER :: Element 4465 LOGICAL :: GotIt, FoundSomewhere1, FoundSomewhere2 4466 !------------------------------------------------------------------------------ 4467 4468 IF( PRESENT( InitIm ) ) THEN 4469 IF( InitIm ) THEN 4470 IF( .NOT. ASSOCIATED( Handle % HandleIm ) ) THEN 4471 ALLOCATE( Handle % HandleIm ) 4472 CALL ListInitHandle( Handle % HandleIm ) 4473 END IF 4474 CALL Info('ListInitElementKeyword','Treating real part of keyword',Level=15) 4475 CALL ListInitElementKeyword( Handle,Section,Name,minv,maxv,& 4476 DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere,InitVec3D=InitVec3D) 4477 IF( PRESENT( FoundSomewhere) ) FoundSomewhere1 = FoundSomewhere 4478 4479 CALL Info('ListInitElementKeyword','Treating imaginary part of keyword',Level=15) 4480 CALL ListInitElementKeyword( Handle % HandleIm,Section,TRIM(Name)//' im',minv,maxv,& 4481 DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere,InitVec3D=InitVec3D) 4482 IF( PRESENT( FoundSomewhere ) ) FoundSomewhere = FoundSomewhere .OR. FoundSomewhere1 4483 RETURN 4484 END IF 4485 END IF 4486 4487 IF( PRESENT( InitVec3D ) ) THEN 4488 IF( InitVec3D ) THEN 4489 IF( .NOT. ASSOCIATED( Handle % Handle2 ) ) THEN 4490 ALLOCATE( Handle % Handle2 ) 4491 CALL ListInitHandle( Handle % Handle2 ) 4492 END IF 4493 IF( .NOT. ASSOCIATED( Handle % Handle3 ) ) THEN 4494 ALLOCATE( Handle % Handle3 ) 4495 CALL ListInitHandle( Handle % Handle3 ) 4496 END IF 4497 4498 CALL ListInitElementKeyword( Handle,Section,TRIM(Name)//' 1',minv,maxv,& 4499 DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere) 4500 IF( PRESENT( FoundSomewhere) ) FoundSomewhere1 = FoundSomewhere 4501 CALL ListInitElementKeyword( Handle % Handle2,Section,TRIM(Name)//' 2',minv,maxv,& 4502 DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere) 4503 IF( PRESENT( FoundSomewhere) ) FoundSomewhere2 = FoundSomewhere 4504 CALL ListInitElementKeyword( Handle % Handle3,Section,TRIM(Name)//' 3',minv,maxv,& 4505 DefRValue,DefIValue,DefLValue,UnfoundFatal,EvaluateAtIp,FoundSomewhere) 4506 IF( PRESENT( FoundSomewhere ) ) FoundSomewhere = FoundSomewhere .OR. & 4507 FoundSomewhere1 .OR. FoundSomewhere2 4508 RETURN 4509 END IF 4510 END IF 4511 4512 CALL Info('ListInitElementKeyword','Treating keyword: '//TRIM(Name),Level=12) 4513 4514 Model => CurrentModel 4515 Handle % BulkElement = .TRUE. 4516 NULLIFY(ptr) 4517 4518 SELECT CASE ( Section ) 4519 4520 CASE('Body') 4521 Handle % SectionType = SECTION_TYPE_BODY 4522 4523 CASE('Material') 4524 Handle % SectionType = SECTION_TYPE_MATERIAL 4525 4526 CASE('Body Force') 4527 Handle % SectionType = SECTION_TYPE_BF 4528 4529 CASE('Initial Condition') 4530 Handle % SectionType = SECTION_TYPE_IC 4531 4532 CASE('Boundary Condition') 4533 Handle % SectionType = SECTION_TYPE_BC 4534 Handle % BulkElement = .FALSE. 4535 4536 CASE('Component') 4537 Handle % SectionType = SECTION_TYPE_COMPONENT 4538 4539 CASE('Equation') 4540 Handle % SectionType = SECTION_TYPE_EQUATION 4541 4542 CASE DEFAULT 4543 CALL Fatal('ListInitElementKeyword','Unknown section: '//TRIM(Section)) 4544 4545 END SELECT 4546 4547 4548 ! Initialize the handle entries because it may be that the list structure was altered, 4549 ! or the same handle is used for different keyword. 4550 Handle % ConstantEverywhere = .TRUE. 4551 Handle % GlobalInList = .FALSE. 4552 Handle % NotPresentAnywhere = .TRUE. 4553 Handle % SomewhereEvaluateAtIP = .FALSE. 4554 Handle % GlobalEverywhere = .TRUE. 4555 Handle % SomeVarAtIp = .FALSE. 4556 Handle % Name = Name 4557 Handle % ListId = -1 4558 Handle % EvaluateAtIp = .FALSE. 4559 Handle % List => NULL() 4560 Handle % Element => NULL() 4561 Handle % Unfoundfatal = .FALSE. 4562 IF (.NOT. ASSOCIATED( Ptr ) ) THEN 4563 Handle % Ptr => ListAllocate() 4564 END IF 4565 4566 4567 ! Deallocate stuff that may change in size, or is used as a marker for first element 4568 IF( Handle % nValuesVec > 0 ) THEN 4569 DEALLOCATE( Handle % ValuesVec ) 4570 Handle % nValuesVec = 0 4571 END IF 4572 4573 4574 Handle % Initialized = .TRUE. 4575 4576 FirstList = .TRUE. 4577 maxn1 = 0 4578 maxn2 = 0 4579 4580 i = 0 4581 DO WHILE(.TRUE.) 4582 i = i + 1 4583 4584 SELECT CASE ( Handle % SectionType ) 4585 4586 CASE( SECTION_TYPE_BODY ) 4587 IF(i > Model % NumberOfBodies ) EXIT 4588 List => Model % Bodies(i) % Values 4589 4590 CASE( SECTION_TYPE_MATERIAL ) 4591 IF(i > Model % NumberOfMaterials ) EXIT 4592 List => Model % Materials(i) % Values 4593 4594 CASE( SECTION_TYPE_BF ) 4595 IF(i > Model % NumberOfBodyForces ) EXIT 4596 List => Model % BodyForces(i) % Values 4597 4598 CASE( SECTION_TYPE_IC ) 4599 IF( i > Model % NumberOfICs ) EXIT 4600 List => Model % ICs(i) % Values 4601 4602 CASE( SECTION_TYPE_EQUATION ) 4603 IF( i > Model % NumberOfEquations ) EXIT 4604 List => Model % Equations(i) % Values 4605 4606 CASE( SECTION_TYPE_BC ) 4607 IF( i > Model % NumberOfBCs ) EXIT 4608 List => Model % BCs(i) % Values 4609 4610 ! It is more difficult to make sure that the BC list is given for all BC elements. 4611 ! Therefore set this to .FALSE. always for BCs. 4612 Handle % ConstantEverywhere = .FALSE. 4613 4614 CASE DEFAULT 4615 CALL Fatal('ListInitElementKeyword','Unknown section: '//TRIM(I2S(Handle % SectionType))) 4616 4617 END SELECT 4618 4619 ! If the parameter is not defined in some list we cannot really be sure 4620 ! that it is intentionally used as a zero. Hence we cannot assume that the 4621 ! keyword is constant. 4622 ptr => ListFind(List,Name,Found) 4623 Handle % ptr % Head => ptr 4624 4625 IF ( .NOT. ASSOCIATED(ptr) ) THEN 4626 Handle % ConstantEverywhere = .FALSE. 4627 CYCLE 4628 ELSE IF( FirstList ) THEN 4629 Handle % NotPresentAnywhere = .FALSE. 4630 Handle % ValueType = ptr % Type 4631 END IF 4632 4633 ValueType = ptr % TYPE 4634 4635 IF( ValueType == LIST_TYPE_LOGICAL ) THEN 4636 Lvalue = ptr % Lvalue 4637 4638 IF( FirstList ) THEN 4639 Handle % LValue = LValue 4640 ELSE 4641 IF( XOR( Handle % LValue, LValue ) ) THEN 4642 Handle % ConstantEverywhere = .FALSE. 4643 EXIT 4644 END IF 4645 END IF 4646 4647 ELSE IF( ValueType == LIST_TYPE_STRING ) THEN 4648 Cvalue = ptr % Cvalue 4649 IF( FirstList ) THEN 4650 Handle % CValueLen = len_trim(CValue) 4651 Handle % CValue = CValue(1:Handle % CValueLen) 4652 ELSE IF( Handle % CValue(1:Handle % CValueLen) /= Cvalue ) THEN 4653 Handle % ConstantEverywhere = .FALSE. 4654 EXIT 4655 END IF 4656 4657 ELSE IF( ValueType == LIST_TYPE_INTEGER ) THEN 4658 Ivalue = ptr % Ivalues(1) 4659 IF( FirstList ) THEN 4660 Handle % IValue = Ivalue 4661 ELSE IF( Handle % IValue /= Ivalue ) THEN 4662 Handle % ConstantEverywhere = .FALSE. 4663 EXIT 4664 END IF 4665 4666 ELSE IF( ValueType >= LIST_TYPE_CONSTANT_SCALAR .AND. & 4667 ValueType <= List_TYPE_CONSTANT_SCALAR_PROC ) THEN 4668 4669 IF(.NOT. ListCheckAllGlobal( Handle % ptr, name ) ) THEN 4670 Handle % GlobalEverywhere = .FALSE. 4671 Handle % ConstantEverywhere = .FALSE. 4672 IF( ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) ) THEN 4673 Handle % SomewhereEvaluateAtIp = .TRUE. 4674 EXIT 4675 END IF 4676 END IF 4677 4678 IF( Handle % ConstantEverywhere ) THEN 4679 Rvalue = ListGetCReal( List,Name) 4680 ! and each list must have the same constant value 4681 IF( FirstList ) THEN 4682 Handle % RValue = Rvalue 4683 ELSE IF( ABS( Handle % RValue - Rvalue ) > TINY( RValue ) ) THEN 4684 Handle % ConstantEverywhere = .FALSE. 4685 END IF 4686 END IF 4687 4688 ELSE IF( ValueType >= LIST_TYPE_CONSTANT_TENSOR .AND. & 4689 ValueType <= LIST_TYPE_VARIABLE_TENSOR_STR ) THEN 4690 4691 Handle % GlobalEverywhere = .FALSE. 4692 Handle % ConstantEverywhere = .FALSE. 4693 IF( ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) ) THEN 4694 Handle % SomewhereEvaluateAtIp = .TRUE. 4695 END IF 4696 4697 n1 = SIZE( ptr % FValues,1 ) 4698 n2 = SIZE( ptr % FValues,2 ) 4699 4700 maxn1 = MAX( n1, maxn1 ) 4701 maxn2 = MAX( n2, maxn2 ) 4702 ELSE 4703 CALL Fatal('ListInitElementKeyword','Unknown value type: '//TRIM(I2S(ValueType))) 4704 4705 END IF 4706 4707 FirstList = .FALSE. 4708 END DO 4709 4710 CALL Info('ListInitElementKeyword',& 4711 'Initiated handle for: > '//TRIM(Handle % Name)//' < of type: '// & 4712 TRIM(I2S(Handle % ValueType)),Level=12) 4713 4714 IF( PRESENT( UnfoundFatal ) ) THEN 4715 Handle % Unfoundfatal = UnfoundFatal 4716 IF( Handle % UnfoundFatal .AND. Handle % NotPresentAnywhere ) THEN 4717 CALL Fatal('ListInitElementKeywords','Keyword required but not present: '& 4718 //TRIM(Handle % Name)) 4719 END IF 4720 END IF 4721 4722 IF( PRESENT( DefLValue ) ) THEN 4723 Handle % DefLValue = DefLValue 4724 END IF 4725 4726 IF( PRESENT( DefRValue ) ) THEN 4727 Handle % DefRValue = DefRValue 4728 END IF 4729 4730 IF( PRESENT( DefIValue ) ) THEN 4731 Handle % DefIValue = DefIValue 4732 END IF 4733 4734 IF( PRESENT( minv ) ) THEN 4735 Handle % GotMinv = .TRUE. 4736 Handle % minv = minv 4737 END IF 4738 4739 IF( PRESENT( maxv ) ) THEN 4740 Handle % GotMaxv = .TRUE. 4741 Handle % maxv = maxv 4742 END IF 4743 4744 IF( PRESENT( EvaluateAtIp ) ) THEN 4745 Handle % EvaluateAtIp = EvaluateAtIp 4746 END IF 4747 4748 IF( PRESENT( FoundSomewhere ) ) THEN 4749 FoundSomewhere = .NOT. Handle % NotPresentAnywhere 4750 END IF 4751 4752 ! For tensor valued ListGetRealElement operations allocate the maximum size 4753 ! of temporal table needed. 4754 IF( maxn1 > 1 .OR. maxn2 > 1 ) THEN 4755 n = CurrentModel % Mesh % MaxElementNodes 4756 IF( ASSOCIATED( Handle % RtensorValues ) ) THEN 4757 IF( SIZE( Handle % RtensorValues, 1 ) < maxn1 .OR. & 4758 SIZE( Handle % RtensorValues, 2 ) < maxn2 .OR. & 4759 SIZE( Handle % RtensorValues, 3 ) < n ) THEN 4760 DEALLOCATE( Handle % RtensorValues ) 4761 END IF 4762 END IF 4763 IF(.NOT. ASSOCIATED( Handle % RtensorValues ) ) THEN 4764 ALLOCATE( Handle % RtensorValues(maxn1,maxn2,n) ) 4765 END IF 4766 END IF 4767 4768 END SUBROUTINE ListInitElementKeyword 4769!------------------------------------------------------------------------------ 4770 4771 4772 4773!------------------------------------------------------------------------------ 4774!> Given a pointer to the element and the correct handle for the keyword find 4775!> the list where the keyword valued should be found in. 4776!------------------------------------------------------------------------------ 4777 FUNCTION ElementHandleList( Element, Handle, ListSame, ListFound ) RESULT( List ) 4778 4779 TYPE(Element_t), POINTER :: Element 4780 TYPE(ValueHandle_t) :: Handle 4781 TYPE(ValueList_t), POINTER :: List 4782 LOGICAL :: ListSame, ListFound 4783!------------------------------------------------------------------------------ 4784 INTEGER :: ListId, id 4785 4786 List => NULL() 4787 4788 ListSame = .FALSE. 4789 ListFound = .FALSE. 4790 4791 4792 ! We are looking for the same element as previous time 4793 IF( ASSOCIATED( Element, Handle % Element ) ) THEN 4794 ListSame = .TRUE. 4795 List => Handle % List 4796 RETURN 4797 END IF 4798 4799 ! Ok, not the same element, get the index that determines the list 4800 IF( Handle % BulkElement ) THEN 4801 ListId = Element % BodyId 4802 ELSE 4803 ListId = 0 4804 IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN 4805 ListId = Element % BoundaryInfo % Constraint 4806 END IF 4807 END IF 4808 4809 ! We are looking at the same list as previous time 4810 IF( Handle % ListId == ListId ) THEN 4811 ListSame = .TRUE. 4812 List => Handle % List 4813 RETURN 4814 ELSE 4815 Handle % ListId = ListId 4816 IF( ListId <= 0 ) RETURN 4817 END IF 4818 4819 ! Ok, we cannot use previous list, lets find the new list 4820 SELECT CASE ( Handle % SectionType ) 4821 4822 CASE( SECTION_TYPE_BODY ) 4823 List => CurrentModel % Bodies(ListId) % Values 4824 ListFound = .TRUE. 4825 4826 CASE( SECTION_TYPE_BF ) 4827 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4828 'Body Force', ListFound ) 4829 IF( ListFound ) List => CurrentModel % BodyForces(id) % Values 4830 4831 CASE( SECTION_TYPE_IC ) 4832 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4833 'Initial Condition', ListFound ) 4834 IF(ListFound) List => CurrentModel % ICs(id) % Values 4835 4836 CASE( SECTION_TYPE_MATERIAL ) 4837 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4838 'Material', ListFound ) 4839 IF(ListFound) List => CurrentModel % Materials(id) % Values 4840 4841 CASE( SECTION_TYPE_EQUATION ) 4842 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4843 'Equation', ListFound ) 4844 IF(ListFound) List => CurrentModel % Equations(id) % Values 4845 4846 CASE( SECTION_TYPE_BC ) 4847 IF( ListId <= 0 .OR. ListId > CurrentModel % NumberOfBCs ) RETURN 4848 IF( CurrentModel % BCs(ListId) % Tag == ListId ) THEN 4849 List => CurrentModel % BCs(ListId) % Values 4850 ListFound = .TRUE. 4851 END IF 4852 4853 CASE( -1 ) 4854 CALL Fatal('ElementHandleList','Handle not initialized!') 4855 4856 CASE DEFAULT 4857 CALL Fatal('ElementHandleList','Unknown section type!') 4858 4859 END SELECT 4860 4861 IF( ListFound ) THEN 4862 ! We still have chance that this is the same list 4863 IF( ASSOCIATED( List, Handle % List ) ) THEN 4864 ListSame = .TRUE. 4865 ELSE 4866 Handle % List => List 4867 END IF 4868 ELSE 4869 Handle % List => NULL() 4870 END IF 4871 4872 END FUNCTION ElementHandleList 4873!------------------------------------------------------------------------------ 4874 4875!------------------------------------------------------------------------------ 4876!> Given an index related to the related to the correct section returns the correct 4877!> value list and a logical flag if there are no more. 4878!------------------------------------------------------------------------------ 4879 FUNCTION SectionHandleList( Handle, ListId, EndLoop ) RESULT( List ) 4880 4881 TYPE(ValueHandle_t) :: Handle 4882 TYPE(ValueList_t), POINTER :: List 4883 INTEGER :: ListId 4884 LOGICAL :: EndLoop 4885!------------------------------------------------------------------------------ 4886 LOGICAL :: Found 4887 INTEGER :: id 4888 4889 List => NULL() 4890 4891 IF( Handle % SectionType == SECTION_TYPE_BC ) THEN 4892 EndLoop = ( ListId <= 0 .OR. ListId > CurrentModel % NumberOfBCs ) 4893 ELSE 4894 EndLoop = ( ListId > CurrentModel % NumberOfBodies ) 4895 END IF 4896 IF( EndLoop ) RETURN 4897 4898 4899 SELECT CASE ( Handle % SectionType ) 4900 4901 CASE( SECTION_TYPE_BODY ) 4902 List => CurrentModel % Bodies(ListId) % Values 4903 4904 CASE( SECTION_TYPE_BF ) 4905 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4906 'Body Force', Found ) 4907 IF( Found ) List => CurrentModel % BodyForces(id) % Values 4908 4909 CASE( SECTION_TYPE_IC ) 4910 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4911 'Initial Condition', Found ) 4912 IF(Found) List => CurrentModel % ICs(id) % Values 4913 4914 CASE( SECTION_TYPE_MATERIAL ) 4915 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4916 'Material', Found ) 4917 IF(Found) List => CurrentModel % Materials(id) % Values 4918 4919 CASE( SECTION_TYPE_EQUATION ) 4920 id = ListGetInteger( CurrentModel % Bodies(ListId) % Values, & 4921 'Equation',Found ) 4922 IF(Found) List => CurrentModel % Equations(id) % Values 4923 4924 CASE( SECTION_TYPE_BC ) 4925 List => CurrentModel % BCs(ListId) % Values 4926 4927 CASE( -1 ) 4928 CALL Fatal('SectionHandleList','Handle not initialized!') 4929 4930 CASE DEFAULT 4931 CALL Fatal('SectionHandleList','Unknown section type!') 4932 4933 END SELECT 4934 4935 END FUNCTION SectionHandleList 4936!------------------------------------------------------------------------------ 4937 4938 4939 4940!------------------------------------------------------------------------------ 4941!> Compares a string valued parameter in elements and return True if they are the same. 4942!------------------------------------------------------------------------------ 4943 FUNCTION ListCompareElementAnyString( Handle, RefValue ) RESULT( Same ) 4944!------------------------------------------------------------------------------ 4945 TYPE(ValueHandle_t) :: Handle 4946 CHARACTER(LEN=*) :: RefValue 4947 LOGICAL :: Same 4948!------------------------------------------------------------------------------ 4949 CHARACTER(LEN=MAX_NAME_LEN) :: ThisValue 4950 TYPE(ValueList_t), POINTER :: List 4951 LOGICAL :: Found, EndLoop 4952 INTEGER :: id, n 4953!------------------------------------------------------------------------------ 4954 4955 Same = .FALSE. 4956 4957 ! If value is not present anywhere then return False 4958 IF( Handle % NotPresentAnywhere ) RETURN 4959 4960 id = 0 4961 DO WHILE (.TRUE.) 4962 id = id + 1 4963 List => SectionHandleList( Handle, id, EndLoop ) 4964 IF( EndLoop ) EXIT 4965 IF(.NOT. ASSOCIATED( List ) ) CYCLE 4966 4967 ThisValue = ListGetString( List, Handle % Name, Found ) 4968 IF( Found ) THEN 4969 n = len_TRIM(ThisValue) 4970 Same = ( ThisValue(1:n) == RefValue ) 4971 IF( Same ) EXIT 4972 END IF 4973 END DO 4974 4975 END FUNCTION ListCompareElementAnyString 4976!------------------------------------------------------------------------------ 4977 4978 4979!------------------------------------------------------------------------------ 4980!> Checks whether any of the logical flags has the desired logical value. 4981!------------------------------------------------------------------------------ 4982 FUNCTION ListCompareElementAnyLogical( Handle, RefValue ) RESULT( Same ) 4983!------------------------------------------------------------------------------ 4984 TYPE(ValueHandle_t) :: Handle 4985 LOGICAL :: RefValue 4986 LOGICAL :: Same 4987!------------------------------------------------------------------------------ 4988 LOGICAL :: ThisValue 4989 TYPE(ValueList_t), POINTER :: List 4990 LOGICAL :: Found, EndLoop 4991 INTEGER :: id, CValueLen 4992!------------------------------------------------------------------------------ 4993 4994 Same = .FALSE. 4995 4996 ! If value is not present anywhere then return False 4997 IF( Handle % NotPresentAnywhere ) RETURN 4998 4999 id = 0 5000 DO WHILE (.TRUE.) 5001 id = id + 1 5002 List => SectionHandleList( Handle, id, EndLoop ) 5003 IF( EndLoop ) EXIT 5004 IF(.NOT. ASSOCIATED( List ) ) CYCLE 5005 5006 ThisValue = ListGetLogical( List, Handle % Name, Found ) 5007 IF( Found ) THEN 5008 IF( ThisValue .AND. RefValue ) THEN 5009 Same = .TRUE. 5010 ELSE IF(.NOT. ThisValue .AND. .NOT. RefValue ) THEN 5011 Same = .TRUE. 5012 END IF 5013 IF( Same ) EXIT 5014 END IF 5015 END DO 5016 5017 END FUNCTION ListCompareElementAnyLogical 5018!------------------------------------------------------------------------------ 5019 5020 5021 5022 5023!------------------------------------------------------------------------------ 5024!> Get value of parameter from either of the parents. 5025!> If the value is found then the Left/Right parent is memorized internally. 5026!> Might not be economical if there are two keywords that toggle but usually 5027!> we just fetch one keyword from the parents. 5028!------------------------------------------------------------------------------ 5029 FUNCTION ListGetElementRealParent( Handle, Basis, Element, Found ) RESULT( RValue ) 5030 5031 TYPE(ValueHandle_t) :: Handle 5032 TYPE(Element_t), OPTIONAL, POINTER :: Element 5033 REAL(KIND=dp), OPTIONAL :: Basis(:) 5034 LOGICAL, OPTIONAL :: Found 5035 REAL(KIND=dp) :: RValue 5036 5037 LOGICAL :: IntFound 5038 LOGICAL :: lefttest = .TRUE. ! first start with left test 1st 5039 TYPE(Element_t), POINTER :: Parent, PElement 5040 5041 SAVE lefttest 5042 5043 ! Find the pointer to the element, if not given 5044 IF( PRESENT( Element ) ) THEN 5045 PElement => Element 5046 ELSE 5047 PElement => CurrentModel % CurrentElement 5048 END IF 5049 5050 IntFound = .FALSE. 5051 IF( lefttest) THEN 5052 Parent => PElement % BoundaryInfo % Left 5053 ELSE 5054 Parent => PElement % BoundaryInfo % Right 5055 END IF 5056 5057 RValue = ListGetElementReal( Handle, Basis, Parent, IntFound, PElement % NodeIndexes ) 5058 5059 ! If not found do the same thing with the other parent 5060 IF(.NOT. IntFound ) THEN 5061 IF( lefttest) THEN 5062 Parent => PElement % BoundaryInfo % Right 5063 ELSE 5064 Parent => PElement % BoundaryInfo % Left 5065 END IF 5066 RValue = ListGetElementReal( Handle, Basis, Parent, IntFound, PElement % NodeIndexes ) 5067 5068 ! reverse the order in which left and right parent are tested 5069 IF( IntFound ) lefttest = .NOT. lefttest 5070 END IF 5071 5072 IF( PRESENT( Found ) ) Found = IntFound 5073 5074 END FUNCTION ListGetElementRealParent 5075 5076 5077!------------------------------------------------------------------------------ 5078!> Gets a real valued parameter in the Gaussian integration point defined 5079!> by the local basis function. To speed up things there is a handle associated 5080!> to the given keyword (Name). Here the values are first evaluated at the 5081!> nodal points and then using basis functions estimated at the 5082!> gaussian integration points. 5083!------------------------------------------------------------------------------ 5084 FUNCTION ListGetElementReal( Handle,Basis,Element,Found,Indexes,& 5085 GaussPoint,Rdim,Rtensor) RESULT(Rvalue) 5086!------------------------------------------------------------------------------ 5087 TYPE(ValueHandle_t) :: Handle 5088 REAL(KIND=dp), OPTIONAL :: Basis(:) 5089 LOGICAL, OPTIONAL :: Found 5090 TYPE(Element_t), POINTER, OPTIONAL :: Element 5091 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5092 INTEGER, OPTIONAL :: GaussPoint 5093 INTEGER, OPTIONAL :: Rdim 5094 REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:) 5095 REAL(KIND=dp) :: Rvalue 5096!------------------------------------------------------------------------------ 5097 TYPE(ValueList_t), POINTER :: List 5098 TYPE(Variable_t), POINTER :: Variable, CVar, TVar 5099 TYPE(ValueListEntry_t), POINTER :: ptr 5100 INTEGER, POINTER :: NodeIndexes(:) 5101 REAL(KIND=dp) :: T(MAX_FNC),x,y,z 5102! TYPE(VariableTable_t), SAVE :: VarTable(MAX_FNC) 5103 REAL(KIND=dp), POINTER :: F(:) 5104 REAL(KIND=dp), POINTER :: ParF(:,:) 5105 INTEGER :: i,j,k,j2,k2,k1,l,l0,l1,lsize,n,bodyid,id,n1,n2 5106 CHARACTER(LEN=MAX_NAME_LEN) :: cmd, tmp_str 5107 LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes, ListSame, ListFound, GotIt, IntFound, & 5108 ElementSame 5109 TYPE(Element_t), POINTER :: PElement 5110#ifdef HAVE_LUA 5111 INTEGER :: lstat 5112#endif 5113!------------------------------------------------------------------------------ 5114 5115 ! If value is not present anywhere then return False 5116 IF( Handle % NotPresentAnywhere ) THEN 5117 IF(PRESENT(Found)) Found = .FALSE. 5118 Rvalue = Handle % DefRValue 5119 RETURN 5120 END IF 5121 5122 IF( PRESENT( Rdim ) ) Rdim = 0 5123 5124 ! If the value is known to be globally constant return it asap. 5125 IF( Handle % ConstantEverywhere ) THEN 5126 IF(PRESENT(Found)) Found = .TRUE. 5127 RValue = Handle % RValue 5128 RETURN 5129 END IF 5130 5131 ! Find the pointer to the element, if not given 5132 IF( PRESENT( Element ) ) THEN 5133 PElement => Element 5134 ELSE 5135 PElement => CurrentModel % CurrentElement 5136 END IF 5137 5138 5139 ! Set the default value 5140 Rvalue = Handle % DefRValue 5141 ElementSame = .FALSE. 5142 5143 5144 ! We know by initialization the list entry type that the keyword has 5145 ! Find the correct list to look the keyword in. 5146 ! Bulk and boundary elements are treated separately. 5147 List => ElementHandleList( PElement, Handle, ListSame, ListFound ) 5148 5149 ! If the provided list is the same as last time, also the keyword will 5150 ! be sitting at the same place, otherwise find it in the new list 5151 IF( ListSame ) THEN 5152 IF( PRESENT( Found ) ) Found = Handle % Found 5153 IF( .NOT. Handle % Found ) RETURN 5154 5155 IF( Handle % GlobalInList ) THEN 5156 IF( Handle % Rdim == 0 ) THEN 5157 Rvalue = Handle % Values(1) 5158 RETURN 5159 ELSE 5160 ! These have been checked already so they should exist 5161 Rdim = Handle % Rdim 5162 Rtensor => Handle % Rtensor 5163 RETURN 5164 END IF 5165 ELSE 5166 ptr => Handle % ptr % head 5167 END IF 5168 ELSE IF( ListFound ) THEN 5169 5170 ptr => ListFind(List,Handle % Name,IntFound ) 5171 IF(PRESENT(Found)) Found = IntFound 5172 Handle % Found = IntFound 5173 IF(.NOT. IntFound ) THEN 5174 IF( Handle % UnfoundFatal ) THEN 5175 CALL Fatal('ListGetElementReal','Could not find required keyword in list: '//TRIM(Handle % Name)) 5176 END IF 5177 RETURN 5178 END IF 5179 5180 Handle % Ptr % Head => ptr 5181 Handle % Rdim = ptr % Fdim 5182 5183 IF( Handle % Rdim > 0 ) THEN 5184 N1 = SIZE(ptr % FValues,1) 5185 N2 = SIZE(ptr % FValues,2) 5186 IF ( ASSOCIATED( Handle % Rtensor) ) THEN 5187 IF ( SIZE(Handle % Rtensor,1) /= N1 .OR. SIZE(Handle % Rtensor,2) /= N2 ) THEN 5188 DEALLOCATE( Handle % Rtensor ) 5189 END IF 5190 END IF 5191 IF(.NOT. ASSOCIATED( Handle % Rtensor) ) THEN 5192 ALLOCATE( Handle % Rtensor(N1,N2) ) 5193 END IF 5194 5195 IF( PRESENT( Rdim ) .AND. PRESENT( Rtensor ) ) THEN 5196 Rdim = Handle % Rdim 5197 Rtensor => Handle % Rtensor 5198 ELSE 5199 CALL Fatal('ListGetElementReal','For tensors Rdim and Rtensor should be present!') 5200 END IF 5201 END IF 5202 5203 ! It does not make sense to evaluate global variables at IP 5204 IF( Handle % SomewhereEvaluateAtIp ) THEN 5205 ! Check whether the keyword should be evaluated at integration point directly 5206 ! Only these dependency type may depend on position 5207 IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. & 5208 ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. & 5209 ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN 5210 Handle % EvaluateAtIP = ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) 5211 ELSE 5212 Handle % EvaluateAtIp = .FALSE. 5213 END IF 5214 END IF 5215 5216 IF( Ptr % DepNameLen > 0 ) THEN 5217 CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, & 5218 Handle % Name, Handle % VarCount, Handle % VarTable, & 5219 SomeAtIp, SomeAtNodes, AllGlobal ) 5220 5221 Handle % GlobalInList = ( AllGlobal .AND. ptr % PROCEDURE == 0 ) 5222 5223 ! If some input parameter is given at integration point 5224 ! we don't have any option other than evaluate things on IPs 5225 IF( SomeAtIP ) Handle % EvaluateAtIp = .TRUE. 5226 Handle % SomeVarAtIp = SomeAtIp 5227 5228 ! If all variables are global ondes we don't need to evaluate things on IPs 5229 IF( AllGlobal ) Handle % EvaluateAtIp = .FALSE. 5230 5231 ELSE 5232 Handle % GlobalInList = ( ptr % PROCEDURE == 0 ) 5233 END IF 5234 ELSE 5235 IF( Handle % UnfoundFatal ) THEN 5236 CALL Fatal('ListGetElementReal','Could not find list for required keyword: '//TRIM(Handle % Name)) 5237 END IF 5238 Rvalue = Handle % DefRValue 5239 5240 !Handle % Values(1) = RValue 5241 IF( PRESENT(Found) ) THEN 5242 Found = .FALSE. 5243 Handle % Found = .FALSE. 5244 END IF 5245 RETURN 5246 END IF 5247 5248 5249 5250 ! Either evaluate parameter directly at IP, 5251 ! or first at nodes and then using basis functions at IP. 5252 ! The latter is the default. 5253 !------------------------------------------------------------------ 5254 IF( Handle % EvaluateAtIp ) THEN 5255 IF(.NOT. PRESENT(Basis)) THEN 5256 CALL Fatal('ListGetElementReal','Parameter > Basis < is required!') 5257 END IF 5258 5259 ! If we get back to the same element than last time use the data already 5260 ! retrieved. If the element is new then get the data in every node of the 5261 ! current element, or only in the 1st node if it is constant. 5262 5263 IF( ASSOCIATED( PElement, Handle % Element ) ) THEN 5264 IF( PRESENT( Indexes ) ) THEN 5265 n = SIZE( Indexes ) 5266 NodeIndexes => Indexes 5267 ELSE 5268 n = Handle % Element % TYPE % NumberOfNodes 5269 NodeIndexes => PElement % NodeIndexes 5270 END IF 5271 5272 ParF => Handle % ParValues 5273 ELSE 5274 IF( .NOT. Handle % AllocationsDone ) THEN 5275 n = CurrentModel % Mesh % MaxElementNodes 5276 ALLOCATE( Handle % Values(n) ) 5277 Handle % Values = 0.0_dp 5278 ALLOCATE( Handle % ParValues(MAX_FNC,n) ) 5279 Handle % ParValues = 0.0_dp 5280 Handle % AllocationsDone = .TRUE. 5281 END IF 5282 5283 Handle % Element => PElement 5284 IF( PRESENT( Indexes ) ) THEN 5285 n = SIZE( Indexes ) 5286 NodeIndexes => Indexes 5287 ELSE 5288 n = PElement % TYPE % NumberOfNodes 5289 NodeIndexes => PElement % NodeIndexes 5290 END IF 5291 5292 IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. & 5293 ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN 5294 5295 ! These might not have been initialized if this is has mixed evaluation strategies 5296 IF(.NOT. ASSOCIATED( Handle % ParValues )) THEN 5297 ALLOCATE( Handle % ParValues(MAX_FNC,CurrentModel % Mesh % MaxElementNodes) ) 5298 Handle % ParValues = 0.0_dp 5299 END IF 5300 5301 DO i=1,n 5302 k = NodeIndexes(i) 5303 5304 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j ) 5305 5306 Handle % ParNo = j 5307 Handle % ParValues(1:j,i) = T(1:j) 5308 5309 ! If the dependency table includes just global values (such as time) 5310 ! the values will be the same for all element entries. 5311 IF( Handle % GlobalInList ) EXIT 5312 5313 END DO 5314 END IF 5315 ParF => Handle % ParValues 5316 END IF 5317 5318 5319 SELECT CASE(ptr % TYPE) 5320 5321 CASE( LIST_TYPE_VARIABLE_SCALAR ) 5322 5323 DO j=1,Handle % ParNo 5324 T(j) = SUM( Basis(1:n) * Handle % ParValues(j,1:n) ) 5325 END DO 5326 5327 ! This one only deals with the variables on IPs, nodal ones are fetched separately 5328 IF( Handle % SomeVarAtIp ) THEN 5329 IF( .NOT. PRESENT( GaussPoint ) ) THEN 5330 CALL Fatal('ListGetElementReal','Evaluation of ip fields requires gauss points as parameter!') 5331 END IF 5332 CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, GaussPoint, T, j ) 5333 END IF 5334 5335 ! there is no node index, pass the negative GaussPoint as to separate it from positive node index 5336 IF ( ptr % PROCEDURE /= 0 ) THEN 5337 IF( PRESENT( GaussPoint ) ) THEN 5338 j = -GaussPoint 5339 ELSE 5340 j = 0 5341 END IF 5342 !CALL ListPushActiveName(Handle % name) 5343 Rvalue = ExecRealFunction( ptr % PROCEDURE,CurrentModel, j, T ) 5344 !CALL ListPopActiveName() 5345 ELSE 5346 RValue = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), & 5347 T(1), ptr % CubicCoeff ) 5348 END IF 5349 5350 CASE( LIST_TYPE_VARIABLE_SCALAR_STR ) 5351 5352 DO j=1,Handle % ParNo 5353 T(j) = SUM( Basis(1:n) * Handle % ParValues(j,1:n) ) 5354 END DO 5355 5356 ! This one only deals with the variables on IPs, nodal ones have been fecthed already 5357 IF( Handle % SomeVarAtIp ) THEN 5358 IF( .NOT. PRESENT( GaussPoint ) ) THEN 5359 CALL Fatal('ListGetElementReal','Evaluation of ip fields requires gauss points as parameter!') 5360 END IF 5361 CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, GaussPoint, T, j ) 5362 END IF 5363 5364 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 5365 WRITE( cmd, * ) 'tx=0; st = ', TVar % Values(1) 5366 k = LEN_TRIM(cmd) 5367 CALL matc( cmd, tmp_str, k ) 5368 5369 DO l=1,Handle % ParNo 5370 WRITE( cmd, * ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 5371 k1 = LEN_TRIM(cmd) 5372 CALL matc( cmd, tmp_str, k1 ) 5373 END DO 5374 5375 cmd = ptr % CValue 5376 k1 = LEN_TRIM(cmd) 5377 CALL matc( cmd, tmp_str, k1 ) 5378 READ( tmp_str(1:k1), * ) RValue 5379 5380 CASE( LIST_TYPE_CONSTANT_SCALAR_PROC ) 5381 5382 IF ( ptr % PROCEDURE /= 0 ) THEN 5383 x = SUM( Basis(1:n) * CurrentModel % Mesh % Nodes % x( NodeIndexes(1:n) ) ) 5384 y = SUM( Basis(1:n) * CurrentModel % Mesh % Nodes % y( NodeIndexes(1:n) ) ) 5385 z = SUM( Basis(1:n) * CurrentModel % Mesh % Nodes % z( NodeIndexes(1:n) ) ) 5386 5387 !CALL ListPushActiveName(Handle % name) 5388 RValue = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,x,y,z) 5389 !CALL ListPopActiveName() 5390 ELSE 5391 CALL Fatal('ListGetElementReal','Constant scalar evaluation failed at ip!') 5392 END IF 5393 5394 CASE DEFAULT 5395 5396 CALL Fatal('ListGetElementReal','Unknown case for avaluation at ip: '//TRIM(I2S(ptr % Type))) 5397 5398 END SELECT 5399 5400 ELSE ! .NOT. EvaluteAtIp 5401 5402 ! If we get back to the same element than last time use the data already 5403 ! retrieved. If the element is new then get the data in every node of the 5404 ! current element, or only in the 1st node if it is constant. 5405 5406 IF( ASSOCIATED( PElement, Handle % Element ) ) THEN 5407 IF( PRESENT( Indexes ) ) THEN 5408 n = SIZE( Indexes ) 5409 NodeIndexes => Indexes 5410 ELSE 5411 n = Handle % Element % TYPE % NumberOfNodes 5412 NodeIndexes => PElement % NodeIndexes 5413 END IF 5414 F => Handle % Values 5415 ElementSame = .TRUE. 5416 5417 ELSE 5418 IF( .NOT. Handle % AllocationsDone ) THEN 5419 n = CurrentModel % Mesh % MaxElementNodes 5420 ALLOCATE( Handle % Values(n) ) 5421 Handle % Values = 0.0_dp 5422 IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN 5423 ALLOCATE( Handle % ParValues(MAX_FNC,n) ) 5424 Handle % ParValues = 0.0_dp 5425 END IF 5426 Handle % AllocationsDone = .TRUE. 5427 END IF 5428 5429 Handle % Element => PElement 5430 F => Handle % Values 5431 5432 IF( PRESENT( Indexes ) ) THEN 5433 n = SIZE( Indexes ) 5434 NodeIndexes => Indexes 5435 ELSE 5436 n = PElement % TYPE % NumberOfNodes 5437 NodeIndexes => PElement % NodeIndexes 5438 END IF 5439 5440 SELECT CASE(ptr % TYPE) 5441 5442 CASE( LIST_TYPE_CONSTANT_SCALAR ) 5443 5444 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 5445 WRITE(Message,*) 'Value type for property [', TRIM(Handle % Name), & 5446 '] not used consistently.' 5447 CALL Fatal( 'ListGetElementReal', Message ) 5448 RETURN 5449 END IF 5450 F(1) = ptr % Coeff * ptr % Fvalues(1,1,1) 5451 5452 5453 CASE( LIST_TYPE_VARIABLE_SCALAR ) 5454 !CALL ListPushActiveName(Handle % name) 5455 5456 T = 1.0_dp 5457 5458 DO i=1,n 5459 k = NodeIndexes(i) 5460 5461 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j ) 5462 5463 IF ( .NOT. ANY( T(1:j) == HUGE(1.0_dp) ) ) THEN 5464 IF ( ptr % PROCEDURE /= 0 ) THEN 5465 F(i) = ptr % Coeff * & 5466 ExecRealFunction( ptr % PROCEDURE,CurrentModel, & 5467 NodeIndexes(i), T ) 5468 ELSE 5469 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 5470 WRITE(Message,*) 'Value type for property [', TRIM(Handle % Name), & 5471 '] not used consistently.' 5472 CALL Fatal( 'ListGetElementReal', Message ) 5473 RETURN 5474 END IF 5475 F(i) = ptr % Coeff * & 5476 InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), & 5477 T(1), ptr % CubicCoeff ) 5478 5479 ! If the dependency table includes just global values (such as time) 5480 ! the values will be the same for all element entries. 5481 IF( Handle % GlobalInList ) EXIT 5482 5483 END IF 5484 END IF 5485 END DO 5486 !CALL ListPopActiveName() 5487 5488 CASE( LIST_TYPE_CONSTANT_SCALAR_STR ) 5489 5490 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 5491 WRITE( cmd, '(a,e15.8)' ) 'st = ', TVar % Values(1) 5492 k = LEN_TRIM(cmd) 5493 CALL matc( cmd, tmp_str, k ) 5494 5495 cmd = ptr % CValue 5496 k = LEN_TRIM(cmd) 5497 CALL matc( cmd, tmp_str, k ) 5498 READ( tmp_str(1:k), * ) F(1) 5499 F(1) = ptr % Coeff * F(1) 5500 5501 CASE( LIST_TYPE_VARIABLE_SCALAR_STR ) 5502 5503 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 5504 WRITE( cmd, * ) 'tx=0; st = ', TVar % Values(1) 5505 k = LEN_TRIM(cmd) 5506 CALL matc( cmd, tmp_str, k ) 5507 5508 DO i=1,n 5509 k = NodeIndexes(i) 5510 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j ) 5511#ifdef HAVE_LUA 5512 IF ( .NOT. ptr % LuaFun ) THEN 5513#endif 5514 5515 IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN 5516 DO l=1,j 5517 WRITE( cmd, * ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 5518 k1 = LEN_TRIM(cmd) 5519 CALL matc( cmd, tmp_str, k1 ) 5520 END DO 5521 5522 cmd = ptr % CValue 5523 k1 = LEN_TRIM(cmd) 5524 CALL matc( cmd, tmp_str, k1 ) 5525 READ( tmp_str(1:k1), * ) F(i) 5526 F(i) = ptr % Coeff * F(i) 5527 END IF 5528#ifdef HAVE_LUA 5529 ELSE 5530 CALL ElmerEvalLua(LuaState, ptr, T, F(i), j ) 5531 END IF 5532#endif 5533 5534 IF( Handle % GlobalInList ) EXIT 5535 END DO 5536 5537 CASE( LIST_TYPE_CONSTANT_SCALAR_PROC ) 5538 5539 IF ( ptr % PROCEDURE == 0 ) THEN 5540 WRITE(Message,*) 'Value type for property [', TRIM(Handle % Name), & 5541 '] not used consistently.' 5542 CALL Fatal( 'ListGetElementReal', Message ) 5543 RETURN 5544 END IF 5545 5546 !CALL ListPushActiveName(Handle % name) 5547 DO i=1,n 5548 F(i) = ptr % Coeff * & 5549 ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, & 5550 CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), & 5551 CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), & 5552 CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) ) 5553 END DO 5554 !CALL ListPopActiveName() 5555 5556 5557 CASE ( LIST_TYPE_CONSTANT_TENSOR ) 5558 5559 n1 = SIZE( Handle % Rtensor, 1 ) 5560 n2 = SIZE( Handle % Rtensor, 2 ) 5561 5562 IF ( ptr % PROCEDURE /= 0 ) THEN 5563 !CALL ListPushActiveName(Handle % name) 5564 DO i=1,n1 5565 DO j=1,n2 5566 Handle % Rtensor(i,j) = ExecConstRealFunction( ptr % PROCEDURE, & 5567 CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp ) 5568 END DO 5569 END DO 5570 !CALL ListPopActiveName() 5571 ELSE 5572 Handle % Rtensor(:,:) = ptr % FValues(:,:,1) 5573 END IF 5574 5575 IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN 5576 Handle % Rtensor = ptr % Coeff * Handle % Rtensor 5577 END IF 5578 5579 5580 CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR ) 5581 5582 Handle % GlobalInList = .FALSE. 5583 5584 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 5585 WRITE( cmd, '(a,e15.8)' ) 'tx=0; st = ', TVar % Values(1) 5586 k = LEN_TRIM(cmd) 5587 CALL matc( cmd, tmp_str, k ) 5588 5589 !CALL ListPushActiveName(Handle % name) 5590 5591 !CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, & 5592 ! Handle % Name, VarCount, VarTable, SomeAtIp, SomeAtNodes, AllGlobal ) 5593 5594 IF( PRESENT( Indexes ) ) THEN 5595 n = SIZE( Indexes ) 5596 NodeIndexes => Indexes 5597 ELSE 5598 n = Handle % Element % TYPE % NumberOfNodes 5599 NodeIndexes => Handle % Element % NodeIndexes 5600 END IF 5601 5602 n1 = SIZE( Handle % Rtensor, 1 ) 5603 n2 = SIZE( Handle % Rtensor, 2 ) 5604 5605 DO i=1,n 5606 k = NodeIndexes(i) 5607 5608 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j ) 5609 5610 IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN 5611#ifdef HAVE_LUA 5612 IF ( .not. ptr % LuaFun ) THEN 5613#endif 5614 DO l=1,j 5615 WRITE( cmd, '(a,g19.12)' ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 5616 k1 = LEN_TRIM(cmd) 5617 CALL matc( cmd, tmp_str, k1 ) 5618 END DO 5619 5620 cmd = ptr % CValue 5621 k1 = LEN_TRIM(cmd) 5622 CALL matc( cmd, tmp_str, k1 ) 5623 READ( tmp_str(1:k1), * ) ((Handle % Rtensor(j,k),k=1,N2),j=1,N1) 5624 5625#ifdef HAVE_LUA 5626 ELSE 5627 call ElmerEvalLua(LuaState, ptr, T, Handle % RTensor, j ) 5628 END IF 5629#endif 5630 ELSE IF ( ptr % PROCEDURE /= 0 ) THEN 5631 CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, & 5632 NodeIndexes(i), T, Handle % RTensor ) 5633 ELSE 5634 DO j2=1,N1 5635 DO k2=1,N2 5636 Handle % Rtensor(j2,k2) = InterpolateCurve(ptr % TValues, ptr % FValues(j2,k2,:), & 5637 T(1), ptr % CubicCoeff ) 5638 END DO 5639 END DO 5640 END IF 5641 5642 !CALL ListPopActiveName() 5643 5644 IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN 5645 Handle % Rtensor = ptr % Coeff * Handle % Rtensor 5646 END IF 5647 5648 IF( Handle % GlobalInList ) THEN 5649 EXIT 5650 ELSE 5651 DO j2=1,N1 5652 DO k2=1,N2 5653 Handle % RtensorValues(j2,k2,i) = Handle % Rtensor(j2,k2) 5654 END DO 5655 END DO 5656 END IF 5657 5658 END DO 5659 END SELECT 5660 5661 END IF 5662 5663 5664 IF( Handle % Rdim == 0 ) THEN 5665 IF( Handle % GlobalInList ) THEN 5666 RValue = F(1) 5667 ELSE 5668 IF(.NOT. PRESENT(Basis)) THEN 5669 CALL Fatal('ListGetElementReal','Parameter > Basis < is required!') 5670 ELSE 5671 RValue = SUM( Basis(1:n) * F(1:n) ) 5672 END IF 5673 END IF 5674 ELSE 5675 Rtensor => Handle % Rtensor 5676 Rdim = Handle % Rdim 5677 5678 IF( .NOT. Handle % GlobalInList ) THEN 5679 IF(.NOT. PRESENT(Basis)) THEN 5680 CALL Fatal('ListGetElementRealArray','Parameter > Basis < is required!') 5681 ELSE 5682 DO j2=1,SIZE( Handle % RTensor, 1 ) 5683 DO k2=1,SIZE( Handle % RTensor, 2 ) 5684 Handle % RTensor(j2,k2) = SUM( Basis(1:n) * Handle % RtensorValues(j2,k2,1:n) ) 5685 END DO 5686 END DO 5687 END IF 5688 END IF 5689 END IF 5690 5691 END IF 5692 5693 IF ( Handle % GotMinv ) THEN 5694 IF ( RValue < Handle % minv ) THEN 5695 WRITE( Message,*) 'Given value ',RValue, ' for property: ', '[', TRIM(Handle % Name),']', & 5696 ' smaller than given minimum: ', Handle % minv 5697 CALL Fatal( 'ListGetElementReal', Message ) 5698 END IF 5699 END IF 5700 5701 IF ( Handle % GotMaxv ) THEN 5702 IF ( RValue > Handle % maxv ) THEN 5703 WRITE( Message,*) 'Given value ',RValue, ' for property: ', '[', TRIM(Handle % Name),']', & 5704 ' larger than given maximum ', Handle % maxv 5705 CALL Fatal( 'ListGetElementReal', Message ) 5706 END IF 5707 END IF 5708 5709 END FUNCTION ListGetElementReal 5710!------------------------------------------------------------------------------ 5711 5712 5713!------------------------------------------------------------------------------ 5714!> This is just a wrapper for getting the imaginary part of the keyword if it 5715!> has been properly initialized. For the solver modules it is more convenient 5716!> as the code becomes more compact when using the "HandleIm" field instead of a 5717!> totally new handle. 5718!------------------------------------------------------------------------------ 5719 FUNCTION ListGetElementIm( Handle,Basis,Element,Found,Indexes,& 5720 GaussPoint,Rdim,Rtensor) RESULT(Rvalue) 5721!------------------------------------------------------------------------------ 5722 TYPE(ValueHandle_t) :: Handle 5723 REAL(KIND=dp), OPTIONAL :: Basis(:) 5724 LOGICAL, OPTIONAL :: Found 5725 TYPE(Element_t), POINTER, OPTIONAL :: Element 5726 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5727 INTEGER, OPTIONAL :: GaussPoint 5728 INTEGER, OPTIONAL :: Rdim 5729 REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:) 5730 REAL(KIND=dp) :: Rvalue 5731 5732 IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN 5733 CALL Fatal('ListGetElementIm','Initialize with imaginary component!') 5734 END IF 5735 Rvalue = ListGetElementReal(Handle % HandleIm,Basis,Element,Found,Indexes,& 5736 GaussPoint,Rdim,Rtensor) 5737 END FUNCTION ListGetElementIm 5738 5739 5740!------------------------------------------------------------------------------ 5741!> This is just a wrapper for getting both the real and imaginary part of the keyword if it 5742!> has been properly initialized. For the solver modules it is convenient since the 5743!> final code is more compact. This does not work with vector valued keywords yet! 5744!------------------------------------------------------------------------------ 5745 FUNCTION ListGetElementComplex( Handle,Basis,Element,Found,Indexes,& 5746 GaussPoint,Rdim,Rtensor) RESULT(Zvalue) 5747!------------------------------------------------------------------------------ 5748 TYPE(ValueHandle_t) :: Handle 5749 REAL(KIND=dp), OPTIONAL :: Basis(:) 5750 LOGICAL, OPTIONAL :: Found 5751 TYPE(Element_t), POINTER, OPTIONAL :: Element 5752 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5753 INTEGER, OPTIONAL :: GaussPoint 5754 INTEGER, OPTIONAL :: Rdim 5755 REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:) 5756 COMPLEX(KIND=dp) :: Zvalue 5757 5758 REAL(KIND=dp) :: RValue, Ivalue 5759 LOGICAL :: RFound 5760 5761 IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN 5762 CALL Fatal('ListGetElementComplex','Initialize with imaginary component!') 5763 END IF 5764 5765 IF( Handle % NotPresentAnywhere .AND. Handle % HandleIm % NotPresentAnywhere ) THEN 5766 IF(PRESENT(Found)) Found = .FALSE. 5767 Zvalue = CMPLX( Handle % DefRValue, 0.0_dp ) 5768 RETURN 5769 END IF 5770 5771 Rvalue = ListGetElementReal(Handle,Basis,Element,Found,Indexes,GaussPoint) 5772 IF( PRESENT( Found ) ) RFound = Found 5773 5774 Ivalue = ListGetElementReal(Handle % HandleIm,Basis,Element,Found,Indexes,GaussPoint) 5775 IF( PRESENT( Found ) ) Found = Found .OR. RFound 5776 5777 Zvalue = CMPLX( Rvalue, Ivalue ) 5778 5779 END FUNCTION ListGetElementComplex 5780 5781 5782!------------------------------------------------------------------------------ 5783!> This is just a wrapper for getting a 3D real vector. 5784!------------------------------------------------------------------------------ 5785 FUNCTION ListGetElementReal3D( Handle,Basis,Element,Found,Indexes,& 5786 GaussPoint,Rdim,Rtensor) RESULT(RValue3D) 5787!------------------------------------------------------------------------------ 5788 TYPE(ValueHandle_t) :: Handle 5789 REAL(KIND=dp), OPTIONAL :: Basis(:) 5790 LOGICAL, OPTIONAL :: Found 5791 TYPE(Element_t), POINTER, OPTIONAL :: Element 5792 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5793 INTEGER, OPTIONAL :: GaussPoint 5794 INTEGER, OPTIONAL :: Rdim 5795 REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:) 5796 REAL(KIND=dp) :: RValue3D(3) 5797 5798 LOGICAL :: Found1, Found2 5799 5800 IF(.NOT. ASSOCIATED( Handle % Handle2 ) ) THEN 5801 CALL Fatal('ListGetElementReal3D','Initialize with 3D components!') 5802 END IF 5803 5804 IF( Handle % NotPresentAnywhere .AND. Handle % Handle2 % NotPresentAnywhere & 5805 .AND. Handle % Handle3 % NotPresentAnywhere ) THEN 5806 IF(PRESENT(Found)) Found = .FALSE. 5807 RValue3D = 0.0_dp 5808 RETURN 5809 END IF 5810 5811 Rvalue3D(1) = ListGetElementReal(Handle,Basis,Element,Found,Indexes,GaussPoint) 5812 IF( PRESENT( Found ) ) Found1 = Found 5813 5814 Rvalue3D(2) = ListGetElementReal(Handle % Handle2,Basis,Element,Found,Indexes,GaussPoint) 5815 IF( PRESENT( Found ) ) Found2 = Found 5816 5817 Rvalue3D(3) = ListGetElementReal(Handle % Handle3,Basis,Element,Found,Indexes,GaussPoint) 5818 IF( PRESENT( Found ) ) Found = Found1 .OR. Found2 .OR. Found 5819 5820 END FUNCTION ListGetElementReal3D 5821 5822 5823!------------------------------------------------------------------------------ 5824!> This is a wrapper to get gradient of a real valued keyword with functional dependencies. 5825!------------------------------------------------------------------------------ 5826 FUNCTION ListGetElementRealGrad( Handle,dBasisdx,Element,Found,Indexes) RESULT(RGrad) 5827!------------------------------------------------------------------------------ 5828 TYPE(ValueHandle_t) :: Handle 5829 ! dBasisdx is required since it is used to evaluate the gradient 5830 REAL(KIND=dp) :: dBasisdx(:,:) 5831 LOGICAL, OPTIONAL :: Found 5832 TYPE(Element_t), POINTER, OPTIONAL :: Element 5833 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5834 REAL(KIND=dp) :: RGrad(3) 5835 LOGICAL :: Lfound 5836 INTEGER :: i 5837 5838 RGrad = 0.0_dp 5839 5840 IF( Handle % NotPresentAnywhere ) THEN 5841 IF( PRESENT( Found ) ) Found = .FALSE. 5842 RETURN 5843 END IF 5844 5845 ! Derivative of constant is zero 5846 IF( Handle % ConstantEverywhere ) THEN 5847 IF( PRESENT( Found ) ) Found = .TRUE. 5848 RETURN 5849 END IF 5850 5851 ! Obtain gradient of a scalar field going through the partial derivatives of the components 5852 DO i=1,3 5853 RGrad(i) = ListGetElementReal(Handle,dBasisdx(:,i),Element,Lfound,Indexes) 5854 ! If we don't have it needless to contunue to 2nd and 3rd dimensions 5855 IF(.NOT. Lfound ) EXIT 5856 END DO 5857 IF( PRESENT( Found ) ) Found = Lfound 5858 5859 END FUNCTION ListGetElementRealGrad 5860 5861 5862!------------------------------------------------------------------------------ 5863!> This is just a wrapper for getting divergence of a 3D real vector. 5864!------------------------------------------------------------------------------ 5865 FUNCTION ListGetElementRealDiv( Handle,dBasisdx,Element,Found,Indexes) RESULT(Rdiv) 5866!------------------------------------------------------------------------------ 5867 TYPE(ValueHandle_t) :: Handle 5868 ! dBasisdx is required since it is used to evaluate the divergence 5869 REAL(KIND=dp) :: dBasisdx(:,:) 5870 LOGICAL, OPTIONAL :: Found 5871 TYPE(Element_t), POINTER, OPTIONAL :: Element 5872 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5873 REAL(KIND=dp) :: Rdiv(3) 5874 5875 LOGICAL :: Found1, Found2, Found3 5876 5877 Rdiv = 0.0_dp 5878 5879 IF(.NOT. ASSOCIATED( Handle % Handle2 ) ) THEN 5880 CALL Fatal('ListGetElementReal3D','Initialize with 3D components!') 5881 END IF 5882 5883 IF( Handle % NotPresentAnywhere .AND. Handle % Handle2 % NotPresentAnywhere & 5884 .AND. Handle % Handle3 % NotPresentAnywhere ) THEN 5885 IF(PRESENT(Found)) Found = .FALSE. 5886 RETURN 5887 END IF 5888 5889 Rdiv(1) = ListGetElementReal(Handle,dBasisdx(:,1),Element,Found1,Indexes) 5890 Rdiv(2) = ListGetElementReal(Handle % Handle2,dBasisdx(:,2),Element,Found2,Indexes) 5891 Rdiv(3) = ListGetElementReal(Handle % Handle3,dBasisdx(:,3),Element,Found3,Indexes) 5892 IF( PRESENT( Found ) ) Found = Found1 .OR. Found2 .OR. Found3 5893 5894 END FUNCTION ListGetElementRealDiv 5895 5896 5897 5898!------------------------------------------------------------------------------ 5899!> This is just a wrapper for getting a 3D complex vector. 5900!------------------------------------------------------------------------------ 5901 FUNCTION ListGetElementComplex3D( Handle,Basis,Element,Found,Indexes,& 5902 GaussPoint,Rdim,Rtensor) RESULT(ZValue3D) 5903!------------------------------------------------------------------------------ 5904 TYPE(ValueHandle_t) :: Handle 5905 REAL(KIND=dp), OPTIONAL :: Basis(:) 5906 LOGICAL, OPTIONAL :: Found 5907 TYPE(Element_t), POINTER, OPTIONAL :: Element 5908 INTEGER, POINTER, OPTIONAL :: Indexes(:) 5909 INTEGER, OPTIONAL :: GaussPoint 5910 INTEGER, OPTIONAL :: Rdim 5911 REAL(KIND=dp), POINTER, OPTIONAL :: Rtensor(:,:) 5912 COMPLEX(KIND=dp) :: ZValue3D(3) 5913 5914 REAL(KIND=dp) :: RValue3D(3), IValue3D(3) 5915 LOGICAL :: RFound 5916 5917 IF(.NOT. ASSOCIATED( Handle % HandleIm ) ) THEN 5918 CALL Fatal('ListGetElementComplex3D','Initialize with imaginary component!') 5919 END IF 5920 5921 Rvalue3D = ListGetElementReal3D(Handle,Basis,Element,Found,Indexes,GaussPoint) 5922 IF( PRESENT( Found ) ) RFound = Found 5923 5924 Ivalue3D = ListGetElementReal3D(Handle % HandleIm,Basis,Element,Found,Indexes,GaussPoint) 5925 IF( PRESENT( Found ) ) Found = Found .OR. RFound 5926 5927 Zvalue3D = CMPLX( Rvalue3D, Ivalue3D ) 5928 5929 END FUNCTION ListGetElementComplex3D 5930 5931 5932!------------------------------------------------------------------------------ 5933!> Gets a real valued parameter in all the Gaussian integration points. 5934!------------------------------------------------------------------------------ 5935 FUNCTION ListGetElementRealVec( Handle,ngp,BasisVec,Element,Found ) RESULT( Rvalues ) 5936!------------------------------------------------------------------------------ 5937 TYPE(ValueHandle_t) :: Handle 5938 INTEGER :: ngp 5939 REAL(KIND=dp), OPTIONAL :: BasisVec(:,:) 5940 LOGICAL, OPTIONAL :: Found 5941 TYPE(Element_t), POINTER, OPTIONAL :: Element 5942 REAL(KIND=dp), POINTER :: Rvalues(:) 5943!------------------------------------------------------------------------------ 5944 TYPE(Variable_t), POINTER :: Variable, CVar, TVar 5945 TYPE(ValueListEntry_t), POINTER :: ptr 5946 INTEGER, POINTER :: NodeIndexes(:) 5947 REAL(KIND=dp) :: T(MAX_FNC),x,y,z, RValue 5948! TYPE(VariableTable_t) :: VarTable(MAX_FNC) 5949 REAL(KIND=dp), POINTER :: F(:) 5950 REAL(KIND=dp), POINTER :: ParF(:,:) 5951 INTEGER :: i,j,k,k1,l,l0,l1,lsize,n,bodyid,id,node,gp 5952 !,varcount 5953 CHARACTER(LEN=MAX_NAME_LEN) :: cmd, tmp_str 5954 LOGICAL :: AllGlobal, SomeAtIp, SomeAtNodes, ListSame, ListFound, GotIt, IntFound 5955 TYPE(Element_t), POINTER :: PElement 5956 TYPE(ValueList_t), POINTER :: List 5957!------------------------------------------------------------------------------ 5958 5959 IF( Handle % nValuesVec < ngp ) THEN 5960 IF( Handle % nValuesVec > 0 ) THEN 5961 DEALLOCATE( Handle % ValuesVec ) 5962 END IF 5963 ALLOCATE( Handle % ValuesVec(ngp) ) 5964 Handle % nValuesVec = ngp 5965 5966 IF( Handle % ConstantEverywhere ) THEN 5967 Handle % ValuesVec(1:ngp) = Handle % Rvalue 5968 ELSE 5969 Handle % ValuesVec(1:ngp) = Handle % DefRValue 5970 END IF 5971 END IF 5972 5973 ! The results are always returned from the Handle % Values 5974 Rvalues => Handle % ValuesVec 5975 5976 ! If value is not present anywhere then return False 5977 IF( Handle % NotPresentAnywhere ) THEN 5978 IF(PRESENT(Found)) Found = .FALSE. 5979 RETURN 5980 END IF 5981 5982 ! If the value is known to be globally constant return it asap. 5983 IF( Handle % ConstantEverywhere ) THEN 5984 IF(PRESENT(Found)) Found = .TRUE. 5985 RETURN 5986 END IF 5987 5988 ! Find the pointer to the element, if not given 5989 IF( PRESENT( Element ) ) THEN 5990 PElement => Element 5991 ELSE 5992 PElement => CurrentModel % CurrentElement 5993 END IF 5994 5995 ! We know by initialization the list entry type that the keyword has 5996 ! Find the correct list to look the keyword in. 5997 ! Bulk and boundary elements are treated separately. 5998 List => ElementHandleList( PElement, Handle, ListSame, ListFound ) 5999 6000 6001 ! If the provided list is the same as last time, also the keyword will 6002 ! be sitting at the same place, otherwise find it in the new list 6003 IF( ListSame ) THEN 6004 IF( PRESENT( Found ) ) Found = Handle % Found 6005 IF( .NOT. Handle % Found ) RETURN 6006 IF( Handle % GlobalInList ) THEN 6007 RETURN 6008 ELSE 6009 ptr => Handle % ptr % head 6010 END IF 6011 ELSE IF( ListFound ) THEN 6012 6013 ptr => ListFind(List,Handle % Name,IntFound) 6014 IF(PRESENT(Found)) Found = IntFound 6015 Handle % Found = IntFound 6016 6017 IF(.NOT. IntFound ) THEN 6018 IF( Handle % UnfoundFatal ) THEN 6019 CALL Fatal('ListGetElementRealVec','Could not find required keyword in list: '//TRIM(Handle % Name)) 6020 END IF 6021 Handle % ValuesVec(1:ngp) = Handle % DefRValue 6022 RETURN 6023 END IF 6024 6025 Handle % Ptr % Head => ptr 6026 6027 ! It does not make sense to evaluate global variables at IP 6028 IF( Handle % SomewhereEvaluateAtIp ) THEN 6029 ! Check whether the keyword should be evaluated at integration point directly 6030 ! Only these dependency type may depend on position 6031 IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. & 6032 ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR .OR. & 6033 ptr % TYPE == LIST_TYPE_CONSTANT_SCALAR_PROC ) THEN 6034 ! Check whether the keyword should be evaluated at integration point directly 6035 Handle % EvaluateAtIp = ListGetLogical( List, TRIM( Handle % Name )//' At IP',GotIt ) 6036 ELSE 6037 Handle % EvaluateAtIp = .FALSE. 6038 END IF 6039 END IF 6040 6041 6042 IF( ptr % DepNameLen > 0 ) THEN 6043 CALL ListParseStrToVars( Ptr % DependName, Ptr % DepNameLen, & 6044 Handle % Name, Handle % VarCount, Handle % VarTable, & 6045 SomeAtIp, SomeAtNodes, AllGlobal ) 6046 IF( SomeAtIp ) Handle % EvaluateAtIp = .TRUE. 6047 Handle % GlobalInList = ( AllGlobal .AND. ptr % PROCEDURE == 0 ) 6048 IF( SomeAtIP ) Handle % EvaluateAtIp = .TRUE. 6049 IF( AllGlobal ) Handle % EvaluateAtIp = .FALSE. 6050 Handle % SomeVarAtIp = SomeAtIp 6051 ELSE 6052 Handle % GlobalInList = ( ptr % PROCEDURE == 0 ) 6053 END IF 6054 6055 ELSE 6056 IF( Handle % UnfoundFatal ) THEN 6057 CALL Fatal('ListGetElementRealVec','Could not find list for required keyword: '//TRIM(Handle % Name)) 6058 END IF 6059 IF( .NOT. Handle % AllocationsDone ) THEN 6060 n = CurrentModel % Mesh % MaxElementNodes 6061 ALLOCATE( Handle % Values(n) ) 6062 Handle % Values = 0.0_dp 6063 IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN 6064 ALLOCATE( Handle % ParValues(MAX_FNC,n) ) 6065 Handle % ParValues = 0.0_dp 6066 END IF 6067 Handle % AllocationsDone = .TRUE. 6068 END IF 6069 Handle % ValuesVec = Handle % DefRValue 6070 IF( PRESENT(Found) ) THEN 6071 Found = .FALSE. 6072 Handle % Found = .FALSE. 6073 END IF 6074 RETURN 6075 END IF 6076 6077 ! Either evaluate parameter directly at IP, 6078 ! or first at nodes and then using basis functions at IP. 6079 ! The later is the default. 6080 !------------------------------------------------------------------ 6081 IF( Handle % EvaluateAtIp ) THEN 6082 6083 IF(.NOT. PRESENT(BasisVec)) THEN 6084 CALL Fatal('ListGetElementRealVec','Parameter > Basis < is required!') 6085 END IF 6086 6087 IF( .NOT. Handle % AllocationsDone ) THEN 6088 n = CurrentModel % Mesh % MaxElementNodes 6089 ALLOCATE( Handle % Values(n) ) 6090 Handle % Values = 0.0_dp 6091 ALLOCATE( Handle % ParValues(MAX_FNC,n) ) 6092 Handle % ParValues = 0.0_dp 6093 Handle % AllocationsDone = .TRUE. 6094 END IF 6095 6096 Handle % Element => PElement 6097 n = PElement % TYPE % NumberOfNodes 6098 NodeIndexes => PElement % NodeIndexes 6099 6100 6101 IF( ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR .OR. & 6102 ptr % TYPE == LIST_TYPE_VARIABLE_SCALAR_STR ) THEN 6103 6104 ! These might not have been initialized if this is has mixed evaluation strategies 6105 IF(.NOT. ASSOCIATED( Handle % ParValues )) THEN 6106 ALLOCATE( Handle % ParValues(MAX_FNC,CurrentModel % Mesh % MaxElementNodes) ) 6107 Handle % ParValues = 0.0_dp 6108 END IF 6109 6110 DO i=1,n 6111 node = NodeIndexes(i) 6112 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, node, T, j ) 6113 6114 IF( Handle % GlobalInList ) THEN 6115 CALL Warn('ListGetElementRealVec','Constant expression need not be evaluated at IPs!') 6116 END IF 6117 6118 Handle % ParNo = j 6119 Handle % ParValues(1:j,i) = T(1:j) 6120 END DO 6121 6122 ParF => Handle % ParValues 6123 END IF 6124 6125 6126 SELECT CASE(ptr % TYPE) 6127 6128 CASE( LIST_TYPE_VARIABLE_SCALAR ) 6129 6130 ! there is no node index, so use zero 6131 IF ( ptr % PROCEDURE /= 0 ) THEN 6132 !CALL ListPushActiveName(Handle % name) 6133 node = 0 6134 6135 DO gp = 1, ngp 6136 DO j=1,Handle % ParNo 6137 T(j) = SUM( BasisVec(gp,1:n) * ParF(j,1:n) ) 6138 END DO 6139 Rvalue = ExecRealFunction( ptr % PROCEDURE, CurrentModel, node, T ) 6140 Handle % ValuesVec(gp) = RValue 6141 END DO 6142 !CALL ListPopActiveName() 6143 ELSE 6144 DO gp = 1, ngp 6145 DO j=1,Handle % ParNo 6146 T(j) = SUM( BasisVec(gp,1:n) * ParF(j,1:n) ) 6147 END DO 6148 RValue = InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), & 6149 T(1), ptr % CubicCoeff ) 6150 Handle % ValuesVec(gp) = RValue 6151 END DO 6152 END IF 6153 6154 CASE( LIST_TYPE_VARIABLE_SCALAR_STR ) 6155 6156 ! there is no node index, so use zero 6157 node = 0 6158 6159#ifdef HAVE_LUA 6160 IF ( .not. ptr % LuaFun ) THEN 6161#endif 6162 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 6163 WRITE( cmd, * ) 'tx=0; st = ', TVar % Values(1) 6164 k = LEN_TRIM(cmd) 6165 CALL matc( cmd, tmp_str, k ) 6166#ifdef HAVE_LUA 6167 END IF 6168#endif 6169 6170 DO gp = 1, ngp 6171 DO j=1,Handle % ParNo 6172 T(j) = SUM( BasisVec(gp,1:n) * Handle % ParValues(j,1:n) ) 6173 END DO 6174 6175 ! This one only deals with the variables on IPs, nodal ones have been fecthed already 6176 IF( Handle % SomeVarAtIp ) THEN 6177 CALL VarsToValuesOnIps( Handle % VarCount, Handle % VarTable, gp, T, j ) 6178 END IF 6179 6180#ifdef HAVE_LUA 6181 IF ( .not. ptr % LuaFun ) THEN 6182#endif 6183 DO l=1,Handle % ParNo 6184 WRITE( cmd, * ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 6185 k1 = LEN_TRIM(cmd) 6186 CALL matc( cmd, tmp_str, k1 ) 6187 END DO 6188 6189 cmd = ptr % CValue 6190 k1 = LEN_TRIM(cmd) 6191 6192 CALL matc( cmd, tmp_str, k1 ) 6193 READ( tmp_str(1:k1), * ) RValue 6194 6195#ifdef HAVE_LUA 6196 ELSE 6197 call ElmerEvalLua(LuaState, ptr, T, RValue, j) 6198 END IF 6199#endif 6200 Handle % ValuesVec(gp) = RValue 6201 END DO 6202 6203 6204 CASE( LIST_TYPE_CONSTANT_SCALAR_PROC ) 6205 6206 IF ( ptr % PROCEDURE /= 0 ) THEN 6207 !CALL ListPushActiveName(Handle % name) 6208 6209 DO gp = 1, ngp 6210 6211 x = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % x( NodeIndexes(1:n))) 6212 y = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % y( NodeIndexes(1:n))) 6213 z = SUM(BasisVec(gp,1:n) * CurrentModel % Mesh % Nodes % z( NodeIndexes(1:n))) 6214 6215 RValue = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,x,y,z) 6216 Handle % ValuesVec(gp) = RValue 6217 END DO 6218 !CALL ListPopActiveName() 6219 6220 ELSE 6221 CALL Fatal('ListGetElementRealVec','Constant scalar evaluation failed at ip!') 6222 END IF 6223 6224 CASE DEFAULT 6225 6226 CALL Fatal('ListGetElementRealVec','Unknown case for avaluation at ip') 6227 6228 END SELECT 6229 6230 ELSE 6231 6232 IF( .NOT. Handle % AllocationsDone ) THEN 6233 n = CurrentModel % Mesh % MaxElementNodes 6234 ALLOCATE( Handle % Values(n) ) 6235 Handle % Values = 0.0_dp 6236 IF( Handle % SomewhereEvaluateAtIp .OR. Handle % EvaluateAtIp ) THEN 6237 ALLOCATE( Handle % ParValues(MAX_FNC,n) ) 6238 Handle % ParValues = 0.0_dp 6239 END IF 6240 Handle % AllocationsDone = .TRUE. 6241 END IF 6242 6243 Handle % Element => PElement 6244 n = PElement % TYPE % NumberOfNodes 6245 NodeIndexes => PElement % NodeIndexes 6246 F => Handle % Values 6247 6248 SELECT CASE(ptr % TYPE) 6249 6250 CASE( LIST_TYPE_CONSTANT_SCALAR ) 6251 6252 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 6253 WRITE(Message,*) 'Value type for property [', TRIM(Handle % Name), & 6254 '] not used consistently.' 6255 CALL Fatal( 'ListGetElementRealVec', Message ) 6256 RETURN 6257 END IF 6258 F(1) = ptr % Coeff * ptr % Fvalues(1,1,1) 6259 RValues(1:ngp) = F(1) 6260 6261 6262 CASE( LIST_TYPE_VARIABLE_SCALAR ) 6263 6264 !CALL ListPushActiveName(Handle % name) 6265 6266 DO i=1,n 6267 node = NodeIndexes(i) 6268 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, node, T, j ) 6269 6270 IF ( ptr % PROCEDURE /= 0 ) THEN 6271 F(i) = ptr % Coeff * & 6272 ExecRealFunction( ptr % PROCEDURE,CurrentModel, & 6273 NodeIndexes(i), T ) 6274 ELSE 6275 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 6276 WRITE(Message,*) 'Value type for property [', TRIM(Handle % Name), & 6277 '] not used consistently.' 6278 CALL Fatal( 'ListGetElementRealVec', Message ) 6279 RETURN 6280 END IF 6281 F(i) = ptr % Coeff * & 6282 InterpolateCurve( ptr % TValues,ptr % FValues(1,1,:), & 6283 T(1), ptr % CubicCoeff ) 6284 6285 ! If the dependency table includes just global values (such as time) 6286 ! the values will be the same for all element entries. 6287 IF( Handle % GlobalInList ) EXIT 6288 END IF 6289 END DO 6290 6291 IF( Handle % GlobalInList ) THEN 6292 Handle % ValuesVec(1:ngp) = F(1) 6293 ELSE 6294 Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) ) 6295 END IF 6296 !CALL ListPopActiveName() 6297 6298 6299 CASE( LIST_TYPE_CONSTANT_SCALAR_STR ) 6300 6301 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 6302 WRITE( cmd, '(a,e15.8)' ) 'st = ', TVar % Values(1) 6303 k = LEN_TRIM(cmd) 6304 CALL matc( cmd, tmp_str, k ) 6305 6306 cmd = ptr % CValue 6307 k = LEN_TRIM(cmd) 6308 CALL matc( cmd, tmp_str, k ) 6309 READ( tmp_str(1:k), * ) F(1) 6310 F(1) = ptr % Coeff * F(1) 6311 6312 Handle % ValuesVec(1:ngp) = F(1) 6313 6314 6315 CASE( LIST_TYPE_VARIABLE_SCALAR_STR ) 6316 6317#ifdef HAVE_LUA 6318 IF ( .not. ptr % LuaFun ) THEN 6319#endif 6320 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 6321 WRITE( cmd, * ) 'tx=0; st = ', TVar % Values(1) 6322 k = LEN_TRIM(cmd) 6323 CALL matc( cmd, tmp_str, k ) 6324#ifdef HAVE_LUA 6325 END IF 6326#endif 6327 6328 DO i=1,n 6329 k = NodeIndexes(i) 6330 6331 CALL VarsToValuesOnNodes( Handle % VarCount, Handle % VarTable, k, T, j ) 6332 6333#ifdef HAVE_LUA 6334 IF ( .not. ptr % LuaFun ) THEN 6335#endif 6336 IF ( .NOT. ANY( T(1:j)==HUGE(1.0_dp) ) ) THEN 6337 DO l=1,j 6338 WRITE( cmd, * ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 6339 k1 = LEN_TRIM(cmd) 6340 CALL matc( cmd, tmp_str, k1 ) 6341 END DO 6342 6343 cmd = ptr % CValue 6344 k1 = LEN_TRIM(cmd) 6345 CALL matc( cmd, tmp_str, k1 ) 6346 READ( tmp_str(1:k1), * ) F(i) 6347 F(i) = ptr % Coeff * F(i) 6348 END IF 6349#ifdef HAVE_LUA 6350 ELSE 6351 call ElmerEvalLuaS(LuaState, ptr, T, F(i), j) 6352 F(i) = ptr % coeff * F(i) 6353 END IF 6354#endif 6355 IF( Handle % GlobalInList ) EXIT 6356 END DO 6357 6358 IF( Handle % GlobalInList ) THEN 6359 Handle % ValuesVec(1:ngp) = F(1) 6360 ELSE 6361 Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) ) 6362 END IF 6363 6364 CASE( LIST_TYPE_CONSTANT_SCALAR_PROC ) 6365 IF ( ptr % PROCEDURE == 0 ) THEN 6366 WRITE(Message,*) 'Value type for property [', TRIM(Handle % Name), & 6367 '] not used consistently.' 6368 CALL Fatal( 'ListGetElementRealVec', Message ) 6369 RETURN 6370 END IF 6371 6372 !CALL ListPushActiveName(Handle % name) 6373 DO i=1,n 6374 F(i) = ptr % Coeff * & 6375 ExecConstRealFunction( ptr % PROCEDURE,CurrentModel, & 6376 CurrentModel % Mesh % Nodes % x( NodeIndexes(i) ), & 6377 CurrentModel % Mesh % Nodes % y( NodeIndexes(i) ), & 6378 CurrentModel % Mesh % Nodes % z( NodeIndexes(i) ) ) 6379 END DO 6380 !CALL ListPopActiveName() 6381 6382 Handle % ValuesVec(1:ngp) = MATMUL( BasisVec(1:ngp,1:n), F(1:n) ) 6383 6384 CASE DEFAULT 6385 CALL Fatal('ListGetElementRealVec','Impossible entry type: '//TRIM(I2S(ptr % Type))) 6386 6387 END SELECT 6388 6389 END IF 6390 6391 END FUNCTION ListGetElementRealVec 6392!------------------------------------------------------------------------------ 6393 6394 6395 6396 6397!------------------------------------------------------------------------------ 6398!> Gets a logical valued parameter in elements. 6399!------------------------------------------------------------------------------ 6400 FUNCTION ListGetElementLogical( Handle, Element, Found ) RESULT(Lvalue) 6401!------------------------------------------------------------------------------ 6402 TYPE(ValueHandle_t) :: Handle 6403 TYPE(Element_t), POINTER, OPTIONAL :: Element 6404 LOGICAL, OPTIONAL :: Found 6405 LOGICAL :: Lvalue 6406!------------------------------------------------------------------------------ 6407 TYPE(ValueList_t), POINTER :: List 6408 TYPE(Element_t), POINTER :: PElement 6409 LOGICAL :: ListSame, ListFound 6410 INTEGER :: id, BodyId 6411!------------------------------------------------------------------------------ 6412 6413 ! If value is not present anywhere then return False 6414 IF( Handle % NotPresentAnywhere ) THEN 6415 IF(PRESENT(Found)) Found = .FALSE. 6416 Lvalue = Handle % DefLValue 6417 RETURN 6418 END IF 6419 6420 ! If the value is known to be globally constant return it asap. 6421 IF( Handle % ConstantEverywhere ) THEN 6422 IF(PRESENT(Found)) Found = .TRUE. 6423 Lvalue = Handle % LValue 6424 RETURN 6425 END IF 6426 6427 ! Find the pointer to the element, if not given 6428 IF( PRESENT( Element ) ) THEN 6429 PElement => Element 6430 ELSE 6431 PElement => CurrentModel % CurrentElement 6432 END IF 6433 6434 ! We know by initialization the list entry type that the keyword has 6435 ! Find the correct list to look the keyword in. 6436 ! Bulk and boundary elements are treated separately. 6437 List => ElementHandleList( PElement, Handle, ListSame, ListFound ) 6438 6439 IF( ListSame ) THEN 6440 IF( PRESENT( Found ) ) Found = Handle % Found 6441 LValue = Handle % LValue 6442 ELSE IF( ListFound ) THEN 6443 LValue = ListGetLogical( List, Handle % Name, Found, & 6444 UnfoundFatal = Handle % UnfoundFatal ) 6445 IF( .NOT. Found ) Lvalue = Handle % DefLValue 6446 Handle % LValue = LValue 6447 IF(PRESENT(Found)) Handle % Found = Found 6448 ELSE 6449 IF( Handle % UnfoundFatal ) THEN 6450 CALL Fatal('ListGetElementLogical','Could not find list for required keyword: '//TRIM(Handle % Name)) 6451 END IF 6452 Lvalue = Handle % DefLValue 6453 IF( PRESENT(Found) ) THEN 6454 Found = .FALSE. 6455 Handle % Found = .FALSE. 6456 END IF 6457 END IF 6458 6459 END FUNCTION ListGetElementLogical 6460!------------------------------------------------------------------------------ 6461 6462 6463!------------------------------------------------------------------------------ 6464!> Gets a integer valued parameter in elements. 6465!------------------------------------------------------------------------------ 6466 FUNCTION ListGetElementInteger( Handle, Element, Found ) RESULT(Ivalue) 6467!------------------------------------------------------------------------------ 6468 TYPE(ValueHandle_t) :: Handle 6469 TYPE(Element_t), POINTER, OPTIONAL :: Element 6470 LOGICAL, OPTIONAL :: Found 6471 INTEGER :: Ivalue 6472!------------------------------------------------------------------------------ 6473 TYPE(ValueList_t), POINTER :: List 6474 TYPE(Element_t), POINTER :: PElement 6475 LOGICAL :: ListSame, ListFound 6476 INTEGER :: id, BodyId 6477!------------------------------------------------------------------------------ 6478 6479 ! If value is not present anywhere then return False 6480 IF( Handle % NotPresentAnywhere ) THEN 6481 IF(PRESENT(Found)) Found = .FALSE. 6482 Ivalue = Handle % DefIValue 6483 RETURN 6484 END IF 6485 6486 ! If the value is known to be globally constant return it asap. 6487 IF( Handle % ConstantEverywhere ) THEN 6488 IF(PRESENT(Found)) Found = .TRUE. 6489 Ivalue = Handle % IValue 6490 RETURN 6491 END IF 6492 6493 ! Find the pointer to the element, if not given 6494 IF( PRESENT( Element ) ) THEN 6495 PElement => Element 6496 ELSE 6497 PElement => CurrentModel % CurrentElement 6498 END IF 6499 6500 ! We know by initialization the list entry type that the keyword has 6501 ! Find the correct list to look the keyword in. 6502 ! Bulk and boundary elements are treated separately. 6503 List => ElementHandleList( PElement, Handle, ListSame, ListFound ) 6504 6505 IF( ListSame ) THEN 6506 IF( PRESENT( Found ) ) Found = Handle % Found 6507 IValue = Handle % IValue 6508 ELSE IF( ListFound ) THEN 6509 IValue = ListGetInteger( List, Handle % Name, Found, UnfoundFatal = Handle % UnfoundFatal ) 6510 Handle % IValue = IValue 6511 IF(PRESENT(Found)) Handle % Found = Found 6512 ELSE 6513 IF( Handle % UnfoundFatal ) THEN 6514 CALL Fatal('ListGetElementInteger','Could not find list for required keyword: '//TRIM(Handle % Name)) 6515 END IF 6516 Ivalue = Handle % DefIValue 6517 Handle % IValue = IValue 6518 IF( PRESENT(Found) ) THEN 6519 Found = .FALSE. 6520 Handle % Found = .FALSE. 6521 END IF 6522 END IF 6523 6524 6525 END FUNCTION ListGetElementInteger 6526!------------------------------------------------------------------------------ 6527 6528 6529 6530!------------------------------------------------------------------------------ 6531!> Gets a string valued parameter in elements. 6532!------------------------------------------------------------------------------ 6533 FUNCTION ListGetElementString( Handle, Element, Found ) RESULT( CValue ) 6534!------------------------------------------------------------------------------ 6535 TYPE(ValueHandle_t) :: Handle 6536 CHARACTER(LEN=MAX_NAME_LEN) :: CValue 6537 TYPE(Element_t), POINTER, OPTIONAL :: Element 6538 LOGICAL, OPTIONAL :: Found 6539!------------------------------------------------------------------------------ 6540 TYPE(ValueList_t), POINTER :: List 6541 TYPE(Element_t), POINTER :: PElement 6542 LOGICAL :: ListSame, ListFound 6543 INTEGER :: id, BodyId 6544!------------------------------------------------------------------------------ 6545 6546 ! If value is not present anywhere then return False 6547 IF( Handle % NotPresentAnywhere ) THEN 6548 IF(PRESENT(Found)) Found = .FALSE. 6549 Cvalue = ' ' 6550 RETURN 6551 END IF 6552 6553 ! If the value is known to be globally constant return it asap. 6554 IF( Handle % ConstantEverywhere ) THEN 6555 IF(PRESENT(Found)) Found = .TRUE. 6556 Cvalue = TRIM(Handle % CValue) 6557 RETURN 6558 END IF 6559 6560 ! Find the pointer to the element, if not given 6561 IF( PRESENT( Element ) ) THEN 6562 PElement => Element 6563 ELSE 6564 PElement => CurrentModel % CurrentElement 6565 END IF 6566 6567 ! We know by initialization the list entry type that the keyword has 6568 ! Find the correct list to look the keyword in. 6569 ! Bulk and boundary elements are treated separately. 6570 List => ElementHandleList( PElement, Handle, ListSame, ListFound ) 6571 6572 IF( ListSame ) THEN 6573 IF( PRESENT( Found ) ) Found = Handle % Found 6574 CValue = Handle % CValue(1:Handle % CValueLen) 6575 ELSE IF( ListFound ) THEN 6576 CValue = ListGetString( List, Handle % Name, Found, & 6577 UnfoundFatal = Handle % UnfoundFatal ) 6578 Handle % CValue = TRIM(CValue) 6579 Handle % CValueLen = len_trim(CValue) 6580 IF(PRESENT(Found)) Handle % Found = Found 6581 ELSE 6582 IF( Handle % UnfoundFatal ) THEN 6583 CALL Fatal('ListGetElementString','Could not find list for required keyword: '//TRIM(Handle % Name)) 6584 END IF 6585 Cvalue = ' ' 6586 Handle % CValueLen = 0 6587 IF( PRESENT(Found) ) THEN 6588 Found = .FALSE. 6589 Handle % Found = .FALSE. 6590 END IF 6591 END IF 6592 6593 END FUNCTION ListGetElementString 6594!------------------------------------------------------------------------------ 6595 6596 6597!------------------------------------------------------------------------------ 6598!> Is the keyword present somewhere 6599!------------------------------------------------------------------------------ 6600 FUNCTION ListGetElementSomewhere( Handle ) RESULT( Found ) 6601!------------------------------------------------------------------------------ 6602 TYPE(ValueHandle_t) :: Handle 6603 LOGICAL :: Found 6604!------------------------------------------------------------------------------ 6605 Found = .NOT. ( Handle % NotPresentAnywhere ) 6606 6607 END FUNCTION ListGetElementSomewhere 6608!------------------------------------------------------------------------------ 6609 6610 6611 6612 6613!------------------------------------------------------------------------------ 6614!> Compares a string valued parameter in elements and return True if they are the same. 6615!------------------------------------------------------------------------------ 6616 FUNCTION ListCompareElementString( Handle, CValue2, Element, Found ) RESULT( SameString ) 6617!------------------------------------------------------------------------------ 6618 TYPE(ValueHandle_t) :: Handle 6619 CHARACTER(LEN=*) :: CValue2 6620 TYPE(Element_t), POINTER, OPTIONAL :: Element 6621 LOGICAL, OPTIONAL :: Found 6622 LOGICAL :: SameString 6623!------------------------------------------------------------------------------ 6624 CHARACTER(LEN=MAX_NAME_LEN) :: CValue 6625 TYPE(ValueList_t), POINTER :: List 6626 TYPE(Element_t), POINTER :: PElement 6627 LOGICAL :: ListSame, ListFound, IntFound 6628 INTEGER :: id, BodyId 6629!------------------------------------------------------------------------------ 6630 6631 SameString = .FALSE. 6632 6633 ! If value is not present anywhere then return False 6634 IF( Handle % NotPresentAnywhere ) THEN 6635 IF(PRESENT(Found)) Found = .FALSE. 6636 RETURN 6637 END IF 6638 6639 ! If the value is known to be globally constant return it asap. 6640 IF( Handle % ConstantEverywhere ) THEN 6641 IF(PRESENT(Found)) Found = .TRUE. 6642 SameString = ( CValue2 == Handle % CValue(1:Handle % CValueLen) ) 6643 RETURN 6644 END IF 6645 6646 ! Find the pointer to the element, if not given 6647 IF( PRESENT( Element ) ) THEN 6648 PElement => Element 6649 ELSE 6650 PElement => CurrentModel % CurrentElement 6651 END IF 6652 6653 ListSame = .FALSE. 6654 ListFound = .FALSE. 6655 6656 ! We know by initialization the list entry type that the keyword has 6657 ! Find the correct list to look the keyword in. 6658 ! Bulk and boundary elements are treated separately. 6659 List => ElementHandleList( PElement, Handle, ListSame, ListFound ) 6660 6661 IF( ListSame ) THEN 6662 IF( PRESENT( Found ) ) Found = Handle % Found 6663 IF( Handle % Found ) THEN 6664 SameString = ( Handle % CValue(1:Handle % CValueLen) == CValue2 ) 6665 END IF 6666 ELSE IF( ListFound ) THEN 6667 CValue = ListGetString( List, Handle % Name, IntFound, & 6668 UnfoundFatal = Handle % UnfoundFatal ) 6669 Handle % Found = IntFound 6670 IF( IntFound ) THEN 6671 Handle % CValueLen = len_trim(CValue) 6672 Handle % CValue = CValue(1:Handle % CValueLen ) 6673 SameString = (Handle % CValue(1:Handle % CValueLen) == CValue2 ) 6674 END IF 6675 IF(PRESENT(Found)) Found = IntFound 6676 ELSE 6677 Handle % Cvalue = ' ' 6678 Handle % CValueLen = 0 6679 Handle % Found = .FALSE. 6680 IF( PRESENT(Found) ) Found = .FALSE. 6681 END IF 6682 6683 END FUNCTION ListCompareElementString 6684!------------------------------------------------------------------------------ 6685 6686 6687 6688!------------------------------------------------------------------------------ 6689!> Initializes the variable handle in a similar manner as the keyword handle is 6690!> initialized. This handle is more compact. Does not support p-fields or 6691!> Hcurl & Hdiv fields yet. 6692!------------------------------------------------------------------------------ 6693 SUBROUTINE ListInitElementVariable( Handle, Name, USolver, UVariable, tStep ) 6694!------------------------------------------------------------------------------ 6695 TYPE(VariableHandle_t) :: Handle 6696 CHARACTER(LEN=*), OPTIONAL :: Name 6697 TYPE(Solver_t), OPTIONAL, TARGET :: USolver 6698 TYPE(Variable_t), OPTIONAL, TARGET :: UVariable 6699 INTEGER, OPTIONAL :: tStep 6700 6701 REAL(KIND=dp), POINTER :: Values(:) 6702 TYPE(Variable_t), POINTER :: Variable 6703 TYPE(Solver_t) , POINTER :: Solver 6704 TYPE(Element_t), POINTER :: Element 6705 6706 Handle % Variable => NULL() 6707 Handle % Values => NULL() 6708 Handle % Perm => NULL() 6709 Handle % Element => NULL() 6710 Handle % dofs = 0 6711 6712 IF ( PRESENT(USolver) ) THEN 6713 Solver => USolver 6714 ELSE 6715 Solver => CurrentModel % Solver 6716 END IF 6717 6718 IF ( PRESENT(name) ) THEN 6719 Variable => VariableGet( Solver % Mesh % Variables, name ) 6720 ELSE IF( PRESENT( UVariable ) ) THEN 6721 Variable => UVariable 6722 ELSE 6723 Variable => Solver % Variable 6724 END IF 6725 6726 IF ( .NOT. ASSOCIATED( Variable ) ) RETURN 6727 6728 Handle % Variable => Variable 6729 Handle % dofs = Variable % Dofs 6730 6731 IF ( PRESENT(tStep) ) THEN 6732 IF ( tStep < 0 ) THEN 6733 IF ( ASSOCIATED(Variable % PrevValues) ) THEN 6734 IF ( -tStep<=SIZE(Variable % PrevValues,2)) & 6735 Handle % Values => Variable % PrevValues(:,-tStep) 6736 END IF 6737 END IF 6738 ELSE 6739 Handle % Values => Variable % Values 6740 END IF 6741 Handle % Perm => Variable % Perm 6742 6743 END SUBROUTINE ListInitElementVariable 6744!------------------------------------------------------------------------------ 6745 6746 6747!------------------------------------------------------------------------------ 6748!> Get a scalar field (e.g. potential or pressure) at the integration point. 6749!> Works with different types of fields. 6750!------------------------------------------------------------------------------ 6751 FUNCTION ListGetElementScalarSolution( Handle, Basis, Element, Found, & 6752 GaussPoint, dof ) RESULT ( Val ) 6753 6754 TYPE(VariableHandle_t) :: Handle 6755 REAL(KIND=dp), OPTIONAL :: Basis(:) 6756 TYPE( Element_t), POINTER, OPTIONAL :: Element 6757 INTEGER, OPTIONAL :: GaussPoint 6758 INTEGER, OPTIONAL :: dof 6759 LOGICAL, OPTIONAL :: Found 6760 REAL(KIND=dp) :: Val 6761 6762 TYPE( Element_t), POINTER :: pElement 6763 INTEGER :: i,j, k, n 6764 INTEGER, POINTER :: Indexes(:) 6765 LOGICAL :: SameElement 6766 6767 Val = 0.0_dp 6768 6769 IF( PRESENT( Found ) ) Found = .FALSE. 6770 6771 IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN 6772 6773 ! Find the pointer to the element, if not given 6774 IF( PRESENT( Element ) ) THEN 6775 PElement => Element 6776 ELSE 6777 PElement => CurrentModel % CurrentElement 6778 END IF 6779 6780 SameElement = ASSOCIATED( Handle % Element, pElement ) 6781 IF( SameElement ) THEN 6782 IF( .NOT. Handle % ActiveElement ) RETURN 6783 ELSE 6784 Handle % Element => pElement 6785 END IF 6786 6787 IF( Handle % dofs > 1 ) THEN 6788 IF( .NOT. PRESENT( dof ) ) THEN 6789 CALL Fatal('ListGetElementScalarSolution','Argument "dof" is needed for vector fields!') 6790 END IF 6791 END IF 6792 6793 ! If variable is defined on gauss points return that instead 6794 IF( Handle % Variable % TYPE == Variable_on_gauss_points ) THEN 6795 IF( .NOT. PRESENT( GaussPoint ) ) THEN 6796 CALL Fatal('ListGetElementScalarSolution','Argument "GaussPoint" required as an argument!') 6797 END IF 6798 6799 j = pElement % ElementIndex 6800 6801 IF( .NOT. SameElement ) THEN 6802 n = Handle % Perm(j+1) - Handle % Perm(j) 6803 Handle % ActiveElement = ( n > 0 ) 6804 IF( n == 0 ) RETURN 6805 END IF 6806 6807 k = Handle % Perm(j) + GaussPoint 6808 6809 IF( Handle % Dofs == 1 ) THEN 6810 val = Handle % Values( k ) 6811 ELSE 6812 val = Handle % Values( Handle % Dofs * (k-1) + dof ) 6813 END IF 6814 6815 ELSE IF( Handle % Variable % TYPE == Variable_on_elements ) THEN 6816 j = Handle % Perm( pElement % ElementIndex ) 6817 Handle % ActiveElement = ( j > 0 ) 6818 6819 IF( j == 0 ) RETURN 6820 6821 IF( Handle % Dofs == 1 ) THEN 6822 val = Handle % Values( j ) 6823 ELSE 6824 val = Handle % Values( Handle % Dofs * (j-1) + dof ) 6825 END IF 6826 6827 ELSE 6828 IF( .NOT. PRESENT( Basis ) ) THEN 6829 CALL Fatal('ListGetElementScalarSolution',& 6830 'Argument "Basis" required for non gauss-point variable!') 6831 END IF 6832 6833 IF( .NOT. SameElement ) THEN 6834 IF( Handle % Variable % TYPE == Variable_on_nodes_on_elements ) THEN 6835 n = pElement % TYPE % NumberOfNodes 6836 Indexes => pElement % DGIndexes 6837 IF(.NOT. ASSOCIATED( Indexes ) ) THEN 6838 CALL Fatal('ListGetElementScalarSolution','DGIndexes not associated!') 6839 END IF 6840 ELSE 6841 n = pElement % TYPE % NumberOfNodes 6842 Indexes => pElement % NodeIndexes 6843 END IF 6844 6845 Handle % n = n 6846 6847 IF( ASSOCIATED( Handle % Perm ) ) THEN 6848 Handle % Indexes(1:n) = Handle % Perm( Indexes(1:n) ) 6849 Handle % ActiveElement = ALL( Handle % Indexes(1:n) /= 0 ) 6850 IF(.NOT. Handle % ActiveElement ) RETURN 6851 ELSE 6852 Handle % Indexes(1:n) = [(i,i=1,4)] 6853 Handle % ActiveElement = .TRUE. 6854 END IF 6855 END IF 6856 6857 n = Handle % n 6858 IF( Handle % Dofs == 1 ) THEN 6859 val = SUM( Basis(1:n) * Handle % Values( Handle % Indexes(1:n) ) ) 6860 ELSE 6861 val = SUM( Basis(1:n) * Handle % Values( & 6862 Handle % dofs*(Handle % Indexes(1:n)-1)+dof ) ) 6863 END IF 6864 6865 END IF 6866 6867 IF( PRESENT( Found ) ) Found = .TRUE. 6868 6869 END FUNCTION ListGetElementScalarSolution 6870!------------------------------------------------------------------------------ 6871 6872!------------------------------------------------------------------------------ 6873!> Get a vector field (e.g. velocity or displacement) at the integration point. 6874!> Works with different types of fields. 6875!------------------------------------------------------------------------------ 6876 FUNCTION ListGetElementVectorSolution( Handle, Basis, Element, Found, GaussPoint, & 6877 dofs ) & 6878 RESULT ( Val3D ) 6879 6880 TYPE(VariableHandle_t) :: Handle 6881 REAL(KIND=dp), OPTIONAL :: Basis(:) 6882 TYPE( Element_t), POINTER, OPTIONAL :: Element 6883 INTEGER, OPTIONAL :: GaussPoint 6884 INTEGER, OPTIONAL :: dofs 6885 LOGICAL, OPTIONAL :: Found 6886 REAL(KIND=dp) :: Val3D(3) 6887 6888 INTEGER :: dof, Ldofs 6889 6890 Val3D = 0.0_dp 6891 6892 IF( .NOT. ASSOCIATED( Handle % Variable ) ) RETURN 6893 6894 IF( PRESENT( dofs ) ) THEN 6895 Ldofs = dofs 6896 ELSE 6897 Ldofs = MIN( 3, Handle % Dofs ) 6898 END IF 6899 6900 DO dof = 1, Ldofs 6901 Val3D(dof) = ListGetElementScalarSolution( Handle, Basis, Element, Found, & 6902 GaussPoint, dof ) 6903 IF( .NOT. Handle % ActiveElement ) RETURN 6904 END DO 6905 6906 END FUNCTION ListGetElementVectorSolution 6907 6908 6909 6910!------------------------------------------------------------------------------ 6911!> Gets a constant real array from the list by its name. 6912!------------------------------------------------------------------------------ 6913 RECURSIVE FUNCTION ListGetConstRealArray( List,Name,Found,UnfoundFatal ) RESULT( F ) 6914!------------------------------------------------------------------------------ 6915 TYPE(ValueList_t), POINTER :: List 6916 CHARACTER(LEN=*) :: Name 6917 LOGICAL, OPTIONAL :: Found, UnfoundFatal 6918!------------------------------------------------------------------------------ 6919 REAL(KIND=dp), POINTER :: F(:,:) 6920 INTEGER :: i,j,N1,N2 6921 TYPE(ValueListEntry_t), POINTER :: ptr 6922!------------------------------------------------------------------------------ 6923 NULLIFY( F ) 6924 ptr => ListFind(List,Name,Found) 6925 IF (.NOT.ASSOCIATED(ptr) ) THEN 6926 IF(PRESENT(UnfoundFatal)) THEN 6927 IF(UnfoundFatal) THEN 6928 CALL Fatal("ListGetConstRealArray", "Failed to find: "//TRIM(Name) ) 6929 END IF 6930 END IF 6931 RETURN 6932 END IF 6933 6934 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 6935 WRITE(Message,*) 'Value type for property [', TRIM(Name), & 6936 '] not used consistently.' 6937 CALL Fatal( 'ListGetConstRealArray', Message ) 6938 RETURN 6939 END IF 6940 6941 N1 = SIZE( ptr % FValues,1 ) 6942 N2 = SIZE( ptr % FValues,2 ) 6943 6944 F => ptr % FValues(:,:,1) 6945 6946 IF ( ptr % PROCEDURE /= 0 ) THEN 6947 CALL ListPushActiveName(name) 6948 DO i=1,N1 6949 DO j=1,N2 6950 F(i,j) = ExecConstRealFunction( ptr % PROCEDURE,CurrentModel,0.0d0,0.0d0,0.0d0 ) 6951 END DO 6952 END DO 6953 CALL ListPopActiveName() 6954 END IF 6955 END FUNCTION ListGetConstRealArray 6956!------------------------------------------------------------------------------ 6957 6958 6959!------------------------------------------------------------------------------ 6960!> Gets an 1D constant real array from the list by its name. 6961!------------------------------------------------------------------------------ 6962 RECURSIVE FUNCTION ListGetConstRealArray1( List,Name,Found,UnfoundFatal ) RESULT( F ) 6963!------------------------------------------------------------------------------ 6964 TYPE(ValueList_t), POINTER :: List 6965 CHARACTER(LEN=*) :: Name 6966 LOGICAL, OPTIONAL :: Found, UnfoundFatal 6967!------------------------------------------------------------------------------ 6968 REAL(KIND=dp), POINTER :: F(:) 6969 INTEGER :: i,j,N1,N2 6970 TYPE(ValueListEntry_t), POINTER :: ptr 6971!------------------------------------------------------------------------------ 6972 NULLIFY( F ) 6973 ptr => ListFind(List,Name,Found) 6974 IF (.NOT.ASSOCIATED(ptr) ) THEN 6975 IF(PRESENT(UnfoundFatal)) THEN 6976 IF(UnfoundFatal) THEN 6977 CALL Fatal("ListGetConstRealArray1","Failed to find: "//TRIM(Name)) 6978 END IF 6979 END IF 6980 RETURN 6981 END IF 6982 6983 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 6984 WRITE(Message,*) 'Value type for property [', TRIM(Name), & 6985 '] not used consistently.' 6986 CALL Fatal( 'ListGetConstRealArray1', Message ) 6987 RETURN 6988 END IF 6989 6990 N1 = SIZE( ptr % FValues,1 ) 6991 N2 = SIZE( ptr % FValues,2 ) 6992 IF( N2 > 1 ) THEN 6993 CALL Warn('ListGetConstRealArray1','The routine is designed for 1D arrays!') 6994 END IF 6995 6996 F => ptr % FValues(:,1,1) 6997 6998 END FUNCTION ListGetConstRealArray1 6999!------------------------------------------------------------------------------ 7000 7001 7002 7003!------------------------------------------------------------------------------ 7004!> Gets a real array from the list by its name, 7005!------------------------------------------------------------------------------ 7006 RECURSIVE SUBROUTINE ListGetRealArray( List,Name,F,N,NodeIndexes,Found ) 7007!------------------------------------------------------------------------------ 7008 TYPE(ValueList_t), POINTER :: List 7009 CHARACTER(LEN=*) :: Name 7010 LOGICAL, OPTIONAL :: Found 7011 INTEGER :: N,NodeIndexes(:) 7012 REAL(KIND=dp), POINTER :: F(:,:,:), G(:,:) 7013!------------------------------------------------------------------------------ 7014 TYPE(ValueListEntry_t), POINTER :: ptr 7015 7016 TYPE(Variable_t), POINTER :: Variable, CVar, TVar 7017 7018 REAL(KIND=dp) :: T(MAX_FNC) 7019 INTEGER :: i,j,k,nlen,N1,N2,k1,l 7020 CHARACTER(LEN=2048) :: tmp_str, cmd 7021 LOGICAL :: AllGlobal 7022!------------------------------------------------------------------------------ 7023 ptr => ListFind(List,Name,Found) 7024 IF ( .NOT.ASSOCIATED(ptr) ) RETURN 7025 7026 7027 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 7028 CALL Fatal( 'ListGetRealArray', & 7029 'Value type for property > '// TRIM(Name) // '< not used consistently.') 7030 END IF 7031 7032 N1 = SIZE(ptr % FValues,1) 7033 N2 = SIZE(ptr % FValues,2) 7034 7035 IF ( .NOT.ASSOCIATED( F ) ) THEN 7036 ALLOCATE( F(N1,N2,N) ) 7037 ELSE IF ( SIZE(F,1)/=N1.OR.SIZE(F,2)/=N2.OR.SIZE(F,3)/= N ) THEN 7038 DEALLOCATE( F ) 7039 ALLOCATE( F(N1,N2,N) ) 7040 END IF 7041 7042 7043 SELECT CASE(ptr % TYPE) 7044 CASE ( LIST_TYPE_CONSTANT_TENSOR ) 7045 DO i=1,n 7046 F(:,:,i) = ptr % Coeff * ptr % FValues(:,:,1) 7047 END DO 7048 7049 IF ( ptr % PROCEDURE /= 0 ) THEN 7050 CALL ListPushActiveName(name) 7051 DO i=1,N1 7052 DO j=1,N2 7053 F(i,j,1) = ptr % Coeff * & 7054 ExecConstRealFunction( ptr % PROCEDURE, & 7055 CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp ) 7056 END DO 7057 END DO 7058 CALL ListPopActiveName() 7059 END IF 7060 7061 7062 CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR ) 7063 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 7064 WRITE( cmd, '(a,e15.8)' ) 'tx=0; st = ', TVar % Values(1) 7065 k = LEN_TRIM(cmd) 7066 CALL matc( cmd, tmp_str, k ) 7067 7068 CALL ListPushActiveName(name) 7069 DO i=1,n 7070 k = NodeIndexes(i) 7071 CALL ListParseStrToValues( Ptr % DependName, Ptr % DepNameLen, k, Name, T, j, AllGlobal) 7072 IF ( ANY(T(1:j)==HUGE(1._dP)) ) CYCLE 7073 7074 IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN 7075#ifdef HAVE_LUA 7076 IF ( .not. ptr % LuaFun ) THEN 7077#endif 7078 DO l=1,j 7079 WRITE( cmd, '(a,g19.12)' ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 7080 k1 = LEN_TRIM(cmd) 7081 CALL matc( cmd, tmp_str, k1 ) 7082 END DO 7083 7084 cmd = ptr % CValue 7085 k1 = LEN_TRIM(cmd) 7086 CALL matc( cmd, tmp_str, k1 ) 7087 READ( tmp_str(1:k1), * ) ((F(j,k,i),k=1,N2),j=1,N1) 7088#ifdef HAVE_LUA 7089 ELSE 7090 call ElmerEvalLuaT(LuaState, ptr, T, F(:,:,i), j) 7091 END IF 7092#endif 7093 ELSE IF ( ptr % PROCEDURE /= 0 ) THEN 7094 G => F(:,:,i) 7095 CALL ExecRealArrayFunction( ptr % PROCEDURE, CurrentModel, & 7096 NodeIndexes(i), T, G ) 7097 ELSE 7098 DO j=1,N1 7099 DO k=1,N2 7100 F(j,k,i) = InterpolateCurve(ptr % TValues, ptr % FValues(j,k,:), & 7101 T(1), ptr % CubicCoeff ) 7102 END DO 7103 END DO 7104 END IF 7105 IF( AllGlobal ) EXIT 7106 END DO 7107 CALL ListPopActiveName() 7108 7109 IF( AllGlobal ) THEN 7110 DO i=2,n 7111 DO j=1,N1 7112 DO k=1,N2 7113 F(j,k,i) = F(j,k,1) 7114 END DO 7115 END DO 7116 END DO 7117 END IF 7118 7119 IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN 7120 F = ptr % Coeff * F 7121 END IF 7122 7123 CASE DEFAULT 7124 F = 0.0d0 7125 DO i=1,N1 7126 IF ( PRESENT( Found ) ) THEN 7127 F(i,1,:) = ListGetReal( List,Name,N,NodeIndexes,Found ) 7128 ELSE 7129 F(i,1,:) = ListGetReal( List,Name,N,NodeIndexes ) 7130 END IF 7131 END DO 7132 END SELECT 7133!------------------------------------------------------------------------------ 7134 END SUBROUTINE ListGetRealArray 7135!------------------------------------------------------------------------------ 7136 7137!------------------------------------------------------------------------------ 7138!> Gets a real vector from the list by its name 7139!------------------------------------------------------------------------------ 7140 RECURSIVE SUBROUTINE ListGetRealVector( List,Name,F,N,NodeIndexes,Found ) 7141!------------------------------------------------------------------------------ 7142 TYPE(ValueList_t), POINTER :: List 7143 CHARACTER(LEN=*) :: Name 7144 LOGICAL, OPTIONAL :: Found 7145 INTEGER :: N,NodeIndexes(:) 7146 REAL(KIND=dp), TARGET :: F(:,:) 7147!------------------------------------------------------------------------------ 7148 TYPE(ValueListEntry_t), POINTER :: ptr 7149 7150 TYPE(Variable_t), POINTER :: Variable, CVar, TVar 7151 7152 REAL(KIND=dp), ALLOCATABLE :: G(:,:) 7153 REAL(KIND=dp) :: T(MAX_FNC) 7154 REAL(KIND=dp), POINTER :: RotMatrix(:,:) 7155 INTEGER :: i,j,k,nlen,N1,N2,k1,S1,S2,l, cnt 7156 CHARACTER(LEN=2048) :: tmp_str, cmd 7157 LOGICAL :: AllGlobal, lFound, AnyFound 7158!------------------------------------------------------------------------------ 7159 ptr => ListFind(List,Name,lFound) 7160 IF ( .NOT.ASSOCIATED(ptr) ) THEN 7161 IF(PRESENT(Found)) Found = .FALSE. 7162 AnyFound = .FALSE. 7163 DO i=1,SIZE(F,1) 7164 F(i,1:n) = ListGetReal(List,TRIM(Name)//' '//TRIM(I2S(i)),n,NodeIndexes,lFound) 7165 AnyFound = AnyFound.OR.lFound 7166 END DO 7167 IF(PRESENT(Found)) THEN 7168 Found = AnyFound 7169 ELSE IF(.NOT.AnyFound) THEN 7170 CALL Warn( 'ListFind', 'Requested property ['//TRIM(Name)//'] not found') 7171 END IF 7172 IF( .NOT. AnyFound ) RETURN 7173 GOTO 200 7174 ELSE 7175 Found = lFound 7176 END IF 7177 7178 F = 0._dp 7179 cnt = 0 7180 ALLOCATE(G(SIZE(F,1),SIZE(F,2))) 7181 7182100 CONTINUE 7183 7184 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 7185 CALL Fatal( 'ListGetRealVector', & 7186 'Value type for property > '// TRIM(Name) // '< not used consistently.') 7187 END IF 7188 7189 N1 = SIZE(ptr % FValues,1) 7190 7191 SELECT CASE(ptr % TYPE) 7192 CASE ( LIST_TYPE_CONSTANT_TENSOR ) 7193 DO i=1,n 7194 G(:,i) = ptr % Coeff * ptr % FValues(:,1,1) 7195 END DO 7196 7197 IF ( ptr % PROCEDURE /= 0 ) THEN 7198 CALL ListPushActiveName(name) 7199 DO i=1,n1 7200 F(i,1) = ptr % Coeff * & 7201 ExecConstRealFunction( ptr % PROCEDURE, & 7202 CurrentModel, 0.0_dp, 0.0_dp, 0.0_dp ) 7203 END DO 7204 CALL ListPopActiveName() 7205 END IF 7206 7207 CASE( LIST_TYPE_VARIABLE_TENSOR,LIST_TYPE_VARIABLE_TENSOR_STR ) 7208 TVar => VariableGet( CurrentModel % Variables, 'Time' ) 7209 WRITE( cmd, '(a,e15.8)' ) 'tx=0; st = ', TVar % Values(1) 7210 k = LEN_TRIM(cmd) 7211 CALL matc( cmd, tmp_str, k ) 7212 7213 CALL ListPushActiveName(name) 7214 DO i=1,n 7215 k = NodeIndexes(i) 7216 CALL ListParseStrToValues( Ptr % DependName, Ptr % DepNameLen, k, Name, T, j, AllGlobal) 7217 IF ( ANY(T(1:j)==HUGE(1._dP)) ) CYCLE 7218 7219 IF ( ptr % TYPE==LIST_TYPE_VARIABLE_TENSOR_STR) THEN 7220#ifdef HAVE_LUA 7221 IF ( .not. ptr % LuaFun ) THEN 7222#endif 7223 DO l=1,j 7224 WRITE( cmd, '(a,g19.12)' ) 'tx('//TRIM(i2s(l-1))//')=', T(l) 7225 k1 = LEN_TRIM(cmd) 7226 CALL matc( cmd, tmp_str, k1 ) 7227 END DO 7228 7229 cmd = ptr % CValue 7230 k1 = LEN_TRIM(cmd) 7231 CALL matc( cmd, tmp_str, k1 ) 7232 READ( tmp_str(1:k1), * ) (G(j,i),j=1,N1) 7233#ifdef HAVE_LUA 7234 ELSE 7235 call ElmerEvalLuaV(LuaState, ptr, T, G(:,i), j) 7236 END IF 7237#endif 7238 ELSE IF ( ptr % PROCEDURE /= 0 ) THEN 7239 CALL ExecRealVectorFunction( ptr % PROCEDURE, CurrentModel, & 7240 NodeIndexes(i), T, G(:,i) ) 7241 ELSE 7242 DO k=1,n1 7243 G(k,i) = InterpolateCurve(ptr % TValues, & 7244 ptr % FValues(k,1,:), T(MIN(j,k)), ptr % CubicCoeff ) 7245 END DO 7246 END IF 7247 7248 IF( AllGlobal ) EXIT 7249 END DO 7250 CALL ListPopActiveName() 7251 7252 IF( AllGlobal ) THEN 7253 DO i=2,n 7254 DO j=1,N1 7255 G(j,i) = G(j,1) 7256 END DO 7257 END DO 7258 END IF 7259 7260 IF( ABS( ptr % Coeff - 1.0_dp ) > EPSILON( ptr % Coeff ) ) THEN 7261 G = ptr % Coeff * G 7262 END IF 7263 7264 CASE DEFAULT 7265 G = 0.0d0 7266 DO i=1,N1 7267 IF ( PRESENT( Found ) ) THEN 7268 G(i,:) = ListGetReal( List,Name,N,NodeIndexes,Found ) 7269 ELSE 7270 G(i,:) = ListGetReal( List,Name,N,NodeIndexes ) 7271 END IF 7272 END DO 7273 END SELECT 7274 7275 7276 F = F + G 7277 cnt = cnt + 1 7278 ptr => ListFind(List,Name//'{'//TRIM(I2S(cnt))//'}',lFound) 7279 IF(ASSOCIATED(ptr)) GOTO 100 7280 7281200 IF( ListGetLogical( List, Name//' Property Rotate', lFound ) ) THEN 7282 RotMatrix => ListGetConstRealArray( List,'Property Rotation Matrix',lFound ) 7283 IF( .NOT. ASSOCIATED( RotMatrix ) ) THEN 7284 CALL Fatal('ListGetRealVector','Property rotation matrix not given for: '//TRIM(Name)) 7285 END IF 7286 IF( SIZE(F,1) /= 3 ) THEN 7287 CALL Fatal('ListGetRealVector','Property may be rotated only with three components!') 7288 END IF 7289 DO i = 1,SIZE(F,2) 7290 F(1:3,i) = MATMUL( RotMatrix, F(1:3,i) ) 7291 END DO 7292 END IF 7293 7294 7295!------------------------------------------------------------------------------ 7296 END SUBROUTINE ListGetRealVector 7297!------------------------------------------------------------------------------ 7298 7299 7300!------------------------------------------------------------------------------ 7301!> Gets a real derivative from. This is only available for tables with dependencies. 7302!------------------------------------------------------------------------------ 7303 RECURSIVE FUNCTION ListGetDerivValue(List,Name,N,NodeIndexes,dT) RESULT(F) 7304!------------------------------------------------------------------------------ 7305 TYPE(ValueList_t), POINTER :: List 7306 CHARACTER(LEN=*) :: Name 7307 INTEGER :: N,NodeIndexes(:) 7308 REAL(KIND=dp), OPTIONAL :: dT 7309 REAL(KIND=dp) :: F(N) 7310!------------------------------------------------------------------------------ 7311 TYPE(Variable_t), POINTER :: Variable 7312 TYPE(ValueListEntry_t), POINTER :: ptr 7313 INTEGER :: i,k,l 7314 REAL(KIND=dp) :: T,T1(1),T2(1),F1,F2 7315!------------------------------------------------------------------------------ 7316 7317 F = 0.0D0 7318 ptr => ListFind(List,Name) 7319 7320 7321 IF ( .NOT.ASSOCIATED(ptr) ) RETURN 7322 7323 7324 SELECT CASE(ptr % TYPE) 7325 CASE( LIST_TYPE_VARIABLE_SCALAR ) 7326 7327 IF ( ptr % PROCEDURE /= 0 ) THEN 7328 IF( .NOT. PRESENT( dT ) ) THEN 7329 CALL Fatal('ListGetDerivValue','Numerical derivative of function requires dT') 7330 END IF 7331 Variable => VariableGet( CurrentModel % Variables,ptr % DependName ) 7332 IF( .NOT. ASSOCIATED( Variable ) ) THEN 7333 CALL Fatal('ListGetDeriveValue','Cannot derivate with variable: '//TRIM(ptr % DependName)) 7334 END IF 7335 7336 DO i=1,n 7337 k = NodeIndexes(i) 7338 IF ( ASSOCIATED(Variable % Perm) ) k = Variable % Perm(k) 7339 IF ( k > 0 ) THEN 7340 T = Variable % Values(k) 7341 T1(1) = T + 0.5_dp * dT 7342 T2(1) = T - 0.5_dp * dT 7343 F1 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndexes(i), T1 ) 7344 F2 = ExecRealFunction( ptr % PROCEDURE,CurrentModel, NodeIndexes(i), T2 ) 7345 F(i) = ptr % Coeff * ( F1 - F2 ) / dT 7346 END IF 7347 END DO 7348 7349 ELSE 7350 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 7351 CALL Fatal( 'ListGetDerivValue', & 7352 'Value type for property > '// TRIM(Name) // '< not used consistently.') 7353 END IF 7354 Variable => VariableGet( CurrentModel % Variables,ptr % DependName ) 7355 IF( .NOT. ASSOCIATED( Variable ) ) THEN 7356 CALL Fatal('ListGetDeriveValue','Cannot derivate with variable: '//TRIM(ptr % DependName)) 7357 END IF 7358 DO i=1,n 7359 k = NodeIndexes(i) 7360 IF ( ASSOCIATED(Variable % Perm) ) k = Variable % Perm(k) 7361 IF ( k > 0 ) THEN 7362 T = Variable % Values(k) 7363 F(i) = ptr % Coeff * & 7364 DerivateCurve(ptr % TValues,ptr % FValues(1,1,:), & 7365 T, ptr % CubicCoeff ) 7366 END IF 7367 END DO 7368 END IF 7369 7370 7371 CASE DEFAULT 7372 CALL Fatal( 'ListGetDerivValue', & 7373 'No automated derivation possible for > '//TRIM(Name)//' <' ) 7374 7375 END SELECT 7376 7377 7378 END FUNCTION ListGetDerivValue 7379!------------------------------------------------------------------------------ 7380 7381 7382!------------------------------------------------------------------------------ 7383!> Given the body of a keyword find the 1st free keyword in the list structure. 7384!> The intended use for this is in Solver_init to decleare exported variables 7385!> without the risk of running over some existing ones. 7386!------------------------------------------------------------------------------ 7387 FUNCTION NextFreeKeyword(keyword0,List) RESULT (Keyword) 7388 7389 CHARACTER(LEN=*) :: Keyword0 7390 TYPE(ValueList_t), POINTER :: List 7391 CHARACTER(LEN=MAX_NAME_LEN) :: Keyword 7392 INTEGER :: No 7393 7394 DO No = 1, 9999 7395 WRITE( Keyword,'(A,I0)') TRIM(Keyword0)//' ',No 7396 IF( .NOT. ListCheckPresent(List,Keyword)) EXIT 7397 END DO 7398 7399!------------------------------------------------------------------------------ 7400 END FUNCTION NextFreeKeyword 7401!------------------------------------------------------------------------------ 7402 7403 7404!------------------------------------------------------------------------------ 7405!> Check if the keyword is present in any boundary condition. 7406!------------------------------------------------------------------------------ 7407 FUNCTION ListCheckPresentAnyBC( Model, Name ) RESULT(Found) 7408!------------------------------------------------------------------------------ 7409 TYPE(Model_t) :: Model 7410 CHARACTER(LEN=*) :: Name 7411 LOGICAL :: Found 7412 INTEGER :: bc 7413 7414 Found = .FALSE. 7415 DO bc = 1,Model % NumberOfBCs 7416 Found = ListCheckPresent( Model % BCs(bc) % Values, Name ) 7417 IF( Found ) EXIT 7418 END DO 7419!------------------------------------------------------------------------------ 7420 END FUNCTION ListCheckPresentAnyBC 7421!------------------------------------------------------------------------------ 7422 7423!------------------------------------------------------------------------------ 7424!> Check if the keyword is present in any boundary condition. 7425!------------------------------------------------------------------------------ 7426 FUNCTION ListCheckPresentAnyIC( Model, Name ) RESULT(Found) 7427!------------------------------------------------------------------------------ 7428 TYPE(Model_t) :: Model 7429 CHARACTER(LEN=*) :: Name 7430 LOGICAL :: Found 7431 INTEGER :: ic 7432 7433 Found = .FALSE. 7434 DO ic = 1,Model % NumberOfICs 7435 Found = ListCheckPresent( Model % ICs(ic) % Values, Name ) 7436 IF( Found ) EXIT 7437 END DO 7438!------------------------------------------------------------------------------ 7439 END FUNCTION ListCheckPresentAnyIC 7440!------------------------------------------------------------------------------ 7441 7442!------------------------------------------------------------------------------ 7443!> Check if the keyword is True in any boundary condition. 7444!------------------------------------------------------------------------------ 7445 FUNCTION ListGetLogicalAnyBC( Model, Name ) RESULT(Found) 7446!------------------------------------------------------------------------------ 7447 TYPE(Model_t) :: Model 7448 CHARACTER(LEN=*) :: Name 7449 LOGICAL :: Found, GotIt 7450 INTEGER :: bc 7451 7452 Found = .FALSE. 7453 DO bc = 1,Model % NumberOfBCs 7454 Found = ListgetLogical( Model % BCs(bc) % Values, Name, GotIt ) 7455 IF( Found ) EXIT 7456 END DO 7457!------------------------------------------------------------------------------ 7458 END FUNCTION ListGetLogicalAnyBC 7459!------------------------------------------------------------------------------ 7460 7461 7462!------------------------------------------------------------------------------ 7463!> Check if the keyword is present in any body. 7464!------------------------------------------------------------------------------ 7465 FUNCTION ListCheckPresentAnyBody( Model, Name ) RESULT(Found) 7466!------------------------------------------------------------------------------ 7467 TYPE(Model_t) :: Model 7468 CHARACTER(LEN=*) :: Name 7469 LOGICAL :: Found 7470 INTEGER :: body 7471 7472 Found = .FALSE. 7473 DO body = 1,Model % NumberOfBodies 7474 Found = ListCheckPresent( Model % Bodies(body) % Values, Name ) 7475 IF( Found ) EXIT 7476 END DO 7477!------------------------------------------------------------------------------ 7478 END FUNCTION ListCheckPresentAnyBody 7479!------------------------------------------------------------------------------ 7480 7481!------------------------------------------------------------------------------ 7482!> Check if the keyword is true in any body. 7483!------------------------------------------------------------------------------ 7484 FUNCTION ListGetLogicalAnyBody( Model, Name ) RESULT(Found) 7485!------------------------------------------------------------------------------ 7486 TYPE(Model_t) :: Model 7487 CHARACTER(LEN=*) :: Name 7488 LOGICAL :: Found 7489 INTEGER :: body 7490 LOGICAL :: GotIt 7491 7492 Found = .FALSE. 7493 DO body = 1,Model % NumberOfBodies 7494 Found = ListGetLogical( Model % Bodies(body) % Values, Name, GotIt ) 7495 IF( Found ) EXIT 7496 END DO 7497!------------------------------------------------------------------------------ 7498 END FUNCTION ListGetLogicalAnyBody 7499!------------------------------------------------------------------------------ 7500 7501 7502!------------------------------------------------------------------------------ 7503!> Check if the keyword is true in any body. 7504!------------------------------------------------------------------------------ 7505 FUNCTION ListGetCRealAnyBody( Model, Name, Found ) RESULT( F ) 7506!------------------------------------------------------------------------------ 7507 TYPE(Model_t) :: Model 7508 CHARACTER(LEN=*) :: Name 7509 LOGICAL, OPTIONAL :: Found 7510 REAL(KIND=dp) :: F 7511 7512 INTEGER :: body 7513 LOGICAL :: GotIt 7514 7515 F = 0.0_dp 7516 GotIt = .FALSE. 7517 DO body = 1,Model % NumberOfBodies 7518 F = ListGetCReal( Model % Bodies(body) % Values, Name, GotIt ) 7519 IF( GotIt ) EXIT 7520 END DO 7521 7522 IF( PRESENT( Found ) ) Found = GotIt 7523 7524!------------------------------------------------------------------------------ 7525 END FUNCTION ListGetCRealAnyBody 7526!------------------------------------------------------------------------------ 7527 7528!------------------------------------------------------------------------------ 7529!> Check if the keyword is present in any body force. 7530!------------------------------------------------------------------------------ 7531 FUNCTION ListCheckPresentAnyBodyForce( Model, Name ) RESULT(Found) 7532!------------------------------------------------------------------------------ 7533 TYPE(Model_t) :: Model 7534 CHARACTER(LEN=*) :: Name 7535 LOGICAL :: Found 7536 INTEGER :: bf 7537 7538 Found = .FALSE. 7539 DO bf = 1,Model % NumberOfBodyForces 7540 Found = ListCheckPresent( Model % BodyForces(bf) % Values, Name ) 7541 IF( Found ) EXIT 7542 END DO 7543!------------------------------------------------------------------------------ 7544 END FUNCTION ListCheckPresentAnyBodyForce 7545!------------------------------------------------------------------------------ 7546 7547!------------------------------------------------------------------------------ 7548!> Check if the keyword is True in any body force. 7549!------------------------------------------------------------------------------ 7550 FUNCTION ListGetLogicalAnyBodyForce( Model, Name ) RESULT(Found) 7551!------------------------------------------------------------------------------ 7552 TYPE(Model_t) :: Model 7553 CHARACTER(LEN=*) :: Name 7554 LOGICAL :: Found, GotIt 7555 INTEGER :: bf 7556 7557 Found = .FALSE. 7558 DO bf = 1,Model % NumberOfBodyForces 7559 Found = ListGetLogical( Model % BodyForces(bf) % Values, Name, GotIt ) 7560 IF( Found ) EXIT 7561 END DO 7562!------------------------------------------------------------------------------ 7563 END FUNCTION ListGetLogicalAnyBodyForce 7564!------------------------------------------------------------------------------ 7565 7566!------------------------------------------------------------------------------ 7567!> Check if the keyword is present in any material. 7568!------------------------------------------------------------------------------ 7569 FUNCTION ListCheckPresentAnyMaterial( Model, Name ) RESULT(Found) 7570!------------------------------------------------------------------------------ 7571 TYPE(Model_t) :: Model 7572 CHARACTER(LEN=*) :: Name 7573 LOGICAL :: Found 7574 INTEGER :: mat 7575 7576 Found = .FALSE. 7577 DO mat = 1,Model % NumberOfMaterials 7578 Found = ListCheckPresent( Model % Materials(mat) % Values, Name ) 7579 IF( Found ) EXIT 7580 END DO 7581!------------------------------------------------------------------------------ 7582 END FUNCTION ListCheckPresentAnyMaterial 7583!------------------------------------------------------------------------------ 7584 7585 7586!------------------------------------------------------------------------------ 7587!> Check if the keyword is present in any solver. 7588!------------------------------------------------------------------------------ 7589 FUNCTION ListCheckPresentAnySolver( Model, Name ) RESULT(Found) 7590!------------------------------------------------------------------------------ 7591 TYPE(Model_t) :: Model 7592 CHARACTER(LEN=*) :: Name 7593 LOGICAL :: Found 7594 INTEGER :: ind 7595 7596 Found = .FALSE. 7597 DO ind = 1,Model % NumberOfSolvers 7598 Found = ListCheckPresent( Model % Solvers(ind) % Values, Name ) 7599 IF( Found ) EXIT 7600 END DO 7601!------------------------------------------------------------------------------ 7602 END FUNCTION ListCheckPresentAnySolver 7603!------------------------------------------------------------------------------ 7604 7605 7606 7607!------------------------------------------------------------------------------ 7608!> Check if the keyword is present in any component. 7609!------------------------------------------------------------------------------ 7610 FUNCTION ListCheckPresentAnyComponent( Model, Name ) RESULT( Found ) 7611!------------------------------------------------------------------------------ 7612 IMPLICIT NONE 7613 7614 TYPE(Model_t) :: Model 7615 CHARACTER(LEN=*) :: Name 7616 LOGICAL :: Found 7617 INTEGER :: ind 7618 7619 Found = .FALSE. 7620 DO ind=1, Model % NumberOfComponents 7621 Found = ListCheckPresent( Model % Components(ind) % Values, Name ) 7622 IF( Found ) EXIT 7623 END DO 7624!------------------------------------------------------------------------------ 7625 END FUNCTION ListCheckPresentAnyComponent 7626!------------------------------------------------------------------------------ 7627 7628 !------------------------------------------------------------------------------ 7629!> Check if the keyword is true in any component. 7630!------------------------------------------------------------------------------ 7631 FUNCTION ListGetLogicalAnyComponent( Model, Name ) RESULT( Found ) 7632!------------------------------------------------------------------------------ 7633 IMPLICIT NONE 7634 7635 TYPE(Model_t) :: Model 7636 CHARACTER(LEN=*) :: Name 7637 LOGICAL :: Found, GotIt 7638 INTEGER :: ind 7639 7640 Found = .FALSE. 7641 DO ind=1, Model % NumberOfComponents 7642 Found = ListGetLogical( Model % Components(ind) % Values, Name, GotIt ) 7643 IF( Found ) EXIT 7644 END DO 7645!------------------------------------------------------------------------------ 7646 END FUNCTION ListGetLogicalAnyComponent 7647!------------------------------------------------------------------------------ 7648 7649!------------------------------------------------------------------------------ 7650!> Check if the keyword in any material is defined as an array 7651!------------------------------------------------------------------------------ 7652 FUNCTION ListCheckAnyMaterialIsArray( Model, Name ) RESULT(IsArray) 7653!------------------------------------------------------------------------------ 7654 TYPE(Model_t) :: Model 7655 CHARACTER(LEN=*) :: Name 7656 LOGICAL :: IsArray 7657 LOGICAL :: Found 7658 INTEGER :: mat, n1, n2 7659 TYPE(ValueListEntry_t), POINTER :: ptr 7660 7661 IsArray = .FALSE. 7662 DO mat = 1,Model % NumberOfMaterials 7663 ptr => ListFind(Model % Materials(mat) % Values,Name,Found) 7664 IF( .NOT. ASSOCIATED( ptr ) ) CYCLE 7665 IF ( .NOT. ASSOCIATED(ptr % FValues) ) THEN 7666 WRITE(Message,*) 'Value type for property [', TRIM(Name), & 7667 '] not used consistently.' 7668 CALL Fatal( 'ListCheckAnyMaterialArray', Message ) 7669 END IF 7670 n1 = SIZE( ptr % FValues,1 ) 7671 n2 = SIZE( ptr % FValues,2 ) 7672 IsArray = ( n1 > 1 ) .OR. ( n2 > 1 ) 7673 IF( IsArray ) EXIT 7674 END DO 7675!------------------------------------------------------------------------------ 7676 END FUNCTION ListCheckAnyMaterialIsArray 7677!------------------------------------------------------------------------------ 7678 7679 7680!------------------------------------------------------------------------------ 7681!> Check if the keyword is True in any material. 7682!------------------------------------------------------------------------------ 7683 FUNCTION ListGetLogicalAnyMaterial( Model, Name ) RESULT(Found) 7684!------------------------------------------------------------------------------ 7685 TYPE(Model_t) :: Model 7686 CHARACTER(LEN=*) :: Name 7687 LOGICAL :: Found, GotIt 7688 INTEGER :: mat 7689 7690 Found = .FALSE. 7691 DO mat = 1,Model % NumberOfMaterials 7692 Found = ListGetLogical( Model % Materials(mat) % Values, Name, GotIt ) 7693 IF( Found ) EXIT 7694 END DO 7695!------------------------------------------------------------------------------ 7696 END FUNCTION ListGetLogicalAnyMaterial 7697!------------------------------------------------------------------------------ 7698 7699 7700!------------------------------------------------------------------------------ 7701!> Check if the keyword is True in any solver. 7702!------------------------------------------------------------------------------ 7703 FUNCTION ListGetLogicalAnySolver( Model, Name ) RESULT(Found) 7704!------------------------------------------------------------------------------ 7705 TYPE(Model_t) :: Model 7706 CHARACTER(LEN=*) :: Name 7707 LOGICAL :: Found, GotIt 7708 INTEGER :: ind 7709 7710 Found = .FALSE. 7711 DO ind = 1,Model % NumberOfSolvers 7712 Found = ListGetLogical( Model % Solvers(ind) % Values, Name, GotIt ) 7713 IF( Found ) EXIT 7714 END DO 7715!------------------------------------------------------------------------------ 7716 END FUNCTION ListGetLogicalAnySolver 7717!------------------------------------------------------------------------------ 7718 7719 7720!------------------------------------------------------------------------------ 7721!> Check if the keyword is present in any equation. 7722!------------------------------------------------------------------------------ 7723 FUNCTION ListCheckPresentAnyEquation( Model, Name ) RESULT(Found) 7724!------------------------------------------------------------------------------ 7725 TYPE(Model_t) :: Model 7726 CHARACTER(LEN=*) :: Name 7727 LOGICAL :: Found 7728 INTEGER :: eq 7729 7730 Found = .FALSE. 7731 DO eq = 1,Model % NumberOfEquations 7732 Found = ListCheckPresent( Model % Equations(eq) % Values, Name ) 7733 IF( Found ) EXIT 7734 END DO 7735!------------------------------------------------------------------------------ 7736 END FUNCTION ListCheckPresentAnyEquation 7737!------------------------------------------------------------------------------ 7738 7739!------------------------------------------------------------------------------ 7740!> Check if the keyword is True in any equation. 7741!------------------------------------------------------------------------------ 7742 FUNCTION ListGetLogicalAnyEquation( Model, Name ) RESULT(Found) 7743!------------------------------------------------------------------------------ 7744 TYPE(Model_t) :: Model 7745 CHARACTER(LEN=*) :: Name 7746 LOGICAL :: Found, GotIt 7747 INTEGER :: eq 7748 7749 Found = .FALSE. 7750 DO eq = 1,Model % NumberOfEquations 7751 Found = ListGetLogical( Model % Equations(eq) % Values, Name, GotIt ) 7752 IF( Found ) EXIT 7753 END DO 7754!------------------------------------------------------------------------------ 7755 END FUNCTION ListGetLogicalAnyEquation 7756!------------------------------------------------------------------------------ 7757 7758 7759!------------------------------------------------------------------------------ 7760!> Elmer may include scalar and vector variables which may be known by their 7761!> original name or have an alias. For historical reasons they are introduced 7762!> by two quite separate ways. This subroutine tries to make the definition of 7763!> variables for saving more straight-forward. 7764!------------------------------------------------------------------------------ 7765 SUBROUTINE CreateListForSaving( Model, List, ShowVariables, ClearList, & 7766 UseGenericKeyword ) 7767!------------------------------------------------------------------------------ 7768 IMPLICIT NONE 7769!------------------------------------------------------------------------------ 7770 TYPE(Model_t) :: Model 7771 TYPE(ValueList_t), POINTER :: List 7772 LOGICAL :: ShowVariables 7773 LOGICAL, OPTIONAL :: ClearList 7774 LOGICAL, OPTIONAL :: UseGenericKeyword 7775!------------------------------------------------------------------------------ 7776 INTEGER :: i,j,k,l,LoopDim, VarDim,FullDim,DOFs,dim,Comp 7777 TYPE(Variable_t), POINTER :: Variables, Var, Var1 7778 CHARACTER(LEN=MAX_NAME_LEN) :: VarName, VarStr, VarStrComp, VarStrExt, str 7779 LOGICAL :: IsVector, Set, GotIt, ComponentVector, ThisOnly, IsIndex, & 7780 EnforceVectors, UseGeneric, DisplacementV 7781 INTEGER :: Nvector, Nscalar 7782 TYPE(ValueList_t), POINTER :: Params 7783 7784 Params => Model % Solver % Values 7785 Variables => Model % Mesh % Variables 7786 7787 IF( .NOT. ASSOCIATED( Variables ) ) THEN 7788 CALL Warn('CreateListForSaving','Mesh does not include any variables!') 7789 RETURN 7790 END IF 7791 7792 UseGeneric = .FALSE. 7793 IF( PRESENT( UseGenericKeyword ) ) THEN 7794 UseGeneric = UseGenericKeyword 7795 END IF 7796 7797 7798!------------------------------------------------------------------------------ 7799! Sometimes the list must be cleared in order to use it for a different mesh 7800!----------------------------------------------------------------------------- 7801 IF( PRESENT( ClearList ) ) THEN 7802 IF( ClearList ) THEN 7803 IF( UseGeneric ) THEN 7804 DO i=1,999 7805 WRITE(VarStr,'(A,I0)') 'Variable ',i 7806 IF( ListCheckPresent( List, VarStr ) ) THEN 7807 CALL ListRemove( List, VarStr ) 7808 ELSE 7809 EXIT 7810 END IF 7811 END DO 7812 ELSE 7813 DO i=1,999 7814 WRITE(VarStr,'(A,I0)') 'Scalar Field ',i 7815 IF( ListCheckPresent( List, VarStr ) ) THEN 7816 CALL ListRemove( List, VarStr ) 7817 ELSE 7818 EXIT 7819 END IF 7820 END DO 7821 7822 DO i=1,999 7823 WRITE(VarStr,'(A,I0)') 'Vector Field ',i 7824 IF( ListCheckPresent( List, VarStr ) ) THEN 7825 CALL ListRemove( List, VarStr ) 7826 ELSE 7827 EXIT 7828 END IF 7829 7830 WRITE(VarStr,'(A,I0,A)') 'Vector Field ',i,' Complement' 7831 IF( ListCheckPresent( List, VarStr ) ) THEN 7832 CALL ListRemove( List, VarStr ) 7833 END IF 7834 END DO 7835 7836 END IF 7837 END IF 7838 END IF 7839 7840 !------------------------------------------------------------------- 7841 ! First check that there is a need to create the list i.e. it is not 7842 ! already manually defined 7843 !------------------------------------------------------------------- 7844 IF( UseGeneric ) THEN 7845 IF( ListCheckPresent( List,'Variable 1' ) ) THEN 7846 CALL Info('CreateListForSaving','Variable 1 exists, creating no list!',Level=10) 7847 RETURN 7848 END IF 7849 ELSE 7850 IF( ListCheckPresent( List,'Scalar Field 1' ) ) THEN 7851 CALL Info('CreateListForSaving','Scalar Field 1 exists, creating no list!',Level=10) 7852 RETURN 7853 END IF 7854 7855 IF( ListCheckPresent( List,'Vector Field 1' ) ) THEN 7856 CALL Info('CreateListForSaving','Vector Field 1 exists, creating no list!',Level=10) 7857 RETURN 7858 END IF 7859 END IF 7860 7861 Nscalar = 0 7862 Nvector = 0 7863 7864 7865 ThisOnly = .NOT. ListGetLogical( Params,'Interpolate Fields',GotIt) 7866 dim = Model % Mesh % MeshDim 7867 7868 EnforceVectors = ListGetLogical( Params,'Enforce Vectors',GotIt) 7869 IF(.NOT. GotIt ) EnforceVectors = .TRUE. 7870 7871 7872 ! For historical reasons treat "displacement" in a special way 7873 ! but only if it exists as vector. Otherwise it will be treated by its components. 7874 ! This fixes output for the elasticity solver in case of mixed solution. 7875 Var => Variables 7876 DisplacementV = .FALSE. 7877 DO WHILE( ASSOCIATED( Var ) ) 7878 IF( Var % Name == 'displacement' ) DisplacementV = .TRUE. 7879 Var => Var % Next 7880 END DO 7881 7882 7883 Var => Variables 7884 7885 DO WHILE( ASSOCIATED( Var ) ) 7886 ! Skip if variable is not active for saving 7887 IF ( .NOT. Var % Output ) THEN 7888 Var => Var % Next 7889 CYCLE 7890 END IF 7891 7892 ! Skip if variable is global one 7893 IF ( SIZE( Var % Values ) == Var % DOFs ) THEN 7894 Var => Var % Next 7895 CYCLE 7896 END IF 7897 7898 IF( Var % TYPE == Variable_global ) THEN 7899 Var => Var % Next 7900 CYCLE 7901 ELSE IF( Var % TYPE == Variable_on_gauss_points ) THEN 7902 CONTINUE 7903 7904 ELSE IF( Var % TYPE == Variable_on_elements ) THEN 7905 CONTINUE 7906 7907 END IF 7908 7909 ! Skip if variable is otherwise strange in size 7910 IF(.NOT. ASSOCIATED( Var % Perm ) ) THEN 7911 IF( Var % TYPE == Variable_on_nodes ) THEN 7912 IF( SIZE( Var % Values ) /= Var % Dofs * Model % Mesh % NumberOfNodes ) THEN 7913 Var => Var % Next 7914 CYCLE 7915 END IF 7916 ELSE IF( Var % TYPE == Variable_on_nodes_on_elements ) THEN 7917 IF( SIZE( Var % Values ) /= Var % Dofs * Model % Mesh % NumberOfBulkElements ) THEN 7918 Var => Var % Next 7919 CYCLE 7920 END IF 7921 END IF 7922 END IF 7923 7924 VarDim = Var % Dofs 7925 IsVector = (VarDim > 1) 7926 Set = .FALSE. 7927 7928 WRITE(VarName,'(A)') TRIM(Var % Name) 7929 7930 SELECT CASE(Var % Name) 7931 7932 CASE( 'coordinate 1','coordinate 2','coordinate 3' ) 7933 ! These are treated separatetely as coordinates are not typically saved 7934 7935 7936 CASE( 'mesh update' ) 7937 ! Mesh update is treated separately because its special connection to displacement 7938 Set = .TRUE. 7939 IF(.NOT. UseGeneric ) THEN 7940 Var1 => Variables 7941 DO WHILE( ASSOCIATED( Var1 ) ) 7942 IF ( TRIM(Var1 % Name) == 'displacement' ) EXIT 7943 Var1 => Var1 % Next 7944 END DO 7945 IF ( ASSOCIATED( Var1 ) ) Set = .FALSE. 7946 END IF 7947 7948 CASE('mesh update 1','mesh update 2', 'mesh update 3' ) 7949 7950 CASE( 'displacement' ) 7951 Set = .TRUE. 7952 ! mesh update is by default the complement to displacement 7953 ! However, for generic variablelist the complement is not active 7954 IF(.NOT. UseGeneric ) THEN 7955 Var1 => Variables 7956 DO WHILE( ASSOCIATED( Var1 ) ) 7957 IF ( TRIM(Var1 % Name) == 'mesh update' ) EXIT 7958 Var1 => Var1 % Next 7959 END DO 7960 IF ( ASSOCIATED( Var1 ) ) THEN 7961 WRITE(VarStrComp,'(A,I0,A)') 'Vector Field ',Nvector+1,' Complement' 7962 CALL ListAddString( List ,TRIM(VarStrComp),'mesh update') 7963 END IF 7964 END IF 7965 7966 !CASE( 'displacement 1','displacement 2','displacement 3') 7967 7968 7969 CASE DEFAULT 7970 ! All vector variables are assumed to be saved using its components 7971 ! rather than vector itself. 7972 IF ( VarDim == 1 ) THEN 7973 Set = .TRUE. 7974 7975 str = ' ' 7976 j = LEN_TRIM(Var % Name) 7977 DO i=1,j 7978 str(i:i) = Var % Name(i:i) 7979 END DO 7980 7981 IsIndex = .FALSE. 7982 Comp = 0 7983 k = INDEX( str(:j),' ',BACK=.TRUE.) 7984 7985 IF( k > 0 ) THEN 7986 IsIndex = ( VERIFY( str(k:j),' 0123456789') == 0 ) 7987 IF( IsIndex ) READ( str(k:j), * ) Comp 7988 END IF 7989 7990 ! This is the easy way of checking that the component belongs to a vector 7991 ! The size of the vector can be either dim or 3. 7992 GotIt = .FALSE. 7993 IF( IsIndex ) THEN 7994 Var1 => VariableGet(Variables,TRIM(str(1:k))) 7995 IF( ASSOCIATED( Var1 ) ) THEN 7996 GotIt = .TRUE. 7997 IsVector = ( Var1 % Dofs == Dim .OR. Var1 % Dofs == 3 ) 7998 Set = ( Comp == 1 .OR. .NOT. IsVector ) 7999 END IF 8000 END IF 8001 8002 ! This is a hard way of ensuring that the component belongs to a vector 8003 ! Check that there are exactly dim number of components 8004 ! If so save the quantity as a vector, otherwise componentwise 8005 IF( EnforceVectors .AND. .NOT. GotIt ) THEN 8006 IF( Comp == 1 ) THEN 8007 ! If we have the 1st component we need at least dim (2 or 3) components 8008 ! to have a vector. 8009 Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(dim),ThisOnly) 8010 8011 ! However, if the 4th component also exists then this cannot be a vector 8012 IF( ASSOCIATED(Var1)) THEN 8013 Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(4),ThisOnly) 8014 IsVector = .NOT. ASSOCIATED(Var1) 8015 END IF 8016 8017 ELSE IF( Comp <= 3 ) THEN ! component 2 or 3 8018 ! Associated to the previous case, cycle the other components of the vector 8019 ! and cycle them if they are part of the vector that will be detected above. 8020 8021 Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' 1',ThisOnly) 8022 IF( ASSOCIATED( Var1 ) ) THEN 8023 Var1 => VariableGet(Variables,TRIM(str(1:j-2))//' '//I2S(4),ThisOnly) 8024 Set = ASSOCIATED( Var1 ) 8025 END IF 8026 END IF 8027 END IF 8028 8029 ! Remove the trailing numbers as they are not needed in this case. 8030 IF( Set ) THEN 8031 IF(IsVector) WRITE(VarName,'(A)') TRIM(str(1:j-2)) 8032 8033 ! This is a special case as historically this is saved as vector 8034 IF(VarName == 'displacement' .AND. DisplacementV ) Set = .FALSE. 8035 END IF 8036 END IF 8037 END SELECT 8038 8039 8040 8041 !--------------------------------------------------------------------------- 8042 ! Set the default variable names that have not been set 8043 !------------------------------------------------------------------------ 8044 IF( Set ) THEN 8045 IF( UseGeneric ) THEN 8046 Nscalar = Nscalar + 1 8047 WRITE(VarStr,'(A,I0)') 'Variable ',Nscalar 8048 ELSE IF( IsVector ) THEN 8049 Nvector = Nvector + 1 8050 WRITE(VarStr,'(A,I0)') 'Vector Field ',Nvector 8051 ELSE 8052 Nscalar = Nscalar + 1 8053 WRITE(VarStr,'(A,I0)') 'Scalar Field ',Nscalar 8054 END IF 8055 CALL ListAddString( List,TRIM(VarStr),TRIM(VarName) ) 8056 END IF 8057 8058 Var => Var % Next 8059 END DO 8060 8061 8062 IF( ShowVariables ) THEN 8063 CALL Info('CreateListForSaving','Field Variables for Saving') 8064 IF( UseGeneric ) THEN 8065 DO i=1,Nscalar 8066 WRITE(VarStr,'(A,I0)') 'Variable ',i 8067 VarName = ListGetString( List, VarStr,GotIt ) 8068 IF( GotIt ) THEN 8069 WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName) 8070 CALL Info('CreateListForSaving',Message,Level=6) 8071 END IF 8072 END DO 8073 ELSE 8074 DO i=1,Nscalar 8075 WRITE(VarStr,'(A,I0)') 'Scalar Field ',i 8076 VarName = ListGetString( List, VarStr,GotIt ) 8077 IF( GotIt ) THEN 8078 WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName) 8079 CALL Info('CreateListForSaving',Message,Level=6) 8080 END IF 8081 END DO 8082 8083 DO i=1,Nvector 8084 WRITE(VarStr,'(A,I0)') 'Vector Field ',i 8085 VarName = ListGetString( List, VarStr,GotIt ) 8086 IF( GotIt ) THEN 8087 WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName) 8088 CALL Info('CreateListForSaving',Message,Level=6) 8089 END IF 8090 END DO 8091 8092 DO i=1,Nvector 8093 WRITE(VarStr,'(A,I0,A)') 'Vector Field ',i,' Complement' 8094 VarName = ListGetString( List, VarStr, GotIt ) 8095 IF( GotIt ) THEN 8096 WRITE( Message,'(A)') TRIM(VarStr)//': '//TRIM(VarName) 8097 CALL Info('CreateListForSaving',Message,Level=6) 8098 END IF 8099 END DO 8100 END IF 8101 END IF 8102 8103 END SUBROUTINE CreateListForSaving 8104 8105 8106!------------------------------------------------------------------------------ 8107!> A timer that uses a list structure to store the times making in 8108!> generally applicable without any upper limit on the number of timers. 8109!> This resets the timer. 8110!----------------------------------------------------------------------------- 8111 8112 SUBROUTINE ResetTimer(TimerName) 8113 CHARACTER(*) :: TimerName 8114 REAL(KIND=dp) :: ct, rt 8115 LOGICAL :: Found,FirstTime=.TRUE. 8116 8117 IF( FirstTime ) THEN 8118 FirstTime=.FALSE. 8119 TimerPassive = ListGetLogical( CurrentModel % Simulation,'Timer Passive',Found) 8120 TimerCumulative = ListGetLogical( CurrentModel % Simulation,'Timer Cumulative',Found) 8121 TimerRealTime = ListGetLogical( CurrentModel % Simulation,'Timer Real Time',Found) 8122 TimerCPUTime = ListGetLogical( CurrentModel % Simulation,'Timer CPU Time',Found) 8123 IF( .NOT. (TimerRealTime .OR. TimerCPUTime ) ) TimerRealTime = .TRUE. 8124 TimerPrefix = ListGetString( CurrentModel % Simulation,'Timer Prefix',Found ) 8125 IF( .NOT. Found ) THEN 8126 IF( ListGetLogical( CurrentModel % Simulation,'Timer Results',Found ) ) THEN 8127 TimerPrefix = 'res:' 8128 ELSE 8129 TimerPrefix = 'timer:' 8130 END IF 8131 END IF 8132 END IF 8133 8134 8135 IF( TimerPassive ) RETURN 8136 8137 IF( TimerCPUTime ) THEN 8138 ct = CPUTime() 8139 CALL ListAddConstReal( TimerList,TRIM(TimerName)//' cpu time',ct ) 8140 END IF 8141 8142 IF( TimerRealTime ) THEN 8143 rt = RealTime() 8144 CALL ListAddConstReal( TimerList,TRIM(TimerName)//' real time',rt ) 8145 END IF 8146 8147 IF( TimerCumulative ) THEN 8148 IF( TimerCPUTime ) THEN 8149 IF( .NOT. ListCheckPresent( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time') ) THEN 8150 CALL ListAddConstReal( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',0.0_dp ) 8151 END IF 8152 END IF 8153 IF( TimerRealTime ) THEN 8154 IF( .NOT. ListCheckPresent( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time') ) THEN 8155 CALL ListAddConstReal( CurrentModel % Simulation,TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',0.0_dp ) 8156 END IF 8157 END IF 8158 END IF 8159 8160 END SUBROUTINE ResetTimer 8161 8162 8163!----------------------------------------------------------------------------- 8164!> Delete an existing timer. 8165!---------------------------------------------------------------------------- 8166 SUBROUTINE DeleteTimer(TimerName) 8167 CHARACTER(*) :: TimerName 8168 8169 IF( TimerPassive ) RETURN 8170 8171 IF( TimerCPUTime ) THEN 8172 CALL ListRemove( TimerList, TRIM(TimerName)//' cpu time' ) 8173 END IF 8174 8175 IF( TimerRealTime ) THEN 8176 CALL ListRemove( TimerList, TRIM(TimerName)//' real time' ) 8177 END IF 8178 8179 END SUBROUTINE DeleteTimer 8180 8181!----------------------------------------------------------------------------- 8182!> Check current time of the timer. 8183!---------------------------------------------------------------------------- 8184 SUBROUTINE CheckTimer(TimerName, Level, Delete, Reset) 8185 CHARACTER(*) :: TimerName 8186 INTEGER, OPTIONAL :: Level 8187 LOGICAL, OPTIONAL :: Reset, Delete 8188 8189 REAL(KIND=dp) :: ct0,rt0,ct, rt, cumct, cumrt 8190 LOGICAL :: Found 8191 8192 IF( TimerPassive ) RETURN 8193 8194 IF( TimerCPUTime ) THEN 8195 ct0 = ListGetConstReal( TimerList,TRIM(TimerName)//' cpu time',Found) 8196 IF( Found ) THEN 8197 ct = CPUTime() - ct0 8198 WRITE(Message,'(a,f10.4,a)') 'Elapsed CPU time: ',ct,' (s)' 8199 CALL Info(TRIM(TimerName),Message,Level=Level) 8200 END IF 8201 END IF 8202 8203 IF( TimerRealTime ) THEN 8204 rt0 = ListGetConstReal( TimerList,TRIM(TimerName)//' real time',Found) 8205 IF( Found ) THEN 8206 rt = RealTime() - rt0 8207 WRITE(Message,'(a,f10.4,a)') 'Elapsed REAL time: ',rt,' (s)' 8208 CALL Info(TRIM(TimerName),Message,Level=Level) 8209 END IF 8210 END IF 8211 8212 8213 IF( TimerCPUTime ) THEN 8214 IF( TimerCumulative ) THEN 8215 cumct = ListGetConstReal(CurrentModel % Simulation,& 8216 TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',Found) 8217 IF( Found ) THEN 8218 ct = ct + cumct 8219 WRITE(Message,'(a,f10.4,a)') 'Elapsed CPU time cumulative: ',ct,' (s)' 8220 CALL Info(TRIM(TimerName),Message,Level=Level) 8221 ELSE 8222 CALL Warn('CheckTimer',& 8223 'Requesting previous CPU time from non-existing timer: '//TRIM(TimerName) ) 8224 END IF 8225 END IF 8226 CALL ListAddConstReal(CurrentModel % Simulation,& 8227 TRIM(TimerPrefix)//' '//TRIM(TimerName)//' cpu time',ct) 8228 8229 END IF 8230 IF( TimerRealTime ) THEN 8231 IF( TimerCumulative ) THEN 8232 cumrt = ListGetConstReal(CurrentModel % Simulation,& 8233 TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',Found) 8234 IF( Found ) THEN 8235 rt = rt + cumrt 8236 WRITE(Message,'(a,f10.4,a)') 'Elapsed real time cumulative: ',rt,' (s)' 8237 CALL Info(TRIM(TimerName),Message,Level=Level) 8238 ELSE 8239 CALL Warn('CheckTimer',& 8240 'Requesting previous real time from non-existing timer: '//TRIM(TimerName) ) 8241 END IF 8242 END IF 8243 CALL ListAddConstReal(CurrentModel % Simulation,& 8244 TRIM(TimerPrefix)//' '//TRIM(TimerName)//' real time',rt) 8245 END IF 8246 8247 8248 IF( PRESENT( Reset ) ) THEN 8249 IF( Reset ) THEN 8250 IF( TimerCPUTime ) THEN 8251 CALL ListAddConstReal( TimerList,TRIM(TimerName)//' cpu time',ct ) 8252 END IF 8253 IF( TimerRealTime ) THEN 8254 CALL ListAddConstReal( TimerList,TRIM(TimerName)//' real time',rt ) 8255 END IF 8256 END IF 8257 END IF 8258 8259 IF( PRESENT( Delete ) ) THEN 8260 IF( Delete ) CALL DeleteTimer( TimerName ) 8261 END IF 8262 8263 END SUBROUTINE CheckTimer 8264 8265 8266!> Returns the angular frequency 8267 FUNCTION ListGetAngularFrequency(ValueList,Found,UElement) RESULT(w) 8268 REAL(KIND=dp) :: w 8269 TYPE(ValueList_t), OPTIONAL, POINTER :: ValueList 8270 LOGICAL, OPTIONAL :: Found 8271 LOGICAL :: GotIt 8272 TYPE(Element_t), POINTER :: Element, UElement 8273 OPTIONAL :: UElement 8274 INTEGER :: elem_id,eq_id,mat_id 8275 8276 ! This is rather complicated since it should replace all the various strategies 8277 ! that have been used in different solvers. 8278 !------------------------------------------------------------------------------ 8279 8280 ! The only way frequency may depend on element is that it sits in equation block 8281 !-------------------------------------------------------------------------------- 8282 IF( PRESENT( ValueList ) ) THEN 8283 w = 2 * PI * ListGetCReal( ValueList,'Frequency',GotIt) 8284 IF(.NOT. GotIt) w = ListGetCReal( ValueList,'Angular Frequency',GotIt) 8285 ELSE 8286 GotIt = .FALSE. 8287 END IF 8288 8289 ! It seems that the equation section is used to allow compliance with ElmerGUI 8290 !------------------------------------------------------------------------------ 8291 IF( .NOT. GotIt ) THEN 8292 IF(PRESENT(UElement)) THEN 8293 Element => UElement 8294 eq_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Equation') 8295 w = 2 * PI * ListGetCReal( & 8296 CurrentModel % Equations(eq_id) % Values,'Frequency',GotIt) 8297 IF(.NOT. GotIt) w = ListGetCReal( & 8298 CurrentModel % Equations(eq_id) % Values,'Angular Frequency',GotIt) 8299 END IF 8300 END IF 8301 8302 ! Check also the material section... 8303 !------------------------------------------------------------------------------ 8304 IF( .NOT. GotIt ) THEN 8305 IF(PRESENT(UElement)) THEN 8306 Element => UElement 8307 mat_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Material') 8308 w = 2 * PI * ListGetCReal( & 8309 CurrentModel % Materials(mat_id) % Values,'Frequency',GotIt) 8310 IF(.NOT. GotIt) w = ListGetCReal( & 8311 CurrentModel % Materials(mat_id) % Values,'Angular Frequency',GotIt) 8312 END IF 8313 END IF 8314 8315 ! Normally the constant frequency is given in Simulation (or solver) block 8316 !------------------------------------------------------------------------- 8317 IF(.NOT. GotIt) w = 2 * PI * ListGetCReal( & 8318 CurrentModel % Simulation,'Frequency',GotIt) 8319 IF(.NOT. GotIt ) w = ListGetCReal( & 8320 CurrentModel % Simulation,'Angular Frequency',GotIt) 8321 8322 IF(.NOT. GotIt ) w = 2 * PI * ListGetCReal( & 8323 CurrentModel % Solver % Values,'Frequency',GotIt) 8324 IF(.NOT. GotIt ) w = ListGetCReal( & 8325 CurrentModel % Solver % Values,'Angular Frequency',GotIt) 8326 8327 ! It seems that the equation section is used to allow compliance with ElmerGUI 8328 !------------------------------------------------------------------------------ 8329 IF( .NOT. GotIt ) THEN 8330 elem_id = CurrentModel % Solver % ActiveElements(1) 8331 Element => CurrentModel % Elements(elem_id) 8332 eq_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Equation') 8333 w = 2 * PI * ListGetCReal( & 8334 CurrentModel % Equations(eq_id) % Values,'Frequency',GotIt) 8335 IF(.NOT. GotIt) w = ListGetCReal( & 8336 CurrentModel % Equations(eq_id) % Values,'Angular Frequency',GotIt) 8337 END IF 8338 8339 ! Check also the material section... 8340 !------------------------------------------------------------------------------ 8341 IF( .NOT. GotIt ) THEN 8342 elem_id = CurrentModel % Solver % ActiveElements(1) 8343 Element => CurrentModel % Elements(elem_id) 8344 mat_id = ListGetInteger( CurrentModel % Bodies(Element % bodyid) % Values,'Material') 8345 w = 2 * PI * ListGetCReal( & 8346 CurrentModel % Materials(mat_id) % Values,'Frequency',GotIt) 8347 IF(.NOT. GotIt) w = ListGetCReal( & 8348 CurrentModel % Materials(mat_id) % Values,'Angular Frequency',GotIt) 8349 END IF 8350 8351 IF( PRESENT( Found ) ) THEN 8352 Found = GotIt 8353 ELSE IF(.NOT. GotIt ) THEN 8354 CALL Warn('ListGetAngularFrequency','Angular frequency could not be determined!') 8355 END IF 8356 END FUNCTION ListGetAngularFrequency 8357 8358 8359 !------------------------------------------------------------------------------ 8360!> Returns handle to the Solver value list of the active solver 8361 FUNCTION ListGetSolverParams(Solver) RESULT(SolverParam) 8362!------------------------------------------------------------------------------ 8363 TYPE(ValueList_t), POINTER :: SolverParam 8364 TYPE(Solver_t), OPTIONAL :: Solver 8365 8366 IF ( PRESENT(Solver) ) THEN 8367 SolverParam => Solver % Values 8368 ELSE 8369 SolverParam => CurrentModel % Solver % Values 8370 END IF 8371!------------------------------------------------------------------------------ 8372 END FUNCTION ListGetSolverParams 8373!------------------------------------------------------------------------------ 8374 8375#ifdef HAVE_LUA 8376!------------------------------------------------------------------------------- 8377!> evaluates lua string to real array 8378!------------------------------------------------------------------------------- 8379SUBROUTINE ElmerEvalLuaT(L, ptr, T, F, varcount) 8380!------------------------------------------------------------------------------- 8381 TYPE(LuaState_t) :: L 8382 TYPE(ValueListEntry_t), POINTER :: ptr 8383 REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:) 8384 REAL(KIND=C_DOUBLE), INTENT(OUT) :: F(:,:) 8385 INTEGER :: VARCOUNT 8386!------------------------------------------------------------------------------- 8387 integer :: lstat 8388 8389 L % tx(1:varcount) = T(1:varcount) ! this should be superfluous 8390 call lua_exec_fun(L, ptr % cvalue, 0, size(F,1)*size(F,2)) 8391 8392 CALL lua_poptensor(L, F) 8393!------------------------------------------------------------------------------- 8394END SUBROUTINE 8395!------------------------------------------------------------------------------- 8396 8397!------------------------------------------------------------------------------- 8398!> evaluates lua string to real vector 8399!------------------------------------------------------------------------------- 8400SUBROUTINE ElmerEvalLuaV(L, ptr, T, F, varcount) 8401!------------------------------------------------------------------------------- 8402 TYPE(LuaState_t) :: L 8403 TYPE(ValueListEntry_t), POINTER :: ptr 8404 REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:) 8405 REAL(KIND=C_DOUBLE), INTENT(INOUT) :: F(:) 8406 INTEGER :: VARCOUNT 8407!------------------------------------------------------------------------------- 8408 integer :: lstat 8409 8410 L % tx(1:varcount) = T(1:varcount) ! this should be superfluous 8411 call lua_exec_fun(L, ptr % cvalue, 0, size(F,1)) 8412 8413 CALL lua_popvector(L, F) 8414!------------------------------------------------------------------------------- 8415END SUBROUTINE 8416!------------------------------------------------------------------------------- 8417 8418!------------------------------------------------------------------------------- 8419!> evaluates lua string to real scalar 8420!------------------------------------------------------------------------------- 8421SUBROUTINE ElmerEvalLuaS(L, ptr, T, F, varcount) 8422!------------------------------------------------------------------------------- 8423 TYPE(LuaState_t) :: L 8424 TYPE(ValueListEntry_t), POINTER :: ptr 8425 REAL(KIND=C_DOUBLE), INTENT(IN) :: T(:) 8426 REAL(KIND=C_DOUBLE), INTENT(OUT) :: F 8427 INTEGER :: VARCOUNT 8428!------------------------------------------------------------------------------- 8429 integer :: lstat 8430 8431 L % tx(1:varcount) = T(1:varcount) ! this should be superfluous 8432 call lua_exec_fun(L, ptr % cvalue, 0, 1) 8433 F = lua_popnumber(LuaState) 8434!------------------------------------------------------------------------------- 8435END SUBROUTINE 8436!------------------------------------------------------------------------------- 8437#endif 8438 8439#ifdef DEVEL_LISTCOUNTER 8440 8441 !------------------------------------------------------------------------------ 8442 !> Go through the lists and for each lists show call counts. 8443 !------------------------------------------------------------------------------ 8444 SUBROUTINE ReportListCounters( Model ) 8445 TYPE(Model_t) :: Model 8446 CHARACTER(LEN=MAX_NAME_LEN) :: dirname 8447 8448 INTEGER :: i, totcount, nelem 8449 LOGICAL :: Unused 8450 8451 CALL Info('ReportListCounters','Saving ListGet operations count per bulk elements') 8452 8453 ! OPEN(10,FILE="listcounter.dat") 8454 OPEN( 10,File='../listcounter.dat',& 8455 STATUS='UNKNOWN',POSITION='APPEND' ) 8456 8457 totcount = 0 8458 8459 8460 CALL GETCWD(dirname) 8461 WRITE( 10,'(A)') 'Working directory: '//TRIM(dirname) 8462 8463 ! These are only for reference 8464 nelem = Model % Mesh % NumberOfBulkElements 8465 8466 WRITE( 10,'(T4,A)') 'Number of elements: '//TRIM(I2S(nelem)) 8467 WRITE( 10,'(T4,A)') 'Number of nodes: '//TRIM(I2S(Model % Mesh % NumberOfNodes)) 8468 8469 Unused = .TRUE. 8470100 IF( Unused ) THEN 8471 WRITE( 10,'(T4,A)') 'Unused keywords:' 8472 ELSE 8473 WRITE( 10,'(T4,A)') 'Used keywords:' 8474 END IF 8475 8476 CALL ReportList('Simulation', Model % Simulation, Unused ) 8477 CALL ReportList('Constants', Model % Constants, Unused ) 8478 DO i=1,Model % NumberOfEquations 8479 CALL ReportList('Equation '//TRIM(I2S(i)), Model % Equations(i) % Values, Unused ) 8480 END DO 8481 DO i=1,Model % NumberOfComponents 8482 CALL ReportList('Component '//TRIM(I2S(i)), Model % Components(i) % Values, Unused ) 8483 END DO 8484 DO i=1,Model % NumberOfBodyForces 8485 CALL ReportList('Body Force '//TRIM(I2S(i)), Model % BodyForces(i) % Values, Unused ) 8486 END DO 8487 DO i=1,Model % NumberOfICs 8488 CALL ReportList('Initial Condition '//TRIM(I2S(i)), Model % ICs(i) % Values, Unused ) 8489 END DO 8490 DO i=1,Model % NumberOfBCs 8491 CALL ReportList('Boundary Condition '//TRIM(I2S(i)), Model % BCs(i) % Values, Unused ) 8492 END DO 8493 DO i=1,Model % NumberOfMaterials 8494 CALL ReportList('Material '//TRIM(I2S(i)), Model % Materials(i) % Values, Unused ) 8495 END DO 8496 DO i=1,Model % NumberOfBoundaries 8497 CALL ReportList('Boundary '//TRIM(I2S(i)), Model % Boundaries(i) % Values, Unused ) 8498 END DO 8499 DO i=1,Model % NumberOfSolvers 8500 CALL ReportList('Solver '//TRIM(I2S(i)), Model % Solvers(i) % Values, Unused ) 8501 END DO 8502 8503 IF( Unused ) THEN 8504 Unused = .FALSE. 8505 GOTO 100 8506 END IF 8507 8508 CLOSE(10) 8509 8510 8511 CALL Info('ReportListCounters','List operations total count:'//TRIM(I2S(totcount))) 8512 8513 CONTAINS 8514 8515 8516 !------------------------------------------------------------------------------ 8517 ! Plot the number of times that the list entries have been called. 8518 !------------------------------------------------------------------------------ 8519 SUBROUTINE ReportList( SectionName, List, Unused ) 8520 TYPE(ValueList_t), POINTER :: List 8521 CHARACTER(LEN=*) :: SectionName 8522 LOGICAL :: Unused 8523 !------------------------------------------------------------------------------ 8524 TYPE(ValueListEntry_t), POINTER :: ptr 8525 INTEGER :: n, m 8526 8527 IF(.NOT.ASSOCIATED(List)) RETURN 8528 8529 Ptr => List % Head 8530 DO WHILE( ASSOCIATED(ptr) ) 8531 n = ptr % NameLen 8532 m = ptr % Counter 8533 8534 IF( Unused .AND. m == 0 ) THEN 8535 WRITE( 10,'(T8,A,T30,A)') TRIM(SectionName),ptr % Name(1:n) 8536 ELSE IF(.NOT. Unused .AND. m > 0 ) THEN 8537 WRITE( 10,'(T8,A,T30,I0,T40,A)') TRIM(SectionName),m,ptr % Name(1:n) 8538 totcount = totcount + m 8539 END IF 8540 ptr => ptr % Next 8541 END DO 8542 8543 END SUBROUTINE ReportList 8544 !------------------------------------------------------------------------------ 8545 8546 END SUBROUTINE ReportListCounters 8547 !------------------------------------------------------------------------------ 8548 8549#else 8550 8551 SUBROUTINE ReportListCounters( Model ) 8552 TYPE(Model_t) :: Model 8553 8554 CALL Info('ReportListCounter','List counters are not activated!') 8555 END SUBROUTINE ReportListCounters 8556 8557#endif 8558 8559 8560 8561 8562END MODULE Lists 8563 8564!> \} ElmerLib 8565