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, Peter Råback 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 Apr 2001 34! * 35! *****************************************************************************/ 36 37!> \ingroup ElmerLib 38!> \{ 39 40!------------------------------------------------------------------------------ 41!> Mesh manipulation utilities for *Solver - routines 42!------------------------------------------------------------------------------ 43 44MODULE MeshUtils 45 46 USE LoadMod 47 USE ElementUtils 48 USE ElementDescription 49 USE Interpolation 50 USE ParallelUtils 51 USE Types 52 IMPLICIT NONE 53 54CONTAINS 55 56 57!------------------------------------------------------------------------------ 58!> Allocated one single element. 59!------------------------------------------------------------------------------ 60 FUNCTION AllocateElement() RESULT( Element ) 61!------------------------------------------------------------------------------ 62 TYPE(Element_t), POINTER :: Element 63!------------------------------------------------------------------------------ 64 INTEGER :: istat 65!------------------------------------------------------------------------------ 66 67 ALLOCATE( Element, STAT=istat ) 68 IF ( istat /= 0 ) & 69 CALL Fatal( 'AllocateElement', 'Unable to allocate a few bytes of memory?' ) 70 Element % BDOFs = 0 71 Element % NDOFs = 0 72 Element % BodyId = -1 73 Element % Splitted = 0 74 Element % hK = 0 75 Element % ElementIndex = 0 76 Element % StabilizationMk = 0 77 NULLIFY( Element % TYPE ) 78 NULLIFY( Element % PDefs ) 79 NULLIFY( Element % BubbleIndexes ) 80 NULLIFY( Element % DGIndexes ) 81 NULLIFY( Element % NodeIndexes ) 82 NULLIFY( Element % EdgeIndexes ) 83 NULLIFY( Element % FaceIndexes ) 84 NULLIFY( Element % BoundaryInfo ) 85!------------------------------------------------------------------------------ 86 END FUNCTION AllocateElement 87!------------------------------------------------------------------------------ 88 89!------------------------------------------------------------------------------ 90 SUBROUTINE AllocatePDefinitions(Element) 91!------------------------------------------------------------------------------ 92 IMPLICIT NONE 93 INTEGER :: istat,n 94 95 TYPE(Element_t) :: Element 96 97 ! Sanity check to avoid memory leaks 98 IF (.NOT. ASSOCIATED(Element % PDefs)) THEN 99 ALLOCATE(Element % PDefs, STAT=istat) 100 IF ( istat /= 0) CALL Fatal('AllocatePDefinitions','Unable to allocate memory') 101 ELSE 102 CALL Info('AllocatePDefinitions','P element definitions already allocated',Level=10) 103 END IF 104 105 ! Initialize fields 106 Element % PDefs % P = 0 107 Element % PDefs % TetraType = 0 108 Element % PDefs % isEdge = .FALSE. 109 Element % PDefs % pyramidQuadEdge = .FALSE. 110 Element % PDefs % localNumber = 0 111 Element % PDefs % GaussPoints = 0 112!------------------------------------------------------------------------------ 113 END SUBROUTINE AllocatePDefinitions 114!------------------------------------------------------------------------------ 115 116!------------------------------------------------------------------------------ 117 SUBROUTINE AllocateBoundaryInfo(Element) 118!------------------------------------------------------------------------------ 119 IMPLICIT NONE 120 INTEGER :: istat,n 121 122 TYPE(Element_t) :: Element 123 124 ALLOCATE(Element % BoundaryInfo, STAT=istat) 125 IF ( istat /= 0) CALL Fatal('AllocateBoundaryInfo','Unable to allocate memory') 126 127 Element % BoundaryInfo % Left => NULL() 128 Element % BoundaryInfo % Right => NULL() 129 Element % BoundaryInfo % GebhardtFactors => NULL() 130 Element % BoundaryInfo % Constraint = 0 131 132!------------------------------------------------------------------------------ 133 END SUBROUTINE AllocateBoundaryInfo 134!------------------------------------------------------------------------------ 135 136!> Allocate mesh structure and return handle to it. 137!------------------------------------------------------------------------------ 138 FUNCTION AllocateMesh(NumberOfBulkElements, NumberOfBoundaryElements, & 139 NumberOfNodes, InitParallel ) RESULT(Mesh) 140!------------------------------------------------------------------------------ 141 INTEGER, OPTIONAL :: NumberOfBulkElements, NumberOfBoundaryElements, NumberOfNodes 142 LOGICAL, OPTIONAL :: InitParallel 143 TYPE(Mesh_t), POINTER :: Mesh 144!------------------------------------------------------------------------------ 145 INTEGER :: istat, i, n 146 CHARACTER(*), PARAMETER :: Caller = 'AllocateMesh' 147 148 ALLOCATE( Mesh, STAT=istat ) 149 IF ( istat /= 0 ) CALL Fatal( Caller, 'Unable to allocate a few bytes of memory?' ) 150 151! Nothing computed on this mesh yet! 152! ---------------------------------- 153 Mesh % SavesDone = 0 154 Mesh % OutputActive = .FALSE. 155 156 Mesh % AdaptiveDepth = 0 157 Mesh % Changed = .FALSE. ! TODO: Change this sometime 158 Mesh % Stabilize = .FALSE. 159 Mesh % MeshTag = 1 160 161 Mesh % Variables => NULL() 162 Mesh % Parent => NULL() 163 Mesh % Child => NULL() 164 Mesh % Next => NULL() 165 Mesh % RootQuadrant => NULL() 166 Mesh % Edges => NULL() 167 Mesh % Faces => NULL() 168 Mesh % Projector => NULL() 169 Mesh % NumberOfEdges = 0 170 Mesh % NumberOfFaces = 0 171 172 Mesh % NumberOfBulkElements = 0 173 Mesh % NumberOfBoundaryElements = 0 174 Mesh % Elements => NULL() 175 176 Mesh % DiscontMesh = .FALSE. 177 Mesh % SingleMesh = .FALSE. 178 Mesh % InvPerm => NULL() 179 180 Mesh % MinFaceDOFs = 1000 181 Mesh % MinEdgeDOFs = 1000 182 Mesh % MaxFaceDOFs = 0 183 Mesh % MaxEdgeDOFs = 0 184 Mesh % MaxBDOFs = 0 185 Mesh % MaxElementDOFs = 0 186 Mesh % MaxElementNodes = 0 187 188 Mesh % ViewFactors => NULL() 189 190 ALLOCATE( Mesh % Nodes, STAT=istat ) 191 IF ( istat /= 0 ) CALL Fatal( Caller, 'Unable to allocate a few bytes of memory?' ) 192 193 NULLIFY( Mesh % Nodes % x ) 194 NULLIFY( Mesh % Nodes % y ) 195 NULLIFY( Mesh % Nodes % z ) 196 Mesh % Nodes % NumberOfNodes = 0 197 Mesh % NumberOfNodes = 0 198 199 Mesh % NodesOrig => Mesh % Nodes 200 NULLIFY( Mesh % NodesMapped ) 201 202 Mesh % EntityWeightsComputed = .FALSE. 203 Mesh % BCWeight => NULL() 204 Mesh % BodyForceWeight => NULL() 205 Mesh % BodyWeight => NULL() 206 Mesh % MaterialWeight => NULL() 207 208 Mesh % ParallelInfo % NumberOfIfDOFs = 0 209 NULLIFY( Mesh % ParallelInfo % GlobalDOFs ) 210 NULLIFY( Mesh % ParallelInfo % INTERFACE ) 211 NULLIFY( Mesh % ParallelInfo % NeighbourList ) 212 213 i = 0 214 IF( PRESENT( NumberOfBulkElements ) ) THEN 215 Mesh % NumberOfBulkElements = NumberOfBulkElements 216 i = i + 1 217 END IF 218 219 IF( PRESENT( NumberOfBoundaryElements ) ) THEN 220 Mesh % NumberOfBoundaryElements = NumberOfBoundaryElements 221 i = i + 1 222 END IF 223 224 IF( PRESENT( NumberOfNodes ) ) THEN 225 Mesh % NumberOfNodes = NumberOfNodes 226 i = i + 1 227 END IF 228 229 IF( i > 0 ) THEN 230 IF( i < 3 ) CALL Fatal(Caller,'Either give all or no optional parameters!') 231 CALL InitializeMesh( Mesh, InitParallel ) 232 END IF 233 234!------------------------------------------------------------------------------ 235 END FUNCTION AllocateMesh 236!------------------------------------------------------------------------------ 237 238 239 ! Initialize mesh structures after the size information has been 240 ! retrieved. 241 !---------------------------------------------------------------- 242 SUBROUTINE InitializeMesh(Mesh, InitParallel) 243 TYPE(Mesh_t), POINTER :: Mesh 244 LOGICAL, OPTIONAL :: InitParallel 245 246 INTEGER :: i,j,k,NoElems,istat 247 TYPE(Element_t), POINTER :: Element 248 CHARACTER(*), PARAMETER :: Caller = 'InitializeMesh' 249 LOGICAL :: DoParallel 250 251 IF( Mesh % NumberOfNodes == 0 ) THEN 252 CALL Warn(Caller,'Mesh has zero nodes!') 253 RETURN 254 ELSE 255 CALL Info(Caller,'Number of nodes in mesh: '& 256 //TRIM(I2S(Mesh % NumberOfNodes)),Level=8) 257 END IF 258 259 CALL Info(Caller,'Number of bulk elements in mesh: '& 260 //TRIM(I2S(Mesh % NumberOfBulkElements)),Level=8) 261 262 CALL Info(Caller,'Number of boundary elements in mesh: '& 263 //TRIM(I2S(Mesh % NumberOfBoundaryElements)),Level=8) 264 265 Mesh % Nodes % NumberOfNodes = Mesh % NumberOfNodes 266 267 NoElems = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 268 269 IF( NoElems == 0 ) THEN 270 CALL Fatal('InitializeMesh','Mesh has zero elements!') 271 END IF 272 273 Mesh % MaxElementDOFs = 0 274 Mesh % MinEdgeDOFs = 1000 275 Mesh % MinFaceDOFs = 1000 276 Mesh % MaxEdgeDOFs = 0 277 Mesh % MaxFaceDOFs = 0 278 Mesh % MaxBDOFs = 0 279 280 Mesh % DisContMesh = .FALSE. 281 Mesh % DisContPerm => NULL() 282 Mesh % DisContNodes = 0 283 284 CALL Info(Caller,'Initial number of max element nodes: '& 285 //TRIM(I2S(Mesh % MaxElementNodes)),Level=10) 286 287 ! Allocate the elements 288 !------------------------------------------------------------------------- 289 CALL AllocateVector( Mesh % Elements, NoElems, Caller ) 290 291 DO j=1,NoElems 292 Element => Mesh % Elements(j) 293 294 Element % DGDOFs = 0 295 Element % BodyId = 0 296 Element % TYPE => NULL() 297 Element % BoundaryInfo => NULL() 298 Element % PDefs => NULL() 299 Element % DGIndexes => NULL() 300 Element % EdgeIndexes => NULL() 301 Element % FaceIndexes => NULL() 302 Element % BubbleIndexes => NULL() 303 END DO 304 305 ! Allocate the nodes 306 !------------------------------------------------------------------------- 307 CALL AllocateVector( Mesh % Nodes % x, Mesh % NumberOfNodes, Caller ) 308 CALL AllocateVector( Mesh % Nodes % y, Mesh % NumberOfNodes, Caller ) 309 CALL AllocateVector( Mesh % Nodes % z, Mesh % NumberOfNodes, Caller ) 310 311 IF( .NOT. PRESENT( InitParallel ) ) RETURN 312 IF( .NOT. InitParallel ) RETURN 313 314 CALL Info( Caller,'Allocating parallel info',Level=12) 315 316 ALLOCATE(Mesh % ParallelInfo % GlobalDOFs(Mesh % NumberOfNodes), STAT=istat ) 317 IF ( istat /= 0 ) & 318 CALL Fatal( Caller, 'Unable to allocate Mesh % ParallelInfo % NeighbourList' ) 319 ALLOCATE(Mesh % ParallelInfo % INTERFACE(Mesh % NumberOfNodes), STAT=istat ) 320 IF ( istat /= 0 ) & 321 CALL Fatal( Caller, 'Unable to allocate Mesh % ParallelInfo % NeighbourList' ) 322 ALLOCATE(Mesh % ParallelInfo % NeighbourList(Mesh % NumberOfNodes), STAT=istat ) 323 IF ( istat /= 0 ) & 324 CALL Fatal( Caller, 'Unable to allocate Mesh % ParallelInfo % NeighbourList' ) 325 DO i=1,Mesh % NumberOfNodes 326 NULLIFY(Mesh % ParallelInfo % NeighbourList(i) % Neighbours) 327 END DO 328 329 END SUBROUTINE InitializeMesh 330 331 332 333!------------------------------------------------------------------------------ 334 SUBROUTINE GetMaxDefs(Model, Mesh, Element, ElementDef, SolverId, BodyId, Def_Dofs) 335!------------------------------------------------------------------------------ 336 CHARACTER(*) :: ElementDef 337 TYPE(Model_t) :: Model 338 TYPE(MEsh_t) :: Mesh 339 TYPE(Element_t) :: Element 340 INTEGER :: SolverId, BodyId, Def_Dofs(:,:) 341 342 TYPE(ValueList_t), POINTER :: Params 343 INTEGER :: i, j,k,l, n, slen, Family 344 INTEGER, POINTER :: Body_Dofs(:,:) 345 LOGICAL :: stat, Found 346 REAL(KIND=dp) :: x,y,z 347 TYPE(Solver_t), POINTER :: Solver 348 CHARACTER(MAX_NAME_LEN) :: str, RESULT 349 350 TYPE(ValueList_t), POINTER :: BodyParams 351 CHARACTER(MAX_NAME_LEN) :: ElementDefBody 352 353 BodyParams => Model % Bodies(BodyId) % Values 354 355 ElementDefBody=ListGetString(BodyParams,'Solver '//TRIM(i2s(SolverId))//': Element',Found ) 356 IF (Found) THEN 357 CALL Info('GetMaxDefs','Element found for body '//TRIM(i2s(BodyId))//' with solver '//TRIM(i2s(SolverId)), Level=5) 358 CALL Info('GetMaxDefs','Default element type is: '//ElementDef, Level=5) 359 CALL Info('GetMaxDefs','New element type for this body is now: '//ElementDefBody, Level=5) 360 ElementDef=ElementDefBody 361 END IF 362 363 Solver => Model % Solvers(SolverId) 364 Params => Solver % Values 365 366 IF ( .NOT. ALLOCATED(Solver % Def_Dofs) ) THEN 367 ALLOCATE(Solver % Def_Dofs(10,Model % NumberOfBodies,6)) 368 Solver % Def_Dofs=-1 369 Solver % Def_Dofs(:,:,1)=1 370 END IF 371 Body_Dofs => Solver % Def_Dofs(1:8,BodyId,:) 372 373 j = INDEX(ElementDef, '-') ! FIX this to include elementtypewise defs... 374 IF ( j>0 ) RETURN 375 376 j = INDEX( ElementDef, 'n:' ) 377 IF ( j>0 ) THEN 378 READ( ElementDef(j+2:), * ) l 379 Body_Dofs(:,1) = l 380 Def_Dofs(:,1) = MAX(Def_Dofs(:,1), l) 381 END IF 382 383 j = INDEX( ElementDef, 'e:' ) 384 IF ( j>0 ) THEN 385 READ( ElementDef(j+2:), * ) l 386 Body_Dofs(:,2) = l 387 Def_Dofs(1:8,2) = MAX(Def_Dofs(1:8,2), l ) 388 END IF 389 390 j = INDEX( ElementDef, 'f:' ) 391 IF ( j>0 ) THEN 392 READ( ElementDef(j+2:), * ) l 393 Body_Dofs(:,3) = l 394 Def_Dofs(1:8,3) = MAX(Def_Dofs(1:8,3), l ) 395 END IF 396 397 j = INDEX( ElementDef, 'd:' ) 398 IF ( j>0 ) THEN 399 READ( ElementDef(j+2:), * ) l 400 Body_Dofs(:,4) = l 401 Def_Dofs(1:8,4) = MAX(Def_Dofs(1:8,4), l ) 402 ELSE 403 IF ( ListGetLogical( Solver % Values, & 404 'Discontinuous Galerkin', stat ) ) THEN 405 Body_Dofs(:,4) = 0 406 Def_Dofs(1:8,4) = MAX(Def_Dofs(1:8,4),0 ) 407 END IF 408 END IF 409 410 j = INDEX( ElementDef, 'b:' ) 411 IF ( j>0 ) THEN 412 READ( ElementDef(j+2:), * ) l 413 Body_Dofs(1:8,5) = l 414 Def_Dofs(1:8,5) = MAX(Def_Dofs(1:8,5), l ) 415 END IF 416 417 j = INDEX( ElementDef, 'p:' ) 418 IF ( j>0 ) THEN 419 IF ( ElementDef(j+2:j+2) == '%' ) THEN 420 n = Element % TYPE % NumberOfNodes 421 x = SUM(Mesh % Nodes % x(Element % NodeIndexes))/n 422 y = SUM(Mesh % Nodes % y(Element % NodeIndexes))/n 423 z = SUM(Mesh % Nodes % z(Element % NodeIndexes))/n 424! WRITE( str, * ) 'cx= ',TRIM(i2s(Element % ElementIndex)),x,y,z 425 WRITE( str, * ) 'cx= ',TRIM(i2s(Element % BodyId)),x,y,z 426 str = TRIM(str) // '; ' // TRIM(ElementDef(j+3:))//'(cx)' 427 slen = LEN_TRIM(str) 428 CALL matc(str,RESULT,slen) 429 READ(RESULT(1:slen),*) x 430 Body_Dofs(:,6) = 0 431 Def_Dofs(1:8,6) = MAX(Def_Dofs(1:8,6),NINT(x)) 432 Family = Element % TYPE % ElementCode / 100 433 Solver % Def_Dofs(Family, BodyId, 6) = & 434 MAX(Solver % Def_Dofs(Family, BodyId, 6), NINT(x)) 435 ELSE 436 READ( ElementDef(j+2:), * ) l 437 Body_Dofs(:,6) = l 438 Def_Dofs(1:8,6) = MAX(Def_Dofs(1:8,6), l ) 439 END IF 440 END IF 441 442!------------------------------------------------------------------------------ 443 END SUBROUTINE GetMaxDefs 444!------------------------------------------------------------------------------ 445 446 447 SUBROUTINE MarkHaloNodes( Mesh, HaloNode, FoundHaloNodes ) 448 449 TYPE(Mesh_t), POINTER :: Mesh 450 LOGICAL, POINTER :: HaloNode(:) 451 LOGICAL :: FoundHaloNodes 452 453 INTEGER :: n,t 454 TYPE(Element_t), POINTER :: Element 455 INTEGER, POINTER :: Indexes(:) 456 LOGICAL :: AllocDone 457 458 ! Check whether we need to skip some elements and nodes on the halo boundary 459 ! We don't want to create additional nodes on the nodes that are on the halo only 460 ! since they just would create further need for new halo... 461 FoundHaloNodes = .FALSE. 462 IF( ParEnv % PEs > 1 ) THEN 463 DO t = 1, Mesh % NumberOfBulkElements 464 Element => Mesh % Elements(t) 465 IF( ParEnv % MyPe /= Element % PartIndex ) THEN 466 FoundHaloNodes = .TRUE. 467 EXIT 468 END IF 469 END DO 470 END IF 471 472 473 ! If we have halo check the truly active nodes 474 IF( FoundHaloNodes ) THEN 475 CALL Info('MarkHaloNodes',& 476 'Checking for nodes that are not really needed in bulk assembly',Level=12) 477 478 IF( .NOT. ASSOCIATED( HaloNode ) ) THEN 479 ALLOCATE( HaloNode( Mesh % NumberOfNodes ) ) 480 AllocDone = .TRUE. 481 ELSE 482 AllocDone = .FALSE. 483 END IF 484 485 ! Node is a halo node if it is not needed by any proper element 486 HaloNode = .TRUE. 487 DO t = 1, Mesh % NumberOfBulkElements 488 Element => Mesh % Elements(t) 489 IF( ParEnv % MyPe == Element % PartIndex ) THEN 490 Indexes => Element % NodeIndexes 491 HaloNode( Indexes ) = .FALSE. 492 END IF 493 END DO 494 495 n = COUNT( HaloNode ) 496 FoundHaloNodes = ( n > 0 ) 497 CALL Info('MarkHaloNodes','Number of passive nodes in the halo: '& 498 //TRIM(I2S(n)),Level=10) 499 500 ! If there are no halo nodes and the allocation was done within this subroutine 501 ! then deallocate also. 502 IF( .NOT. FoundHaloNodes .AND. AllocDone ) THEN 503 DEALLOCATE( HaloNode ) 504 END IF 505 END IF 506 507 END SUBROUTINE MarkHaloNodes 508 509 510 511 ! Mark nodes that are associated with at least some boundary element. 512 !------------------------------------------------------------------------------ 513 SUBROUTINE MarkBCNodes(Mesh,BCNode,NoBCNodes) 514 TYPE(Mesh_t), POINTER :: Mesh 515 LOGICAL, ALLOCATABLE :: BCNode(:) 516 INTEGER :: NoBCNodes 517 518 INTEGER :: elem 519 TYPE(Element_t), POINTER :: Element 520 521 CALL Info('MarkInterfaceNodes','Marking interface nodes',Level=8) 522 523 IF(.NOT. ALLOCATED( BCNode ) ) THEN 524 ALLOCATE( BCNode( Mesh % NumberOfNodes ) ) 525 END IF 526 BCNode = .FALSE. 527 528 DO elem=Mesh % NumberOfBulkElements + 1, & 529 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 530 531 Element => Mesh % Elements( elem ) 532 !IF( .NOT. ASSOCIATED( Element % BoundaryInfo ) ) CYCLE 533 534 BCNode(Element % NodeIndexes) = .TRUE. 535 END DO 536 537 NoBCNodes = COUNT( BCNode ) 538 539 CALL Info('MarkBCNodes','Number of BC nodes: '//TRIM(I2S(NoBCNodes)),Level=8) 540 541 END SUBROUTINE MarkBCNodes 542 543 544 545 546!> Create a discontinuous mesh over requested boundaries. 547!> The nodes are duplicated in order to facilitate the discontinuity. 548!> The duplicate nodes are not created by default if the connectivity 549!> of the nodes is needed by other bulk elements than those directly 550!> associated with the discontinuous boundaries. 551!------------------------------------------------------------------------------ 552 SUBROUTINE CreateDiscontMesh( Model, Mesh, DoAlways ) 553 554 TYPE(Model_t) :: Model 555 TYPE(Mesh_t), POINTER :: Mesh 556 LOGICAL, OPTIONAL :: DoAlways 557 558 INTEGER, POINTER :: DisContPerm(:) 559 LOGICAL, ALLOCATABLE :: DisContNode(:), DisContElem(:), ParentUsed(:), & 560 MovingNode(:), StayingNode(:) 561 LOGICAL :: Found, DisCont, GreedyBulk, GreedyBC, Debug, DoubleBC, UseTargetBodies, & 562 UseConsistantBody, LeftHit, RightHit, Moving, Moving2, Set, Parallel 563 INTEGER :: i,j,k,l,n,m,t,bc 564 INTEGER :: NoNodes, NoDisContElems, NoDisContNodes, & 565 NoBulkElems, NoBoundElems, NoParentElems, NoMissingElems, & 566 DisContTarget, NoMoving, NoStaying, NoStayingElems, NoMovingElems, & 567 NoUndecided, PrevUndecided, NoEdges, Iter, ElemFamily, DecideLimit, & 568 ActiveBCs, CandA, CandB, RightBody, LeftBody, ConflictElems 569 INTEGER, TARGET :: TargetBody(1) 570 INTEGER, POINTER :: Indexes(:),ParentIndexes(:),TargetBodies(:) 571 TYPE(Element_t), POINTER :: Element, LeftElem, RightElem, ParentElem, OtherElem 572 CHARACTER(MAX_NAME_LEN) :: DiscontFlag 573 LOGICAL :: CheckForHalo 574 LOGICAL, POINTER :: HaloNode(:) 575 TYPE(ValueList_t), POINTER :: BCList 576 577 LOGICAL :: DoneThisAlready = .FALSE. 578 579 IF(.NOT.PRESENT(DoAlways)) THEN 580 IF (DoneThisAlready) RETURN 581 ELSE 582 IF(.NOT.DoAlways) THEN 583 IF (DoneThisAlready) RETURN 584 END IF 585 END IF 586 DoneThisAlready = .TRUE. 587 588 Discont = .FALSE. 589 DoubleBC = .FALSE. 590 ActiveBCs = 0 591 DO bc = 1,Model % NumberOfBCs 592 DisCont = ListGetLogical( Model % BCs(bc) % Values,'Discontinuous Boundary',Found ) 593 ! If the target boundary / periodic bc / mortar bc is zero 594 ! it refers to itself. Otherwise the boundary will be doubled. 595 IF( DisCont ) THEN 596 i = ListGetInteger( Model % BCs(bc) % Values,'Discontinuous BC',Found ) 597 j = ListGetInteger( Model % BCs(bc) % Values,'Periodic BC',Found ) 598 k = ListGetInteger( Model % BCs(bc) % Values,'Mortar BC',Found ) 599 l = ListGetInteger( Model % BCs(bc) % Values,'Contact BC',Found ) 600 DoubleBC = ( i + j + k + l > 0 ) 601 ActiveBCs = ActiveBCs + 1 602 BCList => Model % BCs(bc) % Values 603 END IF 604 END DO 605 IF(ActiveBCs == 0 ) RETURN 606 607 CALL Info('CreateDiscontMesh','Creating discontinuous boundaries') 608 609 IF( ActiveBCs > 1 ) THEN 610 CALL Warn('CreateDiscontMesh','Be careful when using more than one > Discontinuous Boundary < !') 611 END IF 612 613 Parallel = ( ParEnv % PEs > 1 ) 614 615 NoNodes = Mesh % NumberOfNodes 616 NoBulkElems = Mesh % NumberOfBulkElements 617 NoBoundElems = Mesh % NumberOfBoundaryElements 618 619 ALLOCATE( DisContNode(NoNodes)) 620 ALLOCATE( DisContElem(NoBoundElems)) 621 ALLOCATE( ParentUsed(NoBulkElems)) 622 DisContNode = .FALSE. 623 DisContElem = .FALSE. 624 ParentUsed = .FALSE. 625 NoDisContElems = 0 626 NoMissingElems = 0 627 628 629 ! Check whether we need to skip some elements and nodes on the halo boundary 630 ! We might not want to create additional nodes on the nodes that are on the halo only 631 ! since they just would create further need for new halo... 632 CheckForHalo = ListGetLogical( Model % Simulation,'No Discontinuous Halo',Found ) 633 IF(.NOT. Found ) CheckForHalo = .TRUE. 634 IF( CheckForHalo ) THEN 635 HaloNode => NULL() 636 CALL MarkHaloNodes( Mesh, HaloNode, CheckForHalo ) 637 END IF 638 639 ! Go over all boundary elements and mark nodes that should be 640 ! discontinuous and nodes that should be continuous 641 DO t = 1, NoBoundElems 642 643 Element => Mesh % Elements(NoBulkElems + t) 644 Indexes => Element % NodeIndexes 645 n = Element % Type % NumberOfNodes 646 647 DisCont = .FALSE. 648 DO bc = 1,Model % NumberOfBCs 649 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 650 DisCont = ListGetLogical( Model % BCs(bc) % Values,'Discontinuous Boundary',Found ) 651 IF( DisCont ) EXIT 652 END IF 653 END DO 654 IF(.NOT. DisCont ) CYCLE 655 656 DO i=1,n 657 j = Indexes(i) 658 IF( CheckForHalo ) THEN 659 IF( HaloNode(j) ) CYCLE 660 END IF 661 DisContNode(j) = .TRUE. 662 END DO 663 DisContElem( t ) = .TRUE. 664 665 LeftElem => Element % BoundaryInfo % Left 666 IF( ASSOCIATED( LeftElem ) ) THEN 667 ParentUsed( LeftElem % ElementIndex ) = .TRUE. 668 ELSE 669 NoMissingElems = NoMissingElems + 1 670 END IF 671 672 RightElem => Element % BoundaryInfo % Right 673 IF( ASSOCIATED( RightElem ) ) THEN 674 ParentUsed( RightElem % ElementIndex ) = .TRUE. 675 ELSE 676 NoMissingElems = NoMissingElems + 1 677 END IF 678 END DO 679 680 IF( NoMissingElems > 0 ) THEN 681 CALL Warn('CreateDiscontMesh','Missing '//TRIM(I2S(NoMissingElems))// & 682 ' parent elements in partition '//TRIM(I2S(ParEnv % MyPe))) 683 END IF 684 685 ! Calculate the number of discontinuous nodes and the number of bulk elements 686 ! associated to them. 687 NoDisContElems = COUNT( DiscontElem ) 688 NoDisContNodes = COUNT( DisContNode ) 689 CALL Info('CreateDiscontMesh','Number of discontinuous boundary elements: '& 690 //TRIM(I2S(NoDisContElems)),Level=7) 691 CALL Info('CreateDiscontMesh','Number of candicate nodes: '& 692 //TRIM(I2S(NoDisContNodes)),Level=7) 693 694 ! By default all nodes that are associated to elements immediately at the discontinuous 695 ! boundary are treated as discontinuous. However, the user may be not be greedy and release 696 ! some nodes from the list that are associated also with other non-discontinuous elements. 697 ConflictElems = 0 698 IF( NoDiscontNodes > 0 ) THEN 699 n = NoDiscontNodes 700 701 GreedyBulk = ListGetLogical( Model % Simulation,'Discontinuous Bulk Greedy',Found ) 702 IF(.NOT. Found ) GreedyBulk = .TRUE. 703 704 GreedyBC = ListGetLogical( Model % Simulation,'Discontinuous Boundary Greedy',Found ) 705 IF(.NOT. Found ) GreedyBC = .TRUE. 706 707 IF( .NOT. ( GreedyBC .AND. GreedyBulk ) ) THEN 708 CALL Info('CreateDiscontMesh','Applying non-greedy strategies for Discontinuous mesh',Level=12) 709 710 DO t = 1,NoBulkElems+NoBoundElems 711 Element => Mesh % Elements(t) 712 713 IF( t <= NoBulkElems ) THEN 714 IF( GreedyBulk ) CYCLE 715 IF( ParentUsed(t) ) CYCLE 716 ELSE 717 IF( GreedyBC ) CYCLE 718 IF( DiscontElem(t-NoBulkElems) ) CYCLE 719 !IF( Element % BoundaryInfo % Constraint == 0 ) CYCLE 720 ! Check that this is not an internal BC 721 IF( .NOT. ASSOCIATED( Element % BoundaryInfo % Left ) ) CYCLE 722 IF( .NOT. ASSOCIATED( Element % BoundaryInfo % Right) ) CYCLE 723 END IF 724 Indexes => Element % NodeIndexes 725 726 IF( ANY( DisContNode( Indexes ) ) ) THEN 727 !PRINT *,'t',Element % BoundaryInfo % Constraint, t,DisContElem(t), & 728 ! Indexes, DisContNode( Indexes ) 729 DisContNode( Indexes ) = .FALSE. 730 ConflictElems = ConflictElems + 1 731 END IF 732 END DO 733 NoDisContNodes = COUNT( DisContNode ) 734 END IF 735 736 IF( ConflictElems > 0 ) THEN 737 CALL Info('CreateDiscontMesh','Conflicting discontinuity in elements: '& 738 //TRIM(I2S(ConflictElems))) 739 END IF 740 741 IF( NoDiscontNodes < n ) THEN 742 CALL Info('CreateDiscontMesh','Number of local discontinuous nodes: '& 743 //TRIM(I2S(NoDisContNodes)), Level=12) 744 ELSE 745 CALL Info('CreateDiscontMesh','All candidate nodes used',Level=12) 746 END IF 747 748 IF( NoDiscontNodes == 0 ) THEN 749 IF( n > 0 .AND. .NOT. GreedyBulk ) THEN 750 CALL Info('CreateDiscontMesh','You might want to try the Greedy bulk strategy',Level=3) 751 END IF 752 END IF 753 END IF 754 755 i = NINT( ParallelReduction( 1.0_dp * NoDiscontNodes ) ) 756 CALL Info('CreateDiscontMesh','Number of discontinuous nodes: '& 757 //TRIM(I2S(i)),Level=7) 758 759 IF( i == 0 ) THEN 760 CALL Warn('CreateDiscontMesh','Nothing to create, exiting...') 761 IF( CheckForHalo ) DEALLOCATE( HaloNode ) 762 DEALLOCATE( DiscontNode, DiscontElem, ParentUsed ) 763 RETURN 764 END IF 765 766 ! Ok, we have marked discontinuous nodes, now give them an index. 767 ! This should also create the indexes in parallel. 768 DisContPerm => NULL() 769 ALLOCATE( DisContPerm(NoNodes) ) 770 DisContPerm = 0 771 772 ! We could end up here on an parallel case only 773 ! Then we must make the parallel numbering, so jump to the end where this is done. 774 IF( NoDisContNodes == 0 ) THEN 775 IF( DoubleBC ) THEN 776 Mesh % DiscontMesh = .FALSE. 777 DEALLOCATE( DisContPerm ) 778 ELSE 779 Mesh % DisContMesh = .TRUE. 780 Mesh % DisContPerm => DisContPerm 781 Mesh % DisContNodes = 0 782 END IF 783 GOTO 200 784 END IF 785 786 ! Create a table showing nodes that are related to the moving nodes by 787 ! the moving elements. 788 ALLOCATE( MovingNode( NoNodes ), StayingNode( NoNodes ) ) 789 MovingNode = .FALSE. 790 StayingNode = .FALSE. 791 792 ! For historical reasons there is both single 'body' and multiple 'bodies' 793 ! that define on which side of the discontinuity the new nodes will be. 794 DiscontFlag = 'Discontinuous Target Bodies' 795 TargetBodies => ListGetIntegerArray( BCList, DiscontFlag, UseTargetBodies ) 796 IF(.NOT. UseTargetBodies ) THEN 797 DiscontFlag = 'Discontinuous Target Body' 798 TargetBodies => ListGetIntegerArray( BCList, DiscontFlag, UseTargetBodies ) 799 END IF 800 801 ! If either parent is consistently one of the bodies then we can create a discontinuous 802 ! boundary. Note that this currently only works currently in serial! 803 IF(.NOT. UseTargetBodies ) THEN 804 IF( ParEnv % PEs > 1 ) THEN 805 CALL Fatal('CreateDiscontMesh','Please give > Discontinuous Target Bodies < on the BC!') 806 END IF 807 808 CALL Info('CreateDiscontMesh','Trying to find a dominating parent body',Level=12) 809 810 CandA = -1 811 CandB = -1 812 DO t=1, NoBoundElems 813 IF(.NOT. DisContElem(t) ) CYCLE 814 Element => Mesh % Elements(NoBulkElems + t) 815 816 IF( .NOT. ASSOCIATED( Element % BoundaryInfo % Left ) ) THEN 817 CALL Fatal('CreateDiscontMesh','Alternative strategy requires all parent elements!') 818 END IF 819 IF( .NOT. ASSOCIATED( Element % BoundaryInfo % Right ) ) THEN 820 CALL Fatal('CreateDiscontMesh','Alternative strategy requires all parent elements!') 821 END IF 822 823 LeftBody = Element % BoundaryInfo % Left % BodyId 824 RightBody = Element % BoundaryInfo % Right % BodyId 825 826 IF( CandA == -1 ) THEN 827 CandA = LeftBody 828 ELSE IF( CandA == 0 ) THEN 829 CYCLE 830 ELSE IF( CandA /= LeftBody .AND. CandA /= RightBody ) THEN 831 CandA = 0 832 END IF 833 834 IF( CandB == -1 ) THEN 835 CandB = RightBody 836 ELSE IF( CandB == 0 ) THEN 837 CYCLE 838 ELSE IF( CandB /= LeftBody .AND. CandB /= RightBody ) THEN 839 CandB = 0 840 END IF 841 END DO 842 843 ! Choose the bigger one to honor the old convention 844 ! This eliminates at the same time the unsuccessful case of zero. 845 TargetBody(1) = MAX( CandA, CandB ) 846 847 IF( TargetBody(1) > 0 ) THEN 848 CALL Info('CreateDiscontMesh',& 849 'There seems to be a consistent discontinuous body: '& 850 //TRIM(I2S(TargetBody(1))),Level=8) 851 UseConsistantBody = .TRUE. 852 TargetBodies => TargetBody 853 ELSE 854 CALL Fatal('CreateDiscontMesh',& 855 'No simple rules available for determining discontinuous body') 856 END IF 857 END IF 858 859 860 ! Assume we have only one active BC and we know the list of discontinuous 861 ! target bodies there. Hence we have all the info needed to set the 862 ! discontinuous elements also for other bulk elements. 863 ! This could be made more generic... 864 NoUndecided = 0 865 NoMovingElems = 0 866 NoStayingElems = 0 867 868 DO t=1, NoBulkElems 869 Element => Mesh % Elements(t) 870 871 ! No need to treat halo elements 872 !IF( CheckForHalo .AND. Element % PartIndex /= ParEnv % MyPe ) CYCLE 873 874 Indexes => Element % NodeIndexes 875 876 IF( .NOT. ANY( DisContNode( Indexes ) ) ) CYCLE 877 Moving = ANY( TargetBodies == Element % BodyId ) 878 879 IF( Moving ) THEN 880 NoMovingElems = NoMovingElems + 1 881 MovingNode(Indexes) = .TRUE. 882 ELSE 883 StayingNode(Indexes) = .TRUE. 884 NoStayingElems = NoStayingElems + 1 885 END IF 886 END DO 887 888 CALL Info('CreateDiscontMesh','Number of bulk elements moving: '& 889 //TRIM(I2S(NoMovingElems)), Level=8) 890 CALL Info('CreateDiscontMesh','Number of bulk elements staying: '& 891 //TRIM(I2S(NoStayingElems)), Level=8) 892 893 ! Set discontinuous nodes only if there is a real moving node associted with it 894 ! Otherwise we would create a zero to the permutation vector. 895 ! If there is just a staying node then no need to create discontinuity at this node. 896 DiscontNode = DiscontNode .AND. MovingNode 897 898 ! Create permutation numbering for the discontinuous nodes 899 ! Doubling will be done only for nodes that have both parents 900 j = 0 901 DO i=1,NoNodes 902 IF( DisContNode(i) ) THEN 903 j = j + 1 904 DisContPerm(i) = j 905 END IF 906 END DO 907 IF( j < NoDiscontNodes ) THEN 908 PRINT *,'Some discontinuous nodes only needed on the other side:',& 909 ParEnv % MyPe, NoDiscontNodes-j 910 NoDiscontNodes = j 911 END IF 912 913 914 ! Now set the new indexes for bulk elements 915 ! In parallel skip the halo elements 916 DO t=1, NoBulkElems 917 Element => Mesh % Elements(t) 918 919 ! No need to treat halo elements 920 !IF( CheckForHalo .AND. Element % PartIndex /= ParEnv % MyPe ) CYCLE 921 Indexes => Element % NodeIndexes 922 923 IF( .NOT. ANY( DisContNode( Indexes ) ) ) CYCLE 924 Moving = ANY( TargetBodies == Element % BodyId ) 925 926 IF( Moving ) THEN 927 DO i=1, SIZE(Indexes) 928 j = DisContPerm(Indexes(i)) 929 IF( j > 0 ) Indexes(i) = NoNodes + j 930 END DO 931 END IF 932 END DO 933 934 935 ! Now set also the unset boundary elements by following the ownership of the parent elements 936 ! or the majority opinion if this is conflicting. 937 DO t=1, NoBoundElems 938 939 Element => Mesh % Elements(NoBulkElems + t) 940 941 ! If the element has no constraint then there is no need to treat it 942 IF( Element % BoundaryInfo % Constraint == 0 ) CYCLE 943 944 IF( DisContElem(t) ) THEN 945 LeftElem => Element % BoundaryInfo % Left 946 RightElem => Element % BoundaryInfo % Right 947 948 IF( ASSOCIATED( LeftElem ) ) THEN 949 Moving = ANY( TargetBodies == LeftElem % BodyId ) 950 ELSE 951 Moving = .NOT. ANY( TargetBodies == RightElem % BodyId ) 952 END IF 953 IF( Moving ) THEN 954 Element % BoundaryInfo % Left => RightElem 955 Element % BoundaryInfo % Right => LeftElem 956 END IF 957 CYCLE 958 END IF 959 960 961 Indexes => Element % NodeIndexes 962 963 IF( .NOT. ANY( DisContNode( Indexes ) ) ) CYCLE 964 965 ElemFamily = Element % TYPE % ElementCode / 100 966 LeftElem => Element % BoundaryInfo % Left 967 RightElem => Element % BoundaryInfo % Right 968 969 ! The boundary element follows the parent element if it is clear what to do 970 Set = .TRUE. 971 IF( ASSOCIATED( LeftElem ) .AND. ASSOCIATED( RightElem ) ) THEN 972 Moving = ANY( TargetBodies == LeftElem % BodyId ) 973 Moving2 = ANY( TargetBodies == RightElem % BodyId ) 974 IF( Moving .NEQV. Moving2) THEN 975 CALL Warn('CreateDiscontMesh','Conflicting moving information') 976 !PRINT *,'Moving:',t,Element % BoundaryInfo % Constraint, & 977 ! Moving,Moving2,LeftElem % BodyId, RightElem % BodyId 978 Set = .FALSE. 979 ELSE 980 IF( Moving ) THEN 981 Element % BoundaryInfo % Left => RightElem 982 Element % BoundaryInfo % Right => LeftElem 983 END IF 984 END IF 985 ELSE IF( ASSOCIATED( LeftElem ) ) THEN 986 Moving = ANY( LeftElem % NodeIndexes > NoNodes ) 987 ELSE IF( ASSOCIATED( RightElem ) ) THEN 988 Moving = ANY( RightElem % NodeIndexes > NoNodes ) 989 ELSE 990 CALL Fatal('CreateDiscontMesh','Boundary BC has no parants!') 991 END IF 992 993 ! Otherwise we follow the majority rule 994 IF( .NOT. Set ) THEN 995 NoMoving = COUNT( MovingNode(Indexes) ) 996 NoStaying = COUNT( StayingNode(Indexes) ) 997 998 IF( NoStaying /= NoMoving ) THEN 999 Moving = ( NoMoving > NoStaying ) 1000 Set = .TRUE. 1001 END IF 1002 END IF 1003 1004 ! Ok, finally set whether boundary element is moving or staying 1005 IF( Set ) THEN 1006 IF( Moving ) THEN 1007 NoMovingElems = NoMovingElems + 1 1008 DO i=1, SIZE(Indexes) 1009 j = DisContPerm(Indexes(i)) 1010 IF( j > 0 ) Indexes(i) = NoNodes + j 1011 END DO 1012 ELSE 1013 NoStayingElems = NoStayingElems + 1 1014 END IF 1015 ELSE 1016 NoUndecided = NoUndecided + 1 1017 END IF 1018 END DO 1019 1020 CALL Info('CreateDiscontMesh','Number of related elements moving: '& 1021 //TRIM(I2S(NoMovingElems)), Level=8 ) 1022 CALL Info('CreateDiscontMesh','Number of related elements staying: '& 1023 //TRIM(I2S(NoStayingElems)), Level=8 ) 1024 IF( NoUndecided == 0 ) THEN 1025 CALL Info('CreateDiscontMesh','All elements marked either moving or staying') 1026 ELSE 1027 CALL Info('CreateDiscontMesh','Number of related undecided elements: '//TRIM(I2S(NoUndecided)) ) 1028 CALL Warn('CreateDiscontMesh','Could not decide what to do with some boundary elements!') 1029 END IF 1030 1031 1032 m = COUNT( DiscontNode .AND. .NOT. MovingNode ) 1033 IF( m > 0 ) THEN 1034 PRINT *,'Number of discont nodes not moving: ',ParEnv % MyPe, m 1035 END IF 1036 1037 m = COUNT( DiscontNode .AND. .NOT. StayingNode ) 1038 IF( m > 0 ) THEN 1039 PRINT *,'Number of discont nodes not staying: ',ParEnv % MyPe, m 1040 DO i=1,SIZE(DisContNode) 1041 IF( DiscontNode(i) .AND. .NOT. StayingNode(i) ) THEN 1042 IF( ParEnv % PEs == 1 ) THEN 1043 PRINT *,'Node:',ParEnv % MyPe,i 1044 ELSE 1045 PRINT *,'Node:',ParEnv % MyPe,i,Mesh % ParallelInfo % GlobalDofs(i), & 1046 Mesh % ParallelInfo % NeighbourList(i) % Neighbours 1047 END IF 1048 PRINT *,'Coord:',ParEnv % MyPe, Mesh % Nodes % x(i), Mesh % Nodes % y(i) 1049 END IF 1050 END DO 1051 END IF 1052 1053 !DEALLOCATE( MovingNode, StayingNode ) 1054 1055 ! Now add the new nodes also to the nodes structure 1056 ! and give the new nodes the same coordinates as the ones 1057 ! that they were derived from. 1058 Mesh % NumberOfNodes = NoNodes + NoDisContNodes 1059 CALL EnlargeCoordinates( Mesh ) 1060 1061 CALL Info('CreateDiscontMesh','Setting new coordinate positions',Level=12) 1062 DO i=1, NoNodes 1063 j = DisContPerm(i) 1064 IF( j > 0 ) THEN 1065 k = NoNodes + j 1066 Mesh % Nodes % x(k) = Mesh % Nodes % x(i) 1067 Mesh % Nodes % y(k) = Mesh % Nodes % y(i) 1068 Mesh % Nodes % z(k) = Mesh % Nodes % z(i) 1069 END IF 1070 END DO 1071 1072 1073 ! If the discontinuous boundary is duplicated then no information of it 1074 ! is saved. The periodic and mortar conditions now need to perform 1075 ! searches. On the other hand the meshes may now freely move., 1076 IF( DoubleBC ) THEN 1077 CALL Info('CreateDiscontMesh','Creating secondary boundary for Discontinuous gap',Level=10) 1078 1079 CALL EnlargeBoundaryElements( Mesh, NoDiscontElems ) 1080 1081 NoDisContElems = 0 1082 DO t=1, NoBoundElems 1083 1084 ! Is this a boundary to be doubled? 1085 IF(.NOT. DisContElem(t) ) CYCLE 1086 1087 Element => Mesh % Elements(NoBulkElems + t) 1088 IF(.NOT. ASSOCIATED(Element) ) THEN 1089 CALL Fatal('CreateDiscontMesh','Element '//TRIM(I2S(NoBulkElems+t))//' not associated!') 1090 END IF 1091 Indexes => Element % NodeIndexes 1092 1093 DisContTarget = 0 1094 Found = .FALSE. 1095 DO bc = 1,Model % NumberOfBCs 1096 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 1097 DisContTarget = ListGetInteger( Model % BCs(bc) % Values,& 1098 'Discontinuous BC',Found ) 1099 IF( Found ) EXIT 1100 DisContTarget = ListGetInteger( Model % BCs(bc) % Values,& 1101 'Mortar BC',Found ) 1102 IF( Found ) EXIT 1103 DisContTarget = ListGetInteger( Model % BCs(bc) % Values,& 1104 'Periodic BC',Found ) 1105 IF( Found ) EXIT 1106 DisContTarget = ListGetInteger( Model % BCs(bc) % Values,& 1107 'Contact BC',Found ) 1108 IF( Found ) EXIT 1109 END IF 1110 END DO 1111 IF( .NOT. Found .OR. DisContTarget == 0 ) THEN 1112 CALL Fatal('CreateDiscontMesh','Nonzero target boundary must be given for all, if any bc!') 1113 END IF 1114 1115 RightElem => Element % BoundaryInfo % Right 1116 LeftElem => Element % BoundaryInfo % Left 1117 1118 NoDisContElems = NoDisContElems + 1 1119 j = NoBulkElems + NoBoundElems + NoDisContElems 1120 1121 OtherElem => Mesh % Elements( j ) 1122 IF(.NOT. ASSOCIATED(OtherElem) ) THEN 1123 CALL Fatal('CreateDiscontMesh','Other elem '//TRIM(I2S(j))//' not associated!') 1124 END IF 1125 1126 OtherElem = Element 1127 OtherElem % TYPE => Element % TYPE 1128 1129 NULLIFY( OtherElem % BoundaryInfo ) 1130 ALLOCATE( OtherElem % BoundaryInfo ) 1131 OtherElem % BoundaryInfo % Left => Element % BoundaryInfo % Right 1132 1133 ! Now both boundary elements are just one sided. Remove the associated to the other side. 1134 NULLIFY( Element % BoundaryInfo % Right ) 1135 NULLIFY( OtherElem % BoundaryInfo % Right ) 1136 1137 NULLIFY( OtherElem % NodeIndexes ) 1138 n = SIZE( Element % NodeIndexes ) 1139 ALLOCATE( OtherElem % NodeIndexes( n ) ) 1140 1141 ! Ok, we found the element to manipulate the indexes. 1142 ! The new index is numbered on top of the old indexes. 1143 DO i=1,n 1144 j = Element % NodeIndexes(i) 1145 IF( DisContPerm(j) > 0 ) THEN 1146 OtherElem % NodeIndexes(i) = NoNodes + DisContPerm(j) 1147 ELSE 1148 OtherElem % NodeIndexes(i) = j 1149 END IF 1150 END DO 1151 1152 OtherElem % BoundaryInfo % Constraint = DisContTarget 1153 END DO 1154 1155 CALL Info('CreateDiscontMesh','Number of original bulk elements: '& 1156 //TRIM(I2S(Mesh % NumberOfBulkElements)),Level=10) 1157 CALL Info('CreateDiscontMesh','Number of original boundary elements: '& 1158 //TRIM(I2S(Mesh % NumberOfBoundaryElements)),Level=10) 1159 CALL Info('CreateDiscontMesh','Number of additional boundary elements: '& 1160 //TRIM(I2S(NoDisContElems)),Level=10) 1161 1162 Mesh % DiscontMesh = .FALSE. 1163 ELSE 1164 Mesh % DisContMesh = .TRUE. 1165 Mesh % DisContPerm => DisContPerm 1166 Mesh % DisContNodes = NoDisContNodes 1167 END IF 1168 1169200 CONTINUE 1170 1171 1172 CALL EnlargeParallelInfo(Mesh, DiscontPerm ) 1173 IF( ParEnv % PEs > 1 ) THEN 1174 m = COUNT( Mesh % ParallelInfo % GlobalDofs == 0) 1175 IF( m > 0 ) CALL Warn('CreateDiscontMesh','There are nodes with zero global dof index: '//TRIM(I2S(m))) 1176 END IF 1177 1178 IF( DoubleBC .AND. NoDiscontNodes > 0 ) DEALLOCATE( DisContPerm ) 1179 1180 1181 DEALLOCATE( DisContNode, DiscontElem ) 1182 1183 END SUBROUTINE CreateDiscontMesh 1184 1185 1186!> Reallocate coordinate arrays for iso-parametric p-elements, 1187!> or if the size of nodes has been increased due to discontinuity. 1188!> This does not seem to be necessary for other types of 1189!> elements (face, edge, etc.) 1190! ----------------------------------------------------------- 1191 SUBROUTINE EnlargeCoordinates(Mesh) 1192 1193 TYPE(Mesh_t) :: Mesh 1194 INTEGER :: n0, n 1195 REAL(KIND=dp), POINTER :: TmpCoord(:) 1196 1197 INTEGER :: i 1198 LOGICAL :: pelementsPresent 1199 1200 n = Mesh % NumberOfNodes + & 1201 Mesh % MaxEdgeDOFs * Mesh % NumberOFEdges + & 1202 Mesh % MaxFaceDOFs * Mesh % NumberOFFaces + & 1203 Mesh % MaxBDOFs * Mesh % NumberOFBulkElements 1204 n0 = SIZE( Mesh % Nodes % x ) 1205 1206 pelementsPresent = .FALSE. 1207 DO i=1,Mesh % NumberOfBulkElements 1208 IF(isPelement(Mesh % Elements(i))) THEN 1209 pelementsPresent = .TRUE.; EXIT 1210 END IF 1211 END DO 1212 1213 IF ( Mesh % NumberOfNodes > n0 .OR. n > n0 .AND. pelementsPresent ) THEN 1214 CALL Info('EnlargeCoordinates','Increasing number of nodes from '& 1215 //TRIM(I2S(n0))//' to '//TRIM(I2S(n)),Level=8) 1216 1217 TmpCoord => Mesh % Nodes % x 1218 ALLOCATE( Mesh % Nodes % x(n) ) 1219 Mesh % Nodes % x(1:n0) = TmpCoord 1220 Mesh % Nodes % x(n0 + 1:n) = 0.0_dp 1221 DEALLOCATE( TmpCoord ) 1222 1223 TmpCoord => Mesh % Nodes % y 1224 ALLOCATE( Mesh % Nodes % y(n) ) 1225 Mesh % Nodes % y(1:n0) = TmpCoord 1226 Mesh % Nodes % y(n0 + 1:n) = 0.0_dp 1227 DEALLOCATE( TmpCoord ) 1228 1229 TmpCoord => Mesh % Nodes % z 1230 ALLOCATE( Mesh % Nodes % z(n) ) 1231 Mesh % Nodes % z(1:n0) = TmpCoord 1232 Mesh % Nodes % z(n0 + 1:n) = 0.0_dp 1233 DEALLOCATE( TmpCoord ) 1234 END IF 1235 1236 END SUBROUTINE EnlargeCoordinates 1237 1238 1239 1240 SUBROUTINE EnlargeBoundaryElements(Mesh, DoubleElements ) 1241 1242 TYPE(Mesh_t) :: Mesh 1243 INTEGER :: DoubleElements 1244 INTEGER :: n,n0,i,j 1245 REAL(KIND=dp), POINTER :: TmpCoord(:) 1246 TYPE(Element_t), POINTER :: NewElements(:),OldElements(:), Element 1247 1248 IF( DoubleElements == 0 ) RETURN 1249 1250 n0 = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 1251 n = n0 + DoubleElements 1252 1253 CALL Info('EnlargeBoundaryElements','Increasing number of elements from '& 1254 //TRIM(I2S(n0))//' to '//TRIM(I2S(n)),Level=8) 1255 1256 OldElements => Mesh % Elements 1257 CALL AllocateVector( Mesh % Elements, n, 'EnlargeBoundaryElements' ) 1258 DO i=1,n0 1259 Mesh % Elements(i) = OldElements(i) 1260 IF(ASSOCIATED(OldElements(i) % BoundaryInfo)) THEN 1261 IF (ASSOCIATED(OldElements(i) % BoundaryInfo % Left)) & 1262 Mesh % Elements(i) % BoundaryInfo % Left => & 1263 Mesh % Elements(OldElements(i) % BoundaryInfo % Left % ElementIndex) 1264 1265 IF (ASSOCIATED(OldElements(i) % BoundaryInfo % Right)) & 1266 Mesh % Elements(i) % BoundaryInfo % Right => & 1267 Mesh % Elements(OldElements(i) % BoundaryInfo % Right % ElementIndex) 1268 END IF 1269 END DO 1270 1271 DO i=n0+1,n 1272 Element => Mesh % Elements(i) 1273 1274 Element % DGDOFs = 0 1275 Element % BodyId = 0 1276 Element % TYPE => NULL() 1277 Element % BoundaryInfo => NULL() 1278 Element % PDefs => NULL() 1279 Element % DGIndexes => NULL() 1280 Element % EdgeIndexes => NULL() 1281 Element % FaceIndexes => NULL() 1282 Element % BubbleIndexes => NULL() 1283 END DO 1284 1285 DEALLOCATE( OldElements ) 1286 Mesh % NumberOfBoundaryElements = Mesh % NumberOfBoundaryElements + DoubleElements 1287 1288 END SUBROUTINE EnlargeBoundaryElements 1289 1290 1291 SUBROUTINE EnlargeParallelInfo( Mesh, DiscontPerm ) 1292 1293 TYPE(Mesh_t) :: Mesh 1294 INTEGER, POINTER :: DiscontPerm(:) 1295 1296 INTEGER :: nmax,n0,n1,i,j,istat, goffset 1297 INTEGER, POINTER :: TmpGlobalDofs(:) 1298 INTEGER, ALLOCATABLE :: Perm(:) 1299 LOGICAL, POINTER :: Intf(:) 1300 TYPE(NeighbourList_t), POINTER :: Nlist(:) 1301 1302 IF ( ParEnv % PEs <= 1 ) RETURN 1303 1304 ! As index offset use the number of nodes in the whole mesh 1305 goffset = ParallelReduction( MAXVAL(Mesh % ParallelInfo % GlobalDofs)*1._dp,2 ) 1306 1307 n0 = SIZE( Mesh % ParallelInfo % GlobalDofs ) 1308 n1 = Mesh % NumberOfNodes 1309 IF( n0 >= n1 ) THEN 1310 CALL Info('EnlargeParallelInfo','No need to grow: '& 1311 //TRIM(I2S(n0))//' vs. '//TRIM(I2S(n1)),Level=10) 1312 RETURN 1313 END IF 1314 1315 CALL Info('EnlargeParallelInfo','Increasing global numbering size from '& 1316 //TRIM(I2S(n0))//' to '//TRIM(I2S(n1)),Level=8) 1317 1318 ! Create permutation table for the added nodes 1319 ALLOCATE(Perm(n1)); Perm = 0 1320 DO i=1,n0 1321 IF ( DiscontPerm(i) > 0 ) THEN 1322 Perm(DiscontPerm(i)+n0) = i 1323 END IF 1324 END DO 1325 1326 ! Create the enlarged set of global nodes indexes 1327 ALLOCATE( TmpGlobalDofs(n1), STAT=istat ) 1328 IF (istat /= 0) CALL Fatal('EnlargeParallelInfo', 'Unable to allocate TmpGlobalDofs array.') 1329 TmpGlobalDofs = 0 1330 DO i=1,n0 1331 TmpGlobalDofs(i) = Mesh % ParallelInfo % GlobalDofs(i) 1332 END DO 1333 DO i=n0+1,n1 1334 j = Perm(i) 1335 IF(j > 0) THEN 1336 TmpGlobalDofs(i) = TmpGlobalDOfs(j) + goffset 1337 END IF 1338 END DO 1339 DEALLOCATE(Mesh % ParallelInfo % GlobalDofs) 1340 Mesh % ParallelInfo % GlobalDOfs => TmpGlobalDofs 1341 1342 ! Create the enlarged list of neighbours 1343 ALLOCATE(Nlist(n1)) 1344 DO i=1,n0 1345 IF( ASSOCIATED( Mesh % ParallelInfo % NeighbourList(i) % Neighbours ) ) THEN 1346 Nlist(i) % Neighbours => & 1347 Mesh % ParallelInfo % NeighbourList(i) % Neighbours 1348 Mesh % ParallelInfo % NeighbourList(i) % Neighbours => NULL() 1349 ELSE 1350 Nlist(i) % Neighbours => NULL() 1351 END IF 1352 END DO 1353 1354 DO i=n0+1,n1 1355 j = Perm(i) 1356 IF ( j > 0 ) THEN 1357 IF( ASSOCIATED( Nlist(j) % Neighbours ) ) THEN 1358 ALLOCATE( Nlist(i) % Neighbours(SIZE(Nlist(j) % Neighbours) ) ) 1359 Nlist(i) % Neighbours = Nlist(j) % Neighbours 1360 ELSE 1361 Nlist(i) % Neighbours => NULL() 1362 END IF 1363 END IF 1364 END DO 1365 DEALLOCATE(Mesh % ParallelInfo % NeighbourList) 1366 Mesh % ParallelInfo % NeighbourList => Nlist 1367 1368 1369 ! Create logical table showing the interface nodes 1370 ALLOCATE( Intf(n1) ) 1371 Intf = .FALSE. 1372 Intf(1:n0) = Mesh % ParallelInfo % INTERFACE(1:n0) 1373 DO i=n0+1,n1 1374 j = Perm(i) 1375 IF(j > 0 ) THEN 1376 Intf(i) = Intf(j) 1377 END IF 1378 END DO 1379 DEALLOCATE( Mesh % ParallelInfo % INTERFACE ) 1380 Mesh % ParallelInfo % Interface => Intf 1381 1382 1383 END SUBROUTINE EnlargeParallelInfo 1384 1385 1386 1387 1388 !> Fortran reader for Elmer ascii mesh file format. 1389 !> This is a Fortran replacement for the old C++ eio library. 1390 !------------------------------------------------------------------------ 1391 SUBROUTINE ElmerAsciiMesh(Step, PMesh, MeshNamePar, ThisPe, NumPEs, IsParallel ) 1392 1393 IMPLICIT NONE 1394 1395 INTEGER :: Step 1396 CHARACTER(LEN=*), OPTIONAL :: MeshNamePar 1397 TYPE(Mesh_t), POINTER, OPTIONAL :: PMesh 1398 INTEGER, OPTIONAL :: ThisPe, NumPEs 1399 LOGICAL, OPTIONAL :: IsParallel 1400 1401 TYPE(Mesh_t), POINTER :: Mesh 1402 INTEGER :: PrevStep=0, iostat 1403 INTEGER, PARAMETER :: FileUnit = 10 1404 CHARACTER(MAX_NAME_LEN) :: BaseName, FileName 1405 INTEGER :: i,j,k,n,BaseNameLen, SharedNodes = 0, mype = 0, numprocs = 0 1406 INTEGER, POINTER :: NodeTags(:), ElementTags(:), LocalPerm(:) 1407 INTEGER :: MinNodeTag = 0, MaxNodeTag = 0, istat 1408 LOGICAL :: ElementPermutation=.FALSE., NodePermutation=.FALSE., Parallel 1409 1410 1411 1412 SAVE PrevStep, BaseName, BaseNameLen, Mesh, mype, Parallel, & 1413 NodeTags, ElementTags, LocalPerm 1414 1415 CALL Info('ElmerAsciiMesh','Performing step: '//TRIM(I2S(Step)),Level=8) 1416 1417 IF( Step - PrevStep /= 1 ) THEN 1418 CALL Fatal('ElmerAsciiMesh','The routine should be called in sequence: '// & 1419 TRIM(I2S(PrevStep))//' : '//TRIM(I2S(Step)) ) 1420 END IF 1421 PrevStep = Step 1422 IF( PrevStep == 6 ) PrevStep = 0 1423 1424 IF( Step == 1 ) THEN 1425 IF(.NOT. PRESENT( MeshNamePar ) ) THEN 1426 CALL Fatal('ElmerAsciiMesh','When calling in mode one give MeshNamePar!') 1427 END IF 1428 BaseName = TRIM( MeshNamePar ) 1429 IF(.NOT. PRESENT( PMesh ) ) THEN 1430 CALL Fatal('ElmerAsciiMesh','When calling in mode one give PMesh!') 1431 END IF 1432 Mesh => PMesh 1433 IF(.NOT. PRESENT( ThisPe ) ) THEN 1434 CALL Fatal('ElmerAsciiMesh','When calling in mode one give ThisPe!') 1435 END IF 1436 mype = ThisPe 1437 IF(.NOT. PRESENT( NumPEs) ) THEN 1438 CALL Fatal('ElmerAsciiMesh','When calling in mode one give NumPEs!') 1439 END IF 1440 numprocs = NumPEs 1441 IF(.NOT. PRESENT( IsParallel ) ) THEN 1442 CALL Fatal('ElmerAsciiMesh','When calling in mode one give IsParallel!') 1443 END IF 1444 Parallel = IsParallel 1445 1446 i = LEN_TRIM(MeshNamePar) 1447 DO WHILE(MeshNamePar(i:i) == CHAR(0)) 1448 i=i-1 1449 END DO 1450 BaseNameLen = i 1451 CALL Info('ElmerAsciiMesh','Base mesh name: '//TRIM(MeshNamePar(1:BaseNameLen))) 1452 END IF 1453 1454 1455 SELECT CASE( Step ) 1456 1457 CASE(1) 1458 CALL ReadHeaderFile() 1459 1460 CASE(2) 1461 CALL ReadNodesFile() 1462 1463 CASE(3) 1464 CALL ReadElementsFile() 1465 1466 CASE(4) 1467 CALL ReadBoundaryFile() 1468 CALL PermuteNodeNumbering() 1469 1470 CASE(5) 1471 CALL InitParallelInfo() 1472 CALL ReadSharedFile() 1473 1474 CASE(6) 1475 IF( ASSOCIATED( LocalPerm) ) DEALLOCATE( LocalPerm ) 1476 IF( ASSOCIATED( ElementTags) ) DEALLOCATE( ElementTags ) 1477 1478 END SELECT 1479 1480 1481 CONTAINS 1482 1483 1484 FUNCTION read_ints(s,j,halo) RESULT(n) 1485 INTEGER :: j(:) 1486 CHARACTER(LEN=*) :: s 1487 LOGICAL :: halo 1488 1489 INTEGER :: i,k,l,m,n,ic 1490 INTEGER, PARAMETER :: ic0 = ICHAR('0'), ic9 = ICHAR('9'), icm = ICHAR('-'), & 1491 icd = ICHAR('/'), ics = ICHAR(' ') 1492 1493 k = LEN_TRIM(s) 1494 l = 1 1495 n = 0 1496 halo = .FALSE. 1497 DO WHILE(l<=k.AND.n<SIZE(j)) 1498 DO WHILE(l<=k) 1499 ic = ICHAR(s(l:l)) 1500 IF( ic == ics ) THEN 1501 CONTINUE 1502 ELSE IF( ic == icd ) THEN 1503 halo = .TRUE. 1504 ELSE 1505 EXIT 1506 END IF 1507 l=l+1 1508 END DO 1509 IF(l>k) EXIT 1510 IF(.NOT.(ic==icm .OR. ic>=ic0 .AND. ic<=ic9)) EXIT 1511 1512 m = l+1 1513 DO WHILE(m<=k) 1514 ic = ICHAR(s(m:m)) 1515 IF(ic<ic0 .OR. ic>ic9) EXIT 1516 m=m+1 1517 END DO 1518 1519 n = n + 1 1520 j(n) = s2i(s(l:m-1),m-l) 1521 l = m 1522 END DO 1523 END FUNCTION read_ints 1524 1525 1526 !--------------------------------------------------- 1527 ! Read header file and allocate some mesh structures 1528 !--------------------------------------------------- 1529 SUBROUTINE ReadHeaderFile() 1530 1531 INTEGER :: TypeCount 1532 INTEGER :: Types(64),CountByType(64) 1533 1534 IF( Parallel ) THEN 1535 FileName = BaseName(1:BaseNameLen)//& 1536 '/partitioning.'//TRIM(I2S(numprocs))//& 1537 '/part.'//TRIM(I2S(mype+1))//'.header' 1538 ELSE 1539 FileName = BaseName(1:BaseNameLen)//'/mesh.header' 1540 END IF 1541 1542 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', IOSTAT = iostat ) 1543 IF( iostat /= 0 ) THEN 1544 CALL Fatal('ReadHeaderFile','Could not open file: '//TRIM(Filename)) 1545 ELSE 1546 CALL Info('ReadHeaderFile','Reading header info from file: '//TRIM(FileName),Level=10) 1547 END IF 1548 1549 READ(FileUnit,*,IOSTAT=iostat) Mesh % NumberOfNodes, & 1550 Mesh % NumberOfBulkElements,& 1551 Mesh % NumberOfBoundaryElements 1552 IF( iostat /= 0 ) THEN 1553 CALL Fatal('ReadHeaderFile','Could not read header 1st line in file: '//TRIM(FileName)) 1554 END IF 1555 1556 Types = 0 1557 CountByType = 0 1558 READ(FileUnit,*,IOSTAT=iostat) TypeCount 1559 IF( iostat /= 0 ) THEN 1560 CALL Fatal('ReadHeaderFile','Could not read the type count in file: '//TRIM(FileName)) 1561 END IF 1562 DO i=1,TypeCount 1563 READ(FileUnit,*,IOSTAT=iostat) Types(i),CountByType(i) 1564 IF( iostat /= 0 ) THEN 1565 CALL Fatal('ReadHeaderFile','Could not read type count '& 1566 //TRIM(I2S(i))//'in file: '//TRIM(FileName)) 1567 END IF 1568 END DO 1569 1570 IF( Parallel ) THEN 1571 READ(FileUnit,*,IOSTAT=iostat) SharedNodes 1572 IF( iostat /= 0 ) THEN 1573 CALL Fatal('ReadHeaderFile','Could not read shared nodes in file: '//TRIM(FileName)) 1574 END IF 1575 ELSE 1576 SharedNodes = 0 1577 END IF 1578 1579 Mesh % MaxElementNodes = 0 1580 DO i=1,TypeCount 1581 Mesh % MaxElementNodes = MAX( & 1582 Mesh % MaxElementNodes, MODULO( Types(i), 100) ) 1583 END DO 1584 1585 CLOSE(FileUnit) 1586 1587 END SUBROUTINE ReadHeaderFile 1588 1589 1590 !----------------------------------------------------------------------- 1591 ! Read nodes file and create nodal permutation if needed 1592 !----------------------------------------------------------------------- 1593 SUBROUTINE ReadNodesFile() 1594 1595 REAL(KIND=dp) :: Coords(3) 1596 INTEGER :: NodeTag 1597 1598 IF( Parallel ) THEN 1599 FileName = BaseName(1:BaseNameLen)//& 1600 '/partitioning.'//TRIM(I2S(numprocs))//& 1601 '/part.'//TRIM(I2S(mype+1))//'.nodes' 1602 ELSE 1603 FileName = BaseName(1:BaseNameLen)//'/mesh.nodes' 1604 END IF 1605 1606 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', IOSTAT = iostat ) 1607 IF( iostat /= 0 ) THEN 1608 CALL Fatal('ReadNodesFile','Could not open file: '//TRIM(Filename)) 1609 ELSE 1610 CALL Info('ReadNodesFile','Reading nodes from file: '//TRIM(FileName),Level=10) 1611 END IF 1612 1613 ALLOCATE( NodeTags(Mesh % NumberOfNodes ) ) 1614 NodeTags = 0 1615 1616 NodePermutation = .FALSE. 1617 DO j = 1, Mesh % NumberOfNodes 1618 READ(FileUnit,*,IOSTAT=iostat) NodeTag, k, Coords 1619 IF( iostat /= 0 ) THEN 1620 CALL Fatal('ReadNodesFile','Problem load node '//TRIM(I2S(j))//' in file: '//TRIM(Filename)) 1621 END IF 1622 1623 IF( NodeTags(j) /= j ) NodePermutation = .TRUE. 1624 1625 NodeTags(j) = NodeTag 1626 Mesh % Nodes % x(j) = Coords(1) 1627 Mesh % Nodes % y(j) = Coords(2) 1628 Mesh % Nodes % z(j) = Coords(3) 1629 END DO 1630 1631 CLOSE(FileUnit) 1632 1633 END SUBROUTINE ReadNodesFile 1634 1635 1636 !------------------------------------------------------------------------------ 1637 ! Read elements file and create elemental permutation if needed 1638 !------------------------------------------------------------------------------ 1639 SUBROUTINE ReadElementsFile() 1640 TYPE(Element_t), POINTER :: Element 1641 INTEGER :: ElemType, Tag, Body, ElemNo, Ivals(64),nread, ioffset, partn 1642 CHARACTER(256) :: str 1643 LOGICAL :: halo 1644 1645 1646 CALL AllocateVector( ElementTags, Mesh % NumberOfBulkElements+1, 'ReadElementsFile') 1647 ElementTags = 0 1648 ElementPermutation = .FALSE. 1649 1650 IF( Parallel ) THEN 1651 FileName = BaseName(1:BaseNameLen)// & 1652 '/partitioning.'//TRIM(I2S(numprocs))//& 1653 '/part.'//TRIM(I2S(mype+1))//'.elements' 1654 ELSE 1655 FileName = BaseName(1:BaseNameLen)//'/mesh.elements' 1656 END IF 1657 1658 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', iostat=IOSTAT ) 1659 IF( iostat /= 0 ) THEN 1660 CALL Fatal('ReadElementsFile','Could not open file: '//TRIM(Filename)) 1661 ELSE 1662 CALL Info('ReadElementsFile','Reading bulk elements from file: '//TRIM(FileName),Level=10) 1663 END IF 1664 1665 1666 DO j=1,Mesh % NumberOfBulkElements 1667 1668 Element => Mesh % Elements(j) 1669 IF(.NOT. ASSOCIATED( Element ) ) THEN 1670 CALL Fatal('ReadElementsFile','Element '//TRIM(I2S(i))//' not associated!') 1671 END IF 1672 1673 READ(FileUnit, '(a)', IOSTAT=iostat) str 1674 IF( iostat /= 0 ) THEN 1675 CALL Fatal('ReadElementsFile','Could not read start of element entry: '//TRIM(I2S(j))) 1676 END IF 1677 1678 nread = read_ints(str,ivals,halo) 1679 1680 tag = ivals(1) 1681 1682 IF( halo ) THEN 1683 ioffset = 1 1684 partn = ivals(2) 1685 ELSE 1686 ioffset = 0 1687 partn = 0 1688 END IF 1689 body = ivals(ioffset+2) 1690 ElemType = ivals(ioffset+3) 1691 1692 ElementTags(j) = tag 1693 IF( j /= tag ) ElementPermutation = .TRUE. 1694 Element % ElementIndex = j 1695 Element % BodyId = body 1696 1697 IF( partn > 0 ) THEN 1698 Element % PartIndex = partn-1 1699 ELSE 1700 Element % PartIndex = mype 1701 END IF 1702 1703 Element % TYPE => GetElementType(ElemType) 1704 1705 IF ( .NOT. ASSOCIATED(Element % TYPE) ) THEN 1706 CALL Fatal('ReadElementsFile','Element of type '& 1707 //TRIM(I2S(ElemType))//' could not be associated!') 1708 END IF 1709 1710 n = Element % TYPE % NumberOfNodes 1711 IF( nread < n + ioffset + 3 ) THEN 1712 CALL Fatal('ReadElementsFile','Line '//TRIM(I2S(j))//' does not contain enough entries') 1713 END IF 1714 1715 CALL AllocateVector( Element % NodeIndexes, n ) 1716 1717 Element % NodeIndexes(1:n) = IVals(4+ioffset:nread) 1718 END DO 1719 CLOSE( FileUnit ) 1720 1721 END SUBROUTINE ReadElementsFile 1722 !------------------------------------------------------------------------------ 1723 1724 1725 !------------------------------------------------------------------------------ 1726 ! Read boundary elements file and remap the parents if needed. 1727 !------------------------------------------------------------------------------ 1728 SUBROUTINE ReadBoundaryFile() 1729 INTEGER, POINTER :: LocalEPerm(:) 1730 INTEGER :: MinEIndex, MaxEIndex, ElemNodes, i 1731 INTEGER :: Left, Right, bndry, tag, ElemType, IVals(64), nread, ioffset, partn 1732 TYPE(Element_t), POINTER :: Element 1733 CHARACTER(256) :: str 1734 LOGICAL :: halo 1735 1736 IF( Parallel ) THEN 1737 FileName = BaseName(1:BaseNameLen)//& 1738 '/partitioning.'//TRIM(I2S(numprocs))//& 1739 '/part.'//TRIM(I2S(mype+1))//'.boundary' 1740 ELSE 1741 FileName = BaseName(1:BaseNameLen)//'/mesh.boundary' 1742 END IF 1743 1744 ! Create permutation for the elements. This is needed when the element 1745 ! parents are mapped to the new order. This is needed for mapping of the 1746 ! parents. Otherwise the element numbering is arbitrary. 1747 !------------------------------------------------------------------------------ 1748 IF( ElementPermutation ) THEN 1749 MinEIndex = MINVAL( ElementTags(1:Mesh % NumberOfBulkElements) ) 1750 MaxEIndex = MAXVAL( ElementTags(1:Mesh % NumberOfBulkElements) ) 1751 1752 LocalEPerm => NULL() 1753 CALL AllocateVector( LocalEPerm, MaxEIndex - MinEIndex + 1, 'ReadBoundaryFile' ) 1754 LocalEPerm = 0 1755 DO i=1,Mesh % NumberOfBulkElements 1756 LocalEPerm( ElementTags(i) - MinEIndex + 1 ) = i 1757 END DO 1758 ELSE 1759 MinEIndex = 1 1760 MaxEIndex = Mesh % NumberOfBulkElements 1761 END IF 1762 1763 1764 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', iostat=IOSTAT ) 1765 IF( iostat /= 0 ) THEN 1766 CALL Fatal('ReadBoundaryFile','Could not open file: '//TRIM(Filename)) 1767 ELSE 1768 CALL Info('ReadBoundaryFile','Reading boundary elements from file: '//TRIM(FileName),Level=10) 1769 END IF 1770 1771 1772 DO j=Mesh % NumberOfBulkElements+1, & 1773 Mesh % NumberOfBulkElements+Mesh % NumberOfBoundaryElements 1774 1775 Element => Mesh % Elements(j) 1776 IF(.NOT. ASSOCIATED( Element ) ) THEN 1777 CALL Fatal('ReadBoundaryFile','Element '//TRIM(I2S(i))//' not associated!') 1778 END IF 1779 1780 READ(FileUnit, '(a)', IOSTAT=iostat) str 1781 IF( iostat /= 0 ) THEN 1782 CALL Fatal('ReadBoundaryFile','Could not read boundary element entry: '//TRIM(I2S(j))) 1783 END IF 1784 nread = read_ints(str,ivals,halo) 1785 1786 tag = ivals(1) 1787 1788 IF( halo ) THEN 1789 partn = ivals(2) 1790 ioffset = 1 1791 ELSE 1792 partn = 0 1793 ioffset = 0 1794 END IF 1795 1796 bndry = ivals(ioffset+2) 1797 left = ivals(ioffset+3) 1798 right = ivals(ioffset+4) 1799 ElemType = ivals(ioffset+5) 1800 1801 Element % ElementIndex = j 1802 Element % TYPE => GetElementType(ElemType) 1803 IF ( .NOT. ASSOCIATED(Element % TYPE) ) THEN 1804 CALL Fatal('ReadBoundaryFile','Element of type '//TRIM(I2S(ElemType))//'could not be associated!') 1805 END IF 1806 1807 ElemNodes = Element % TYPE % NumberOfNodes 1808 Mesh % MaxElementNodes = MAX( Mesh % MaxElementNodes, ElemNodes ) 1809 1810 IF( partn == 0 ) THEN 1811 Element % PartIndex = mype 1812 ELSE 1813 Element % PartIndex = partn-1 1814 END IF 1815 1816 CALL AllocateBoundaryInfo( Element ) 1817 1818 Element % BoundaryInfo % Constraint = bndry 1819 Element % BoundaryInfo % Left => NULL() 1820 Element % BoundaryInfo % Right => NULL() 1821 1822 IF ( Left >= MinEIndex .AND. Left <= MaxEIndex ) THEN 1823 IF( ElementPermutation ) THEN 1824 Left = LocalEPerm(Left - MinEIndex + 1) 1825 END IF 1826 ELSE IF ( Left > 0 ) THEN 1827 WRITE( Message, * ) mype,'BOUNDARY PARENT out of range: ', Tag, Left 1828 CALL Error( 'ReadBoundaryFile', Message ) 1829 Left = 0 1830 END IF 1831 1832 IF ( Right >= MinEIndex .AND. Right <= MaxEIndex ) THEN 1833 IF( ElementPermutation ) THEN 1834 Right = LocalEPerm(Right - MinEIndex + 1) 1835 END IF 1836 ELSE IF ( Right > 0 ) THEN 1837 WRITE( Message, * ) mype,'BOUNDARY PARENT out of range: ', Tag,Right 1838 CALL Error( 'ReadBoundaryFile', Message ) 1839 Right = 0 1840 END IF 1841 1842 IF ( Left >= 1 ) THEN 1843 Element % BoundaryInfo % Left => Mesh % Elements(left) 1844 END IF 1845 1846 IF ( Right >= 1 ) THEN 1847 Element % BoundaryInfo % Right => Mesh % Elements(right) 1848 END IF 1849 1850 n = Element % TYPE % NumberOfNodes 1851 CALL AllocateVector( Element % NodeIndexes, n ) 1852 1853 IF( nread < 5 + n + ioffset ) THEN 1854 CALL Fatal('ReadBoundaryFile','Line '//TRIM(I2S(j))//' does not contain enough entries') 1855 END IF 1856 Element % NodeIndexes(1:n) = Ivals(6+ioffset:nread) 1857 END DO 1858 CLOSE( FileUnit ) 1859 1860 1861 IF( ElementPermutation ) THEN 1862 DEALLOCATE( LocalEPerm ) 1863 END IF 1864 1865 END SUBROUTINE ReadBoundaryFile 1866 !------------------------------------------------------------------------------ 1867 1868 1869 1870 ! Make a permutation for the bulk and boundary element topology if 1871 ! the nodes are permuted. This is always the case in parallel. 1872 ! The initial numbering is needed only when the nodes are loaded and 1873 ! hence this is a local subroutine. 1874 !---------------------------------------------------------------------- 1875 SUBROUTINE PermuteNodeNumbering() 1876 1877 TYPE(Element_t), POINTER :: Element 1878 1879 IF( NodePermutation ) THEN 1880 CALL Info('PermuteNodeNumbering','Performing node mapping',Level=6) 1881 1882 MinNodeTag = MINVAL( NodeTags ) 1883 MaxNodeTag = MAXVAL( NodeTags ) 1884 1885 CALL AllocateVector( LocalPerm, MaxNodeTag-MinNodeTag+1, 'PermuteNodeNumbering' ) 1886 LocalPerm = 0 1887 DO i=1,Mesh % NumberOfNodes 1888 LocalPerm(NodeTags(i) - MinNodeTag + 1) = i 1889 END DO 1890 1891 DO i=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 1892 Element => Mesh % Elements(i) 1893 n = Element % TYPE % NumberOfNodes 1894 1895 DO j=1,n 1896 k = Element % NodeIndexes(j) 1897 Element % NodeIndexes(j) = LocalPerm(k - MinNodeTag + 1) 1898 END DO 1899 END DO 1900 ELSE 1901 CALL Info('PermuteNodeNumbering','Node mapping is continuous',Level=8) 1902 END IF 1903 1904 ! Set the for now, if the case is truly parallel we'll have to revisit these 1905 ! when reading the parallel information. 1906 Mesh % ParallelInfo % NumberOfIfDOFs = 0 1907 Mesh % ParallelInfo % GlobalDOFs => NodeTags 1908 1909 END SUBROUTINE PermuteNodeNumbering 1910 1911 1912 ! Initialize some parallel structures once the non-nodal 1913 ! element types are known. 1914 ! Currently this is here mainly because the 1915 ! Elemental and Nodal tags are local 1916 !------------------------------------------------------- 1917 SUBROUTINE InitParallelInfo() 1918 1919 INTEGER, POINTER :: TmpGlobalDofs(:) 1920 1921 ! These two have already been set, and if the case is serial 1922 ! case they can be as is. 1923 !Mesh % ParallelInfo % NumberOfIfDOFs = 0 1924 !Mesh % ParallelInfo % GlobalDOFs => NodeTags 1925 1926 1927 ! This also for serial runs ... 1928 DO i=1,Mesh % NumberOfBulkElements 1929 Mesh % Elements(i) % GElementIndex = ElementTags(i) 1930 END DO 1931 1932 IF(.NOT. Parallel ) RETURN 1933 1934 n = Mesh % NumberOfNodes + & 1935 Mesh % MaxEdgeDOFs * Mesh % NumberOFEdges + & 1936 Mesh % MaxFaceDOFs * Mesh % NumberOFFaces + & 1937 Mesh % MaxBDOFs * Mesh % NumberOFBulkElements 1938 1939 ALLOCATE( TmpGlobalDOFs(n) ) 1940 TmpGlobalDOFs = 0 1941 TmpGlobalDOFs(1:Mesh % NumberOfNodes) = & 1942 Mesh % ParallelInfo % GlobalDOFs(1:Mesh % NumberOfNodes) 1943 DEALLOCATE( Mesh % ParallelInfo % GlobalDOFs ) 1944 Mesh % ParallelInfo % GlobalDofs => TmpGlobalDofs 1945 1946 ALLOCATE(Mesh % ParallelInfo % NeighbourList(n), STAT=istat) 1947 IF (istat /= 0) CALL Fatal('InitParallelInfo', 'Unable to allocate NeighbourList array.') 1948 1949 DO i=1,n 1950 NULLIFY( Mesh % ParallelInfo % NeighbourList(i) % Neighbours ) 1951 END DO 1952 1953 CALL AllocateVector( Mesh % ParallelInfo % INTERFACE, n, 'InitParallelInfo') 1954 Mesh % ParallelInfo % INTERFACE = .FALSE. 1955 1956 END SUBROUTINE InitParallelInfo 1957 1958 1959 ! Read the file that shows the shared nodes. 1960 !------------------------------------------------------------------------ 1961 SUBROUTINE ReadSharedFile() 1962 1963 INTEGER :: Ivals(64) 1964 INTEGER :: npart, tag, nread 1965 CHARACTER(256) :: str 1966 LOGICAL :: halo 1967 1968 IF(.NOT. Parallel) RETURN 1969 1970 FileName = BaseName(1:BaseNameLen)//& 1971 '/partitioning.'//TRIM(I2S(numprocs))//& 1972 '/part.'//TRIM(I2S(mype+1))//'.shared' 1973 1974 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', IOSTAT = iostat ) 1975 IF( iostat /= 0 ) THEN 1976 CALL Fatal('ReadSharedFile','Could not open file: '//TRIM(Filename)) 1977 ELSE 1978 CALL Info('ReadSharedFile','Reading nodes from file: '//TRIM(FileName),Level=10) 1979 END IF 1980 1981 ! This loop could be made more effective, for example 1982 ! by reading tags and nparts to a temporal vector 1983 ! The operation using the str takes much more time. 1984 !----------------------------------------------------- 1985 DO i=1,SharedNodes 1986 READ(FileUnit, '(a)', IOSTAT=iostat) str 1987 IF( iostat /= 0 ) THEN 1988 CALL Fatal('ReadSharedFile','Could not read shared nodes entry: '//TRIM(I2S(i))) 1989 END IF 1990 nread = read_ints(str,ivals,halo) 1991 1992 tag = ivals(1) 1993 npart = ivals(2) 1994 1995 k = LocalPerm( tag-MinNodeTag+1 ) 1996 Mesh % ParallelInfo % INTERFACE(k) = .TRUE. 1997 CALL AllocateVector(Mesh % ParallelInfo % NeighbourList(k) % Neighbours,npart) 1998 1999 IF( nread < 2 + npart ) THEN 2000 CALL Fatal('ReadSharedFile','Line '//TRIM(I2S(j))//' does not contain enough entries') 2001 END IF 2002 2003 Mesh % ParallelInfo % NeighbourList(k) % Neighbours = ivals(3:nread) - 1 2004 2005 ! this partition does not own the node 2006 IF ( ivals(3)-1 /= mype ) THEN 2007 Mesh % ParallelInfo % NumberOfIfDOFs = & 2008 Mesh % ParallelInfo % NumberOfIfDOFs + 1 2009 END IF 2010 END DO 2011 2012 CLOSE( FileUnit ) 2013 2014 END SUBROUTINE ReadSharedFile 2015 2016 END SUBROUTINE ElmerAsciiMesh 2017 2018 2019 2020 !> An interface over potential mesh loading strategies. 2021 !----------------------------------------------------------------- 2022 SUBROUTINE LoadMeshStep( Step, PMesh, MeshNamePar, ThisPe, NumPEs,IsParallel ) 2023 2024 IMPLICIT NONE 2025 2026 INTEGER :: Step 2027 CHARACTER(LEN=*), OPTIONAL :: MeshNamePar 2028 TYPE(Mesh_t), POINTER, OPTIONAL :: PMesh 2029 INTEGER, OPTIONAL :: ThisPe, NumPEs 2030 LOGICAL, OPTIONAL :: IsParallel 2031 2032 ! Currently only one strategy to get the mesh is implemented 2033 ! but there could be others. 2034 ! 2035 ! This has not yet been tested in parallel and for sure 2036 ! it does not work for halo elements. 2037 !----------------------------------------------------------------- 2038 CALL ElmerAsciiMesh( Step, PMesh, MeshNamePar, ThisPe, NumPEs, IsParallel ) 2039 2040 END SUBROUTINE LoadMeshStep 2041 2042 !------------------------------------------------------------------------------ 2043 ! Set the mesh dimension by studying the coordinate values. 2044 ! This could be less conservative also... 2045 !------------------------------------------------------------------------------ 2046 SUBROUTINE SetMeshDimension( Mesh ) 2047 TYPE(Mesh_t), POINTER :: Mesh 2048 2049 REAL(KIND=dp) :: x, y, z 2050 LOGICAL :: C(3) 2051 INTEGER :: i 2052 2053 IF( Mesh % NumberOfNodes == 0 ) RETURN 2054 2055 ! Compare value to some node, why not the 1st one 2056 x = Mesh % Nodes % x(1) 2057 y = Mesh % Nodes % y(1) 2058 z = Mesh % Nodes % z(1) 2059 2060 C(1) = ANY( Mesh % Nodes % x /= x ) 2061 C(2) = ANY( Mesh % Nodes % y /= y ) 2062 C(3) = ANY( Mesh % Nodes % z /= z ) 2063 2064 ! This version is perhaps too liberal 2065 Mesh % MeshDim = COUNT( C ) 2066 Mesh % MaxDim = 0 2067 DO i=1,3 2068 IF( C(i) ) Mesh % MaxDim = i 2069 END DO 2070 2071 CALL Info('SetMeshDimension','Dimension of mesh is: '//TRIM(I2S(Mesh % MeshDim)),Level=8) 2072 CALL Info('SetMeshDimension','Max dimension of mesh is: '//TRIM(I2S(Mesh % MaxDim)),Level=8) 2073 2074 END SUBROUTINE SetMeshDimension 2075 2076 2077 !------------------------------------------------------------------------------ 2078 !> Function to load mesh from disk. 2079 !------------------------------------------------------------------------------ 2080 FUNCTION LoadMesh2( Model, MeshDirPar, MeshNamePar,& 2081 BoundariesOnly, NumProcs, MyPE, Def_Dofs, mySolver, & 2082 LoadOnly ) RESULT( Mesh ) 2083 !------------------------------------------------------------------------------ 2084 USE PElementMaps, ONLY : GetRefPElementNodes 2085 2086 IMPLICIT NONE 2087 2088 CHARACTER(LEN=*) :: MeshDirPar,MeshNamePar 2089 LOGICAL :: BoundariesOnly 2090 INTEGER, OPTIONAL :: numprocs,mype,Def_Dofs(:,:), mySolver 2091 TYPE(Mesh_t), POINTER :: Mesh 2092 TYPE(Model_t) :: Model 2093 LOGICAL, OPTIONAL :: LoadOnly 2094 !------------------------------------------------------------------------------ 2095 INTEGER :: i,j,k,n 2096 INTEGER :: BaseNameLen, Save_Dim 2097 LOGICAL :: GotIt, Found, ForcePrep=.FALSE. 2098 CHARACTER(MAX_NAME_LEN) :: FileName 2099 TYPE(Element_t), POINTER :: Element 2100 TYPE(Matrix_t), POINTER :: Projector 2101 LOGICAL :: parallel, LoadNewMesh 2102 2103 2104 Mesh => Null() 2105 2106 n = LEN_TRIM(MeshNamePar) 2107 DO WHILE (MeshNamePar(n:n)==CHAR(0).OR.MeshNamePar(n:n)==' ') 2108 n=n-1 2109 END DO 2110 IF(NumProcs<=1) THEN 2111 INQUIRE( FILE=MeshNamePar(1:n)//'/mesh.header', EXIST=Found) 2112 IF(.NOT. Found ) THEN 2113 CALL Fatal('LoadMesh','Requested mesh > '//MeshNamePar(1:n)//' < does not exist!') 2114 END IF 2115 ELSE 2116 INQUIRE( FILE=MeshNamePar(1:n)//'/partitioning.'// & 2117 TRIM(i2s(Numprocs))//'/part.1.header', EXIST=Found) 2118 IF(.NOT. Found ) THEN 2119 CALL Warn('LoadMesh','Requested mesh > '//MeshNamePar(1:n)//' < in partition '& 2120 //TRIM(I2S(Numprocs))//' does not exist!') 2121 RETURN 2122 END IF 2123 END IF 2124 2125 CALL Info('LoadMesh','Starting',Level=8) 2126 2127 Parallel = .FALSE. 2128 IF ( PRESENT(numprocs) .AND. PRESENT(mype) ) THEN 2129 IF ( numprocs > 1 ) Parallel = .TRUE. 2130 END IF 2131 2132 Mesh => AllocateMesh() 2133 2134 ! Get sizes of mesh structures for allocation 2135 !-------------------------------------------------------------------- 2136 CALL LoadMeshStep( 1, Mesh, MeshNamePar, mype, numprocs, Parallel ) 2137 2138 ! Initialize and allocate mesh structures 2139 !--------------------------------------------------------------------- 2140 IF( BoundariesOnly ) Mesh % NumberOfBulkElements = 0 2141 CALL InitializeMesh( Mesh ) 2142 2143 ! Get the (x,y,z) coordinates 2144 !-------------------------------------------------------------------------- 2145 CALL LoadMeshStep( 2 ) 2146 ! Permute and scale the coordinates. 2147 ! This also finds the mesh dimension. It is needed prior to getting the 2148 ! elementtypes since wrong permutation or dimension may spoil that. 2149 !------------------------------------------------------------------- 2150 CALL MapCoordinates() 2151 2152 ! Get the bulk elements: element types, body index, topology 2153 !-------------------------------------------------------------------------- 2154 CALL LoadMeshStep( 3 ) 2155 2156 ! Get the boundary elements: boundary types, boundary index, parents, topology 2157 !------------------------------------------------------------------------------ 2158 CALL LoadMeshStep( 4 ) 2159 2160 ! Read elemental data - this is rarely used, parallel implementation lacking? 2161 !-------------------------------------------------------------------------- 2162 i = LEN_TRIM(MeshNamePar) 2163 DO WHILE(MeshNamePar(i:i) == CHAR(0)) 2164 i=i-1 2165 END DO 2166 BaseNameLen = i 2167 2168 FileName = MeshNamePar(1:BaseNameLen)//'/mesh.elements.data' 2169 CALL ReadElementPropertyFile( FileName, Mesh ) 2170 2171 ! Read mesh.names - this could be saved by some mesh formats 2172 !-------------------------------------------------------------------------- 2173 IF( ListGetLogical( Model % Simulation,'Use Mesh Names',Found ) ) THEN 2174 FileName = MeshNamePar(1:BaseNameLen)//'/mesh.names' 2175 CALL ReadTargetNames( Model, FileName ) 2176 END IF 2177 2178 2179 ! Map bodies using Target Bodies and boundaries using Target Boundaries. 2180 ! This must be done before the element definitions are studied since 2181 ! then the pointer should be to the correct body index. 2182 !------------------------------------------------------------------------ 2183 CALL MapBodiesAndBCs() 2184 2185 ! Read parallel mesh information: shared nodes 2186 !------------------------------------------------------------------ 2187 CALL LoadMeshStep( 5 ) 2188 2189 ! Create the discontinuous mesh that accounts for the jumps in BCs 2190 ! This must be created after the whole mesh has been read in and 2191 ! bodies and bcs have been mapped to full operation. 2192 ! To consider non-nodal elements it must be done before them. 2193 !-------------------------------------------------------------------- 2194 CALL CreateDiscontMesh(Model,Mesh) 2195 2196 ! Deallocate some stuff no longer needed 2197 !------------------------------------------------------------------ 2198 CALL LoadMeshStep( 6 ) 2199 2200 CALL Info('LoadMesh','Loading mesh done',Level=8) 2201 2202 ForcePrep = ListGetLogical( Model % Simulation,'Finalize Meshes Before Extrusion',Found) 2203 2204 IF( PRESENT( LoadOnly ) ) THEN 2205 IF( LoadOnly ) THEN 2206 RETURN 2207 ELSE 2208 ForcePrep = .TRUE. 2209 END IF 2210 END IF 2211 2212 ! Prepare the mesh for next steps. 2213 ! For example, create non-nodal mesh structures, periodic projectors etc. 2214 IF( (ListCheckPresent( Model % Simulation,'Extruded Mesh Levels') .OR. & 2215 ListCheckPresent( Model % Simulation,'Extruded Mesh Layers')) .AND. (.NOT. ForcePrep) ) THEN 2216 CALL Info('LoadMesh','This mesh will be extruded, skipping finalization',Level=12) 2217 RETURN 2218 END IF 2219 2220 CALL PrepareMesh(Model,Mesh,Parallel,Def_Dofs,mySolver) 2221 CALL Info('LoadMesh','Preparing mesh done',Level=8) 2222 2223 2224 CONTAINS 2225 2226 2227 !------------------------------------------------------------------------------ 2228 ! Map bodies and boundaries as prescirbed by the 'Target Bodies' and 2229 ! 'Target Boundaries' keywords. 2230 !------------------------------------------------------------------------------ 2231 SUBROUTINE MapBodiesAndBCs() 2232 2233 TYPE(Element_t), POINTER :: Element 2234 INTEGER, ALLOCATABLE :: IndexMap(:), TmpIndexMap(:) 2235 INTEGER, POINTER :: Blist(:) 2236 INTEGER :: id,minid,maxid,body,bndry,DefaultTargetBC 2237 2238 2239 ! If "target bodies" is used map the bodies accordingly 2240 !------------------------------------------------------ 2241 Found = .FALSE. 2242 DO id=1,Model % NumberOfBodies 2243 IF( ListCheckPresent( Model % Bodies(id) % Values,'Target Bodies') ) THEN 2244 Found = .TRUE. 2245 EXIT 2246 END IF 2247 END DO 2248 2249 IF( Found ) THEN 2250 CALL Info('MapBodiesAndBCs','Remapping bodies',Level=8) 2251 minid = HUGE( minid ) 2252 maxid = -HUGE( maxid ) 2253 DO i=1,Mesh % NumberOfBulkElements 2254 Element => Mesh % Elements(i) 2255 id = Element % BodyId 2256 minid = MIN( id, minid ) 2257 maxid = MAX( id, maxid ) 2258 END DO 2259 IF( minid > maxid ) THEN 2260 CALL Fatal('MapBodiesAndBCs','Body indexes are screwed!') 2261 END IF 2262 CALL Info('MapBodiesAndBCs','Minimum initial body index: '//TRIM(I2S(minid)),Level=6 ) 2263 CALL Info('MapBodiesAndBCs','Maximum initial body index: '//TRIM(I2S(maxid)),Level=6 ) 2264 2265 minid = MIN( 1, minid ) 2266 maxid = MAX( Model % NumberOfBodies, maxid ) 2267 ALLOCATE( IndexMap(minid:maxid) ) 2268 IndexMap = 0 2269 2270 DO id=1,Model % NumberOfBodies 2271 BList => ListGetIntegerArray( Model % Bodies(id) % Values, & 2272 'Target Bodies', GotIt ) 2273 IF ( Gotit ) THEN 2274 DO k=1,SIZE(BList) 2275 body = Blist(k) 2276 IF( body > maxid .OR. body < minid ) THEN 2277#if 0 2278 CALL Warn('MapBodiesAndBCs','Unused body entry in > Target Bodies < : '& 2279 //TRIM(I2S(body)) ) 2280#endif 2281 ELSE IF( IndexMap( body ) /= 0 ) THEN 2282 CALL Warn('MapBodiesAndBCs','Multiple bodies have same > Target Bodies < entry : '& 2283 //TRIM(I2S(body))) 2284 ELSE 2285 IndexMap( body ) = id 2286 END IF 2287 END DO 2288 ELSE 2289 IF( IndexMap( id ) /= 0 ) THEN 2290 CALL Warn('MapBodiesAndBCs','Unset body already set by > Target Boundaries < : '& 2291 //TRIM(I2S(id)) ) 2292 ELSE 2293 IndexMap( id ) = id 2294 END IF 2295 END IF 2296 2297 END DO 2298 2299 IF( .FALSE. ) THEN 2300 PRINT *,'Body mapping' 2301 DO id=minid,maxid 2302 IF( IndexMap( id ) /= 0 ) PRINT *,id,' : ',IndexMap(id) 2303 END DO 2304 END IF 2305 2306 DO i=1,Mesh % NumberOfBulkElements 2307 Element => Mesh % Elements(i) 2308 id = Element % BodyId 2309! IF( IndexMap( id ) == 0 ) THEN 2310! PRINT *,'Unmapped body: ',id 2311! IndexMap(id) = id 2312! END IF 2313 Element % BodyId = IndexMap( id ) 2314 END DO 2315 2316 DEALLOCATE( IndexMap ) 2317 ELSE 2318 CALL Info('MapBodiesAndBCs','Skipping remapping of bodies',Level=10) 2319 END IF 2320 2321 2322 IF( Mesh % NumberOfBoundaryElements == 0 ) RETURN 2323 2324 ! Target boundaries are usually given so this is not conditional 2325 !--------------------------------------------------------------- 2326 CALL Info('MapBodiesAndBCs','Remapping boundaries',Level=8) 2327 minid = HUGE( minid ) 2328 maxid = -HUGE( maxid ) 2329 DO i=Mesh % NumberOfBulkElements+1,& 2330 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2331 Element => Mesh % Elements(i) 2332 id = Element % BoundaryInfo % Constraint 2333 minid = MIN( id, minid ) 2334 maxid = MAX( id, maxid ) 2335 END DO 2336 2337 2338 CALL Info('MapBodiesAndBCs','Minimum initial boundary index: '//TRIM(I2S(minid)),Level=6 ) 2339 CALL Info('MapBodiesAndBCs','Maximum initial boundary index: '//TRIM(I2S(maxid)),Level=6 ) 2340 IF( minid > maxid ) THEN 2341 CALL Fatal('MapBodiesAndBCs','Boundary indexes are screwed') 2342 END IF 2343 2344 minid = MIN( minid, 1 ) 2345 maxid = MAX( maxid, Model % NumberOfBCs ) 2346 ALLOCATE( IndexMap(minid:maxid) ) 2347 IndexMap = 0 2348 2349 2350 DO j=1,Model % NumberOfBoundaries 2351 id = ListGetInteger( Model % Boundaries(j) % Values, & 2352 'Boundary Condition',GotIt, minv=1, maxv=Model % NumberOFBCs ) 2353 IF( id == 0 ) CYCLE 2354 bndry = Model % BoundaryId(j) 2355 IF( bndry > maxid ) THEN 2356 CALL Warn('MapBodiesAndBCs','BoundaryId exceeds range') 2357 ELSE IF( bndry == 0 ) THEN 2358 CALL Warn('MapBodiesAndBCs','BoundaryId is zero') 2359 ELSE 2360 IndexMap( bndry ) = id 2361 END IF 2362 END DO 2363 2364 DefaultTargetBC = 0 2365 DO id=1,Model % NumberOfBCs 2366 IF(ListGetLogical( Model % BCs(id) % Values, & 2367 'Default Target', GotIt)) DefaultTargetBC = id 2368 BList => ListGetIntegerArray( Model % BCs(id) % Values, & 2369 'Target Boundaries', GotIt ) 2370 IF ( Gotit ) THEN 2371 DO k=1,SIZE(BList) 2372 bndry = Blist(k) 2373 IF( bndry > maxid ) THEN 2374#if 0 2375 in my opinion, this is quite usual ... Juha 2376 CALL Warn('MapBodiesAndBCs','Unused BC entry in > Target Boundaries < : '& 2377 //TRIM(I2S(bndry)) ) 2378#endif 2379 ELSE IF( IndexMap( bndry ) /= 0 ) THEN 2380 CALL Warn('MapBodiesAndBCs','Multiple BCs have same > Target Boundaries < entry : '& 2381 //TRIM(I2S(bndry)) ) 2382 ELSE 2383 IndexMap( bndry ) = id 2384 END IF 2385 END DO 2386 ELSE 2387 IF (ListCheckPresent(Model % BCs(id) % Values, 'Target Nodes') .OR. & 2388 ListCheckPresent(Model % BCs(id) % Values, 'Target Coordinates')) & 2389 CYCLE 2390 IF (IndexMap( id ) /= 0 .AND. id == DefaultTargetBC ) THEN ! DefaultTarget has been given 2391 CALL Warn('MapBodiesAndBCs','Default Target is a Target Boundaries entry in > Boundary Condition < : '& 2392 //TRIM(I2S(IndexMap(id))) ) 2393 END IF 2394 ! 2395 !IF( IndexMap( id ) /= 0 .AND. id /= DefaultTargetBC ) THEN 2396 ! CALL Warn('LoadMesh','Unset BC already set by > Target Boundaries < : '& 2397 ! //TRIM(I2S(id)) ) 2398 !ELSE 2399 ! ! IndexMap( id ) = id 2400 !END IF 2401 END IF 2402 END DO 2403 2404 IF( .FALSE. ) THEN 2405 PRINT *,'Boundary mapping' 2406 DO id=minid,maxid 2407 IF( IndexMap( id ) /= 0 ) PRINT *,id,' : ',IndexMap(id) 2408 END DO 2409 END IF 2410 2411 IF( DefaultTargetBC /= 0 ) THEN 2412 CALL Info('MapBodiesAndBCs','Default Target BC: '& 2413 //TRIM(I2S(DefaultTargetBC)),Level=8) 2414 END IF 2415 2416 2417 DO i=Mesh % NumberOfBulkElements + 1, & 2418 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2419 2420 Element => Mesh % Elements(i) 2421 2422 n = Element % TYPE % NumberOfNodes 2423 bndry = Element % BoundaryInfo % Constraint 2424 2425 IF( bndry > maxid .OR. bndry < minid ) THEN 2426 CALL Warn('MapBodiesAndBCs','Boundary index '//TRIM(I2S(bndry))& 2427 //' not in range: '//TRIM(I2S(minid))//','//TRIM(I2S(maxid)) ) 2428 END IF 2429 2430 IF( IndexMap( bndry ) < 0 ) THEN 2431 Element % BoundaryInfo % Constraint = 0 2432 CYCLE 2433 2434 ELSE IF( IndexMap( bndry ) == 0 ) THEN 2435 IF( DefaultTargetBC /= 0 ) THEN 2436! PRINT *,'Default boundary map: ',bndry,DefaultTargetBC 2437 IndexMap( bndry ) = DefaultTargetBC 2438 ELSE 2439! IF( bndry <= Model % NumberOfBCs ) THEN 2440! PRINT *,'Unmapped boundary: ',bndry 2441! ELSE 2442! PRINT *,'Unused boundary: ',bndry 2443! END IF 2444 IndexMap( bndry ) = -1 2445 Element % BoundaryInfo % Constraint = 0 2446 CYCLE 2447 END IF 2448 END IF 2449 2450 bndry = IndexMap( bndry ) 2451 Element % BoundaryInfo % Constraint = bndry 2452 2453 IF( bndry <= Model % NumberOfBCs ) THEN 2454 Element % BodyId = ListGetInteger( & 2455 Model % BCs(bndry) % Values, 'Body Id', Gotit, 1, Model % NumberOfBodies ) 2456 Element % BoundaryInfo % OutBody = & 2457 ListGetInteger( Model % BCs(bndry) % Values, & 2458 'Normal Target Body', GotIt, maxv=Model % NumberOFBodies ) 2459 END IF 2460 END DO 2461 2462 DEALLOCATE( IndexMap ) 2463 2464 END SUBROUTINE MapBodiesAndBCs 2465 2466 2467 2468 !------------------------------------------------------------------------------ 2469 ! Map and scale coordinates, and increase the size of the coordinate 2470 ! vectors, if requested. 2471 !------------------------------------------------------------------------------ 2472 SUBROUTINE MapCoordinates() 2473 2474 REAL(KIND=dp), POINTER CONTIG :: NodesX(:), NodesY(:), NodesZ(:) 2475 REAL(KIND=dp), POINTER :: Wrk(:,:) 2476 INTEGER, POINTER :: CoordMap(:) 2477 REAL(KIND=dp) :: CoordScale(3) 2478 INTEGER :: mesh_dim, model_dim 2479 2480 ! Perform coordinate mapping 2481 !------------------------------------------------------------ 2482 CoordMap => ListGetIntegerArray( Model % Simulation, & 2483 'Coordinate Mapping',GotIt ) 2484 IF ( GotIt ) THEN 2485 CALL Info('MapCoordinates','Performing coordinate mapping',Level=8) 2486 2487 IF ( SIZE( CoordMap ) /= 3 ) THEN 2488 WRITE( Message, * ) 'Inconsistent Coordinate Mapping: ', CoordMap 2489 CALL Error( 'MapCoordinates', Message ) 2490 WRITE( Message, * ) 'Coordinate mapping should be a permutation of 1,2 and 3' 2491 CALL Fatal( 'MapCoordinates', Message ) 2492 END IF 2493 2494 IF ( ALL( CoordMap(1:3) /= 1 ) .OR. ALL( CoordMap(1:3) /= 2 ) .OR. ALL( CoordMap(1:3) /= 3 ) ) THEN 2495 WRITE( Message, * ) 'Inconsistent Coordinate Mapping: ', CoordMap 2496 CALL Error( 'MapCoordinates', Message ) 2497 WRITE( Message, * ) 'Coordinate mapping should be a permutation of 1,2 and 3' 2498 CALL Fatal( 'MapCoordinates', Message ) 2499 END IF 2500 2501 IF( CoordMap(1) == 1 ) THEN 2502 NodesX => Mesh % Nodes % x 2503 ELSE IF( CoordMap(1) == 2 ) THEN 2504 NodesX => Mesh % Nodes % y 2505 ELSE 2506 NodesX => Mesh % Nodes % z 2507 END IF 2508 2509 IF( CoordMap(2) == 1 ) THEN 2510 NodesY => Mesh % Nodes % x 2511 ELSE IF( CoordMap(2) == 2 ) THEN 2512 NodesY => Mesh % Nodes % y 2513 ELSE 2514 NodesY => Mesh % Nodes % z 2515 END IF 2516 2517 IF( CoordMap(3) == 1 ) THEN 2518 NodesZ => Mesh % Nodes % x 2519 ELSE IF( CoordMap(3) == 2 ) THEN 2520 NodesZ => Mesh % Nodes % y 2521 ELSE 2522 NodesZ => Mesh % Nodes % z 2523 END IF 2524 2525 Mesh % Nodes % x => NodesX 2526 Mesh % Nodes % y => NodesY 2527 Mesh % Nodes % z => NodesZ 2528 END IF 2529 2530 ! Determine the mesh dimension 2531 !---------------------------------------------------------------------------- 2532 CALL SetMeshDimension( Mesh ) 2533 2534 mesh_dim = Mesh % MaxDim 2535 2536 ! Scaling of coordinates 2537 !----------------------------------------------------------------------------- 2538 Wrk => ListGetConstRealArray( Model % Simulation,'Coordinate Scaling',GotIt ) 2539 IF( GotIt ) THEN 2540 CoordScale = 1.0_dp 2541 DO i=1,mesh_dim 2542 j = MIN( i, SIZE(Wrk,1) ) 2543 CoordScale(i) = Wrk(j,1) 2544 END DO 2545 WRITE(Message,'(A,3ES10.3)') 'Scaling coordinates:',CoordScale(1:3) 2546 CALL Info('MapCoordinates',Message) 2547 Mesh % Nodes % x = CoordScale(1) * Mesh % Nodes % x 2548 IF( mesh_dim > 1 ) Mesh % Nodes % y = CoordScale(2) * Mesh % Nodes % y 2549 IF( mesh_dim > 2 ) Mesh % Nodes % z = CoordScale(3) * Mesh % Nodes % z 2550 END IF 2551 2552 END SUBROUTINE MapCoordinates 2553 2554 !------------------------------------------------------------------------------ 2555 END FUNCTION LoadMesh2 2556 !------------------------------------------------------------------------------ 2557 2558 2559 !> Prepare a clean nodal mesh as it comes after being loaded from disk. 2560 !> Study the non-nodal elements (face, edge, DG, and p-elements) 2561 !> Create parallel info for the non-nodal elements 2562 !> Enlarge the coordinate vectors for p-elements. 2563 !> Generate static projector for periodic BCS. 2564 !------------------------------------------------------------------- 2565 SUBROUTINE PrepareMesh( Model, Mesh, Parallel, Def_Dofs, mySolver ) 2566 2567 TYPE(Model_t) :: Model 2568 TYPE(Mesh_t), POINTER :: Mesh 2569 LOGICAL :: Parallel 2570 INTEGER, OPTIONAL :: Def_Dofs(:,:), mySolver 2571 LOGICAL :: Found 2572 2573 2574 2575 IF( Mesh % MaxDim == 0) THEN 2576 CALL SetMeshDimension( Mesh ) 2577 END IF 2578 Model % DIMENSION = MAX( Model % DIMENSION, Mesh % MaxDim ) 2579 2580 CALL NonNodalElements() 2581 2582 IF( Parallel ) THEN 2583 CALL ParallelNonNodalElements() 2584 END IF 2585 2586 CALL EnlargeCoordinates( Mesh ) 2587 2588 CALL GeneratePeriodicProjectors( Model, Mesh ) 2589 2590 IF( ListGetLogical( Model % Simulation,'Inspect Quadratic Mesh', Found ) ) THEN 2591 CALL InspectQuadraticMesh( Mesh ) 2592 END IF 2593 2594 IF( ListGetLogical( Model % Simulation,'Inspect Mesh',Found ) ) THEN 2595 CALL InspectMesh( Mesh ) 2596 END IF 2597 2598 IF(ListGetLogical( Model % Simulation, 'Parallel Reduce Element Max Sizes', Found ) ) THEN 2599 Mesh % MaxElementDOFs = NINT( ParallelReduction( 1.0_dp*Mesh % MaxElementDOFs,2 ) ) 2600 Mesh % MaxElementNodes = NINT( ParallelReduction( 1.0_dp*Mesh % MaxElementNodes,2 ) ) 2601 END IF 2602 2603 2604 CONTAINS 2605 2606 2607 ! Check for the non-nodal element basis 2608 !-------------------------------------------------------- 2609 SUBROUTINE NonNodalElements() 2610 2611 INTEGER, POINTER :: EdgeDofs(:), FaceDofs(:) 2612 INTEGER :: i, j, k, l, s, n, DGIndex, body_id, body_id0, eq_id, solver_id, el_id, & 2613 mat_id 2614 LOGICAL :: NeedEdges, Found, FoundDef0, FoundDef, FoundEq, GotIt, MeshDeps, & 2615 FoundEqDefs, FoundSolverDefs(Model % NumberOfSolvers), & 2616 FirstOrderElements, InheritDG, Hit, Stat 2617 TYPE(Element_t), POINTER :: Element, Parent, pParent 2618 TYPE(Element_t) :: DummyElement 2619 TYPE(ValueList_t), POINTER :: Vlist 2620 INTEGER :: inDOFs(10,6) 2621 CHARACTER(MAX_NAME_LEN) :: ElementDef0, ElementDef 2622 2623 2624 EdgeDOFs => NULL() 2625 CALL AllocateVector( EdgeDOFs, Mesh % NumberOfBulkElements, 'LoadMesh' ) 2626 FaceDOFs => NULL() 2627 CALL AllocateVector( FaceDOFs, Mesh % NumberOfBulkElements, 'LoadMesh' ) 2628 2629 DGIndex = 0 2630 NeedEdges = .FALSE. 2631 2632 InDofs = 0 2633 InDofs(:,1) = 1 2634 IF ( PRESENT(Def_Dofs) ) THEN 2635 inDofs = Def_Dofs 2636 ELSE 2637 DO s=1,Model % NumberOfSolvers 2638 DO i=1,6 2639 DO j=1,8 2640 inDofs(j,i) = MAX(Indofs(j,i),MAXVAL(Model % Solvers(s) % Def_Dofs(j,:,i))) 2641 END DO 2642 END DO 2643 END DO 2644 END IF 2645 2646 ! P-basis only over 1st order elements: 2647 ! ------------------------------------- 2648 FirstOrderElements = .TRUE. 2649 DO i=1,Mesh % NumberOfBulkElements 2650 IF (Mesh % Elements(i) % Type % BasisFunctionDegree>1) THEN 2651 FirstOrderElements = .FALSE.; EXIT 2652 END IF 2653 END DO 2654 2655 ! 2656 ! Check whether the "Element" definitions can depend on mesh 2657 ! ----------------------------------------------------------- 2658 MeshDeps = .FALSE.; FoundEqDefs = .FALSE.; FoundSolverDefs = .FALSE. 2659 2660 ! 2661 ! As a preliminary step, check if an element definition is given 2662 ! an equation section. The more common way is give the element 2663 ! definition in a solver section. 2664 ! 2665 DO eq_id=1,Model % NumberOFEquations 2666 Vlist => Model % Equations(eq_id) % Values 2667 ElementDef0 = ListGetString(Vlist,'Element',FoundDef0) 2668 FoundEqDefs = FoundEqDefs .OR. FoundDef0 2669 2670 IF (FoundDef0) THEN 2671 ! 2672 ! Check if the order of p-basis is defined by calling a special 2673 ! MATC function: 2674 ! 2675 j = INDEX(ElementDef0,'p:') 2676 IF (j>0.AND. ElementDef0(j+2:j+2)=='%') MeshDeps = .TRUE. 2677 ELSE 2678 ! 2679 ! Check if element definitions are given for each solver separately 2680 ! by using a special keyword construct and tag the corresponding 2681 ! entries in the list of the solvers. This was thought to serve 2682 ! the definition of bodywise p-orders, but it seems this doesn't 2683 ! work really. TO DO: REPAIR OR REMOVE 2684 ! 2685 DO Solver_id=1,Model % NumberOfSolvers 2686 IF (PRESENT(mySolver)) THEN 2687 IF ( Solver_id /= mySolver ) CYCLE 2688 ELSE 2689 IF (ListCheckPresent(Model % Solvers(Solver_id) % Values, 'Mesh')) CYCLE 2690 END IF 2691 2692 ElementDef = ListGetString(Vlist,'Element{'//TRIM(i2s(solver_id))//'}',FoundDef) 2693 FoundSolverDefs(Solver_id) = FoundSolverDefs(solver_id) .OR. FoundDef 2694 2695 j = INDEX(ElementDef,'p:') 2696 IF (j>0.AND. ElementDef0(j+2:j+2)=='%') MeshDeps = .TRUE. 2697 END DO 2698 END IF 2699 END DO 2700 2701 ! 2702 ! Tag solvers for which the element definition has been given in 2703 ! a solver section: 2704 ! 2705 DO solver_id=1,Model % NumberOFSolvers 2706 Vlist => Model % Solvers(solver_id) % Values 2707 2708 ElementDef0 = ListGetString(Vlist,'Element',FoundDef0) 2709 FoundSolverDefs(Solver_id) = FoundSolverDefs(solver_id) .OR. FoundDef0 2710 2711 j = INDEX(ElementDef0,'p:') 2712 IF (j>0.AND. ElementDef0(j+2:j+2)=='%') meshdeps = .TRUE. 2713 END DO 2714 2715 ! The basic case without the order of p-basis being defined by a MATC function: 2716 ! 2717 IF (.NOT.MeshDeps) THEN 2718 ElementDef = ' ' 2719 FoundDef0 = .FALSE. 2720 DO body_id=1,Model % NumberOfBodies 2721 ElementDef0 = ' ' 2722 Vlist => Model % Bodies(body_id) % Values 2723 eq_id = ListGetInteger(Vlist,'Equation',FoundEq) 2724 IF( FoundEq ) THEN 2725 Vlist => Model % Equations(eq_id) % Values 2726 IF(FoundEqDefs) ElementDef0 = ListGetString(Vlist,'Element',FoundDef0 ) 2727 2728 DO solver_id=1,Model % NumberOfSolvers 2729 2730 IF(PRESENT(mySolver)) THEN 2731 IF ( Solver_id /= mySolver ) CYCLE 2732 ELSE 2733 IF (ListCheckPresent(Model % Solvers(Solver_id) % Values, 'Mesh')) CYCLE 2734 END IF 2735 2736 FoundDef = .FALSE. 2737 IF(FoundSolverDefs(solver_id)) & 2738 ElementDef = ListGetString(Vlist,'Element{'//TRIM(i2s(solver_id))//'}',FoundDef) 2739 2740 IF ( FoundDef ) THEN 2741 CALL GetMaxDefs( Model, Mesh, DummyElement, ElementDef, solver_id, body_id, Indofs ) 2742 ELSE 2743 IF(.NOT. FoundDef0.AND.FoundSolverDefs(Solver_id)) & 2744 ElementDef0 = ListGetString(Model % Solvers(solver_id) % Values,'Element',GotIt) 2745 2746 CALL GetMaxDefs( Model, Mesh, DummyElement, ElementDef0, solver_id, body_id, Indofs ) 2747 2748 IF(.NOT. FoundDef0.AND.FoundSolverDefs(Solver_id)) ElementDef0 = ' ' 2749 END IF 2750 END DO 2751 END IF 2752 END DO 2753 END IF 2754 2755 ! non-nodal elements in bulk elements 2756 !------------------------------------------------------------ 2757 body_id0 = -1; FoundDef=.FALSE.; FoundEq=.FALSE. 2758 ElementDef = ' ' 2759 2760 DO i=1,Mesh % NumberOfBulkElements 2761 Element => Mesh % Elements(i) 2762 2763 body_id = Element % BodyId 2764 n = Element % TYPE % NumberOfNodes 2765 2766 ! Check the Solver specific element types 2767 IF( Meshdeps ) THEN 2768 IF ( body_id/=body_id0 ) THEN 2769 Vlist => Model % Bodies(body_id) % Values 2770 eq_id = ListGetInteger(Vlist,'Equation',FoundEq) 2771 END IF 2772 2773 ElementDef0 = ' ' 2774 IF( FoundEq ) THEN 2775 Vlist => Model % Equations(eq_id) % Values 2776 FoundDef0 = .FALSE. 2777 IF( FoundEqDefs.AND.body_id/=body_id0 ) ElementDef0 = ListGetString(Vlist,'Element',FoundDef0 ) 2778 2779 DO solver_id=1,Model % NumberOfSolvers 2780 IF(PRESENT(mySolver)) THEN 2781 IF ( Solver_id /= mySolver ) CYCLE 2782 ELSE 2783 IF (ListCheckPresent(Model % Solvers(Solver_id) % Values, 'Mesh')) CYCLE 2784 END IF 2785 2786 FoundDef = .FALSE. 2787 IF (FoundSolverDefs(solver_id)) & 2788 ElementDef = ListGetString(Vlist,'Element{'//TRIM(i2s(solver_id))//'}',FoundDef) 2789 2790 IF ( FoundDef ) THEN 2791 CALL GetMaxDefs( Model, Mesh, Element, ElementDef, solver_id, body_id, Indofs ) 2792 ELSE 2793 IF(.NOT. FoundDef0.AND.FoundSolverDefs(solver_id)) & 2794 ElementDef0 = ListGetString(Model % Solvers(solver_id) % Values,'Element',GotIt) 2795 2796 CALL GetMaxDefs( Model, Mesh, Element, ElementDef0, solver_id, body_id, Indofs ) 2797 2798 IF(.NOT. FoundDef0.AND.FoundSolverDefs(Solver_id)) ElementDef0 = ' ' 2799 END IF 2800 END DO 2801 END IF 2802 body_id0 = body_id 2803 END IF 2804 2805 2806 el_id = Element % TYPE % ElementCode / 100 2807 2808 ! Apply the elementtypes 2809 IF ( inDOFs(el_id,1) /= 0 ) THEN 2810 Element % NDOFs = n 2811 ELSE 2812 Element % NDOFs = 0 2813 END IF 2814 2815 EdgeDOFs(i) = MAX(0,inDOFs(el_id,2)) 2816 FaceDOFs(i) = MAX(0,inDOFs(el_id,3)) 2817 2818 IF ( inDofs(el_id,4) == 0 ) THEN 2819 inDOFs(el_id,4) = n 2820 END IF 2821 2822 NULLIFY( Element % DGIndexes ) 2823 IF ( inDOFs(el_id,4) > 0 ) THEN 2824 CALL AllocateVector( Element % DGIndexes, inDOFs(el_id,4)) 2825 DO j=1,inDOFs(el_id,4) 2826 DGIndex = DGIndex + 1 2827 Element % DGIndexes(j) = DGIndex 2828 END DO 2829 ELSE 2830 NULLIFY( Element % DGIndexes ) 2831 END IF 2832 Element % DGDOFs = MAX(0,inDOFs(el_id,4)) 2833 NeedEdges = NeedEdges .OR. ANY( inDOFs(el_id,2:4)>0 ) 2834 2835 ! Check if given element is a p element 2836 IF (FirstOrderElements .AND. inDOFs(el_id,6) > 0) THEN 2837 CALL AllocatePDefinitions(Element) 2838 NeedEdges = .TRUE. 2839 2840 ! Calculate element bubble dofs and set element p 2841 Element % PDefs % P = inDOFs(el_id,6) 2842 IF ( inDOFs(el_id,5) > 0 ) THEN 2843 Element % BDOFs = inDOFs(el_id,5) 2844 ELSE 2845 Element % BDOFs = getBubbleDOFs(Element, Element % PDefs % P) 2846 END IF 2847 2848 ! All elements in actual mesh are not edges 2849 Element % PDefs % pyramidQuadEdge = .FALSE. 2850 Element % PDefs % isEdge = .FALSE. 2851 2852 ! If element is of type tetrahedron and is a p element, 2853 ! do the Ainsworth & Coyle trick 2854 IF (Element % TYPE % ElementCode == 504) CALL ConvertToACTetra(Element) 2855 CALL GetRefPElementNodes( Element % Type, Element % Type % NodeU, & 2856 Element % Type % NodeV, Element % Type % NodeW ) 2857 ELSE 2858 ! Clear P element definitions and set manual bubbles 2859 Element % PDefs => NULL() 2860 Element % BDOFs = MAX(0,inDOFs(el_id,5)) 2861 ! WRITE (*,*) Element % BDOFs 2862 END IF 2863 2864 Mesh % MaxElementNodes = MAX( & 2865 Mesh % MaxElementNodes,Element % TYPE % NumberOfNodes ) 2866 END DO 2867 2868 InheritDG = .FALSE. 2869 IF( dgindex > 0 ) THEN 2870 InheritDG = ListCheckPresentAnyMaterial( CurrentModel,'DG Parent Material') 2871 END IF 2872 2873 ! non-nodal elements in boundary elements 2874 !------------------------------------------------------------ 2875 DO i = Mesh % NumberOfBulkElements + 1, & 2876 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2877 2878 Element => Mesh % Elements(i) 2879 2880 IF(.NOT. ASSOCIATED( Element ) ) THEN 2881 CALL Fatal('NonNodalElements','Element '//TRIM(I2S(i))//' not associated!') 2882 END IF 2883 2884 IF(.NOT. ASSOCIATED( Element % TYPE ) ) THEN 2885 CALL Fatal('NonNodalElements','Type in Element '//TRIM(I2S(i))//' not associated!') 2886 END IF 2887 2888 n = Element % TYPE % NumberOfNodes 2889 Element % NDOFs = n 2890 el_id = ELement % TYPE % ElementCode / 100 2891 2892 IF ( ASSOCIATED(Element % BoundaryInfo % Left) ) THEN 2893 IF( Element % BoundaryInfo % Left % NDOFs == 0 ) THEN 2894 Element % NDOFs = 0 2895 END IF 2896 2897 IF ( Element % TYPE % DIMENSION == 1 ) THEN 2898 Element % BDOFs = & 2899 EdgeDOFs(Element % BoundaryInfo % Left % ElementIndex) 2900 ELSE 2901 Element % BDOFs = FaceDOFs(Element % BoundaryInfo % Left % ElementIndex) 2902 Element % BDOFs = MAX(Element % BDOFs, MAX(0,InDOFs(el_id+6,5))) 2903 END IF 2904 END IF 2905 2906 IF ( ASSOCIATED(Element % BoundaryInfo % Right) ) THEN 2907 IF ( Element % BoundaryInfo % Right % NDOFs == 0 ) THEN 2908 Element % NDOFs = 0 2909 END IF 2910 2911 IF ( Element % TYPE % DIMENSION == 1 ) THEN 2912 Element % BDOFs = & 2913 EdgeDOFs(Element % BoundaryInfo % Right % ElementIndex) 2914 ELSE 2915 Element % BDOFs = FaceDOFs(Element % BoundaryInfo % Right % ElementIndex) 2916 Element % BDOFs = MAX(Element % BDOFs, MAX(0,InDOFs(el_id+6,5))) 2917 END IF 2918 END IF 2919 2920 ! Optionally also set DG indexes for BCs 2921 ! It is easy for outside boundaries, but for internal boundaries 2922 ! we need a flag "DG Parent Material". 2923 IF( InheritDG ) THEN 2924 IF(.NOT. ASSOCIATED( Element % DGIndexes ) ) THEN 2925 ALLOCATE( Element % DGIndexes(n) ) 2926 Element % DGIndexes = 0 2927 END IF 2928 2929 Hit = .TRUE. 2930 k = 0 2931 DO l=1,2 2932 IF(l==1) THEN 2933 Parent => Element % BoundaryInfo % Left 2934 ELSE 2935 Parent => Element % BoundaryInfo % Right 2936 END IF 2937 IF(.NOT. ASSOCIATED( Parent ) ) CYCLE 2938 k = k + 1 2939 pParent => Parent 2940 2941 mat_id = ListGetInteger( CurrentModel % Bodies(Parent % BodyId) % Values,& 2942 'Material',Found ) 2943 IF(mat_id > 0 ) THEN 2944 VList => CurrentModel % Materials(mat_id) % Values 2945 END IF 2946 IF( ASSOCIATED(Vlist) ) THEN 2947 Hit = ListGetLogical(Vlist,'DG Parent Material',Found ) 2948 END IF 2949 IF( Hit ) EXIT 2950 END DO 2951 2952 IF( k == 0 ) THEN 2953 CALL Fatal('NonnodalElements','Cannot define DG indexes for BC!') 2954 ELSE IF( k == 1 ) THEN 2955 Parent => pParent 2956 ELSE IF(.NOT. Hit ) THEN 2957 CALL Fatal('NonnodalElements','Cannot define DG indexes for internal BC!') 2958 END IF 2959 2960 DO l=1,n 2961 DO j=1, Parent % TYPE % NumberOfNodes 2962 IF( Element % NodeIndexes(l) == Parent % NodeIndexes(j) ) THEN 2963 Element % DGIndexes(l) = Parent % DGIndexes(j) 2964 EXIT 2965 END IF 2966 END DO 2967 END DO 2968 END IF 2969 2970 END DO 2971 2972 IF ( Mesh % MaxElementDOFs <= 0 ) Mesh % MaxElementDOFs = Mesh % MaxElementNodes 2973 2974 ! Override automated "NeedEdges" if requested by the user. 2975 !------------------------------------------------------------------------------------ 2976 IF(PRESENT(mySolver)) THEN 2977 Stat = ListGetLogical(Model % Solvers(mySolver) % Values, 'Need Edges', Found) 2978 IF(Found) NeedEdges = Stat 2979 2980 IF( ListGetLogical(Model % Solvers(mySolver) % Values, 'NeedEdges', Found) ) THEN 2981 IF(.NOT. NeedEdges) CALL Fatal('NonNodalElements','Use "Need Edges" instead of "NeedEdges"') 2982 END IF 2983 END IF 2984 2985 IF( Mesh % MeshDim == 2 ) THEN 2986 Stat = ListGetLogical(Model % Simulation, 'Need Edges 2D', Found) 2987 IF(Found) NeedEdges = Stat 2988 END IF 2989 2990 IF( Mesh % MeshDim == 3 ) THEN 2991 Stat = ListGetLogical(Model % Simulation, 'Need Edges 3D', Found) 2992 IF(Found) NeedEdges = Stat 2993 END IF 2994 2995 IF ( NeedEdges ) THEN 2996 CALL Info('NonNodalElements','Requested elements require creation of edges',Level=8) 2997 CALL SetMeshEdgeFaceDOFs(Mesh,EdgeDOFs,FaceDOFs,inDOFs) 2998 END IF 2999 3000 CALL SetMeshMaxDOFs(Mesh) 3001 3002 IF( ASSOCIATED(EdgeDOFs) ) DEALLOCATE(EdgeDOFs ) 3003 IF( ASSOCIATED(FaceDOFs) ) DEALLOCATE(FaceDOFs) 3004 3005 END SUBROUTINE NonNodalElements 3006 3007 3008 ! When the parallel nodal neighbours have been found 3009 ! perform numbering for face and edge elements as well. 3010 !------------------------------------------------------------------- 3011 SUBROUTINE ParallelNonNodalElements() 3012 3013 INTEGER :: i,n,mype 3014 TYPE(Element_t), POINTER :: Element 3015 3016 !IF(.NOT. Parallel ) RETURN 3017 3018 n = SIZE( Mesh % ParallelInfo % NeighbourList ) 3019 mype = ParEnv % Mype 3020 3021 3022 ! For unset neighbours just set the this partition to be the only owner 3023 DO i=1,n 3024 IF (.NOT.ASSOCIATED(Mesh % ParallelInfo % NeighbourList(i) % Neighbours)) THEN 3025 CALL AllocateVector(Mesh % ParallelInfo % NeighbourList(i) % Neighbours,1) 3026 Mesh % ParallelInfo % NeighbourList(i) % Neighbours(1) = mype 3027 END IF 3028 END DO 3029 3030 ! Create parallel numbering of faces 3031 CALL SParFaceNumbering(Mesh, .TRUE. ) 3032 3033 DO i=1,Mesh % NumberOfFaces 3034 Mesh % MinFaceDOFs = MIN(Mesh % MinFaceDOFs,Mesh % Faces(i) % BDOFs) 3035 Mesh % MaxFaceDOFs = MAX(Mesh % MaxFaceDOFs,Mesh % Faces(i) % BDOFs) 3036 END DO 3037 IF(Mesh % MinFaceDOFs > Mesh % MaxFaceDOFs) Mesh % MinFaceDOFs = Mesh % MaxFaceDOFs 3038 3039 ! Create parallel numbering for edges 3040 CALL SParEdgeNumbering(Mesh, .TRUE.) 3041 3042 DO i=1,Mesh % NumberOfEdges 3043 Mesh % MinEdgeDOFs = MIN(Mesh % MinEdgeDOFs,Mesh % Edges(i) % BDOFs) 3044 Mesh % MaxEdgeDOFs = MAX(Mesh % MaxEdgeDOFs,Mesh % Edges(i) % BDOFs) 3045 END DO 3046 IF(Mesh % MinEdgeDOFs > Mesh % MaxEdgeDOFs) Mesh % MinEdgeDOFs = Mesh % MaxEdgeDOFs 3047 3048 ! Set max element dofs here (because element size may have changed 3049 ! when edges and faces have been set). This is the absolute worst case. 3050 ! Element which has MaxElementDOFs may not even be present as a 3051 ! real element 3052 DO i=1,Mesh % NumberOfBulkElements 3053 Element => Mesh % Elements(i) 3054 Mesh % MaxElementDOFs = MAX( Mesh % MaxElementDOFs, & 3055 Element % TYPE % NumberOfNodes + & 3056 Element % TYPE % NumberOfEdges * Mesh % MaxEdgeDOFs + & 3057 Element % TYPE % NumberOfFaces * Mesh % MaxFaceDOFs + & 3058 Element % BDOFs, & 3059 Element % DGDOFs ) 3060 END DO 3061 3062 3063 END SUBROUTINE ParallelNonNodalElements 3064 3065 3066 END SUBROUTINE PrepareMesh 3067 3068 3069 3070 SUBROUTINE InspectMesh(Mesh) 3071 3072 TYPE(Mesh_t), POINTER :: Mesh 3073 INTEGER :: i,j,mini,maxi 3074 INTEGER, POINTER :: Indexes(:) 3075 INTEGER, ALLOCATABLE :: ActiveCount(:) 3076 3077 PRINT *,'Inspecting mesh for ranges and correctness' 3078 3079 PRINT *,'No bulk elements:',Mesh % NumberOfBulkElements 3080 PRINT *,'No boundary elements:',Mesh % NumberOfBoundaryElements 3081 PRINT *,'No nodes:',Mesh % NumberOfNodes 3082 3083 PRINT *,'Range:' 3084 PRINT *,'X:',MINVAL( Mesh % Nodes % x ), MAXVAL( Mesh % Nodes % x ) 3085 PRINT *,'Y:',MINVAL( Mesh % Nodes % y ), MAXVAL( Mesh % Nodes % y ) 3086 PRINT *,'Z:',MINVAL( Mesh % Nodes % z ), MAXVAL( Mesh % Nodes % z ) 3087 3088 ALLOCATE( ActiveCount( Mesh % NumberOfNodes ) ) 3089 3090 mini = HUGE(mini) 3091 maxi = 0 3092 ActiveCount = 0 3093 DO i=1,Mesh % NumberOfBulkElements 3094 Indexes => Mesh % Elements(i) % NodeIndexes 3095 mini = MIN(mini, MINVAL( Indexes ) ) 3096 maxi = MAX(maxi, MAXVAL( Indexes ) ) 3097 ActiveCount(Indexes) = ActiveCount(Indexes) + 1 3098 END DO 3099 PRINT *,'Bulk index range: ',mini,maxi 3100 PRINT *,'Bulk nodes:',COUNT(ActiveCount > 0 ) 3101 PRINT *,'Bulk index count: ',MINVAL(ActiveCount),MAXVAL(ActiveCount) 3102 3103 mini = HUGE(mini) 3104 maxi = 0 3105 ActiveCount = 0 3106 DO i=Mesh % NumberOfBulkElements+1, & 3107 Mesh % NumberOfBulkElements+Mesh % NumberOfBoundaryElements 3108 Indexes => Mesh % Elements(i) % NodeIndexes 3109 mini = MIN(mini, MINVAL( Indexes ) ) 3110 maxi = MAX(maxi, MAXVAL( Indexes ) ) 3111 ActiveCount(Indexes) = ActiveCount(Indexes) + 1 3112 END DO 3113 PRINT *,'Boundary index range: ',mini,maxi 3114 PRINT *,'Boundary nodes: ',COUNT(ActiveCount > 0) 3115 PRINT *,'Boundary index count: ',MINVAL(ActiveCount),MAXVAL(ActiveCount) 3116 3117 DEALLOCATE( ActiveCount ) 3118 3119 PRINT *,'Done inspecting mesh' 3120 3121 END SUBROUTINE InspectMesh 3122 3123 3124 3125!------------------------------------------------------------------------------ 3126 SUBROUTINE SetMeshEdgeFaceDOFs(Mesh,EdgeDOFs,FaceDOFs,inDOFs,NeedEdges) 3127!------------------------------------------------------------------------------ 3128 INTEGER, OPTIONAL :: EdgeDOFs(:), FaceDOFs(:) 3129 TYPE(Mesh_t) :: Mesh 3130 INTEGER, OPTIONAL :: indofs(:,:) 3131 LOGICAL, OPTIONAL :: NeedEdges 3132!------------------------------------------------------------------------------ 3133 INTEGER :: i,j,el_id 3134 TYPE(Element_t), POINTER :: Element, Edge, Face 3135 LOGICAL :: AssignEdges 3136!------------------------------------------------------------------------------ 3137 3138 CALL FindMeshEdges(Mesh) 3139 3140 AssignEdges = .FALSE. 3141 IF (PRESENT(NeedEdges)) AssignEdges = NeedEdges 3142 3143 ! Set edge and face polynomial degree and degrees of freedom for 3144 ! all elements 3145 DO i=1,Mesh % NumberOFBulkElements 3146 Element => Mesh % Elements(i) 3147 3148 ! Iterate each edge of element 3149 DO j = 1,Element % TYPE % NumberOfEdges 3150 Edge => Mesh % Edges( Element % EdgeIndexes(j) ) 3151 3152 ! Set attributes of p element edges 3153 IF ( ASSOCIATED(Element % PDefs) ) THEN 3154 ! Set edge polynomial degree and dofs 3155 Edge % PDefs % P = MAX( Element % PDefs % P, Edge % PDefs % P) 3156 Edge % BDOFs = MAX(Edge % BDOFs, Edge % PDefs % P - 1) 3157 Edge % PDefs % isEdge = .TRUE. 3158 ! Get gauss points for edge. If no dofs 2 gauss points are 3159 ! still needed for integration of linear equation! 3160 Edge % PDefs % GaussPoints = (Edge % BDOFs+2)**Edge % TYPE % DIMENSION 3161 3162 IF (ASSOCIATED(Edge % BoundaryInfo % Left) ) THEN 3163 CALL AssignLocalNumber(Edge, Edge % BoundaryInfo % Left, Mesh) 3164 ELSE 3165 CALL AssignLocalNumber(Edge, Edge % BoundaryInfo % Right, Mesh) 3166 END IF 3167 3168 ! Other element types, which need edge dofs 3169 ELSE IF(PRESENT(EdgeDOFs)) THEN 3170 Edge % BDOFs = MAX(EdgeDOFs(i), Edge % BDOFs) 3171 ELSE 3172 Edge % BDOFs = Max(1, Edge % BDOFs) 3173 END IF 3174 3175 ! Get maximum dof for edges 3176 Mesh % MinEdgeDOFs = MIN(Edge % BDOFs, Mesh % MinEdgeDOFs) 3177 Mesh % MaxEdgeDOFs = MAX(Edge % BDOFs, Mesh % MaxEdgeDOFs) 3178 END DO 3179 IF ( Mesh % MinEdgeDOFs > Mesh % MaxEdgeDOFs ) Mesh % MinEdgeDOFs = MEsh % MaxEdgeDOFs 3180 3181 ! Iterate each face of element 3182 DO j=1,Element % TYPE % NumberOfFaces 3183 Face => Mesh % Faces( Element % FaceIndexes(j) ) 3184 3185 ! Set attributes of p element faces 3186 IF ( ASSOCIATED(Element % PDefs) ) THEN 3187 ! Set face polynomial degree and dofs 3188 Face % PDefs % P = MAX(Element % PDefs % P, Face % PDefs % P) 3189 ! Get number of face dofs 3190 Face % BDOFs = MAX( Face % BDOFs, getFaceDOFs(Element, Face % PDefs % P, j) ) 3191 Face % PDefs % isEdge = .TRUE. 3192 Face % PDefs % GaussPoints = getNumberOfGaussPointsFace( Face, Mesh ) 3193 IF (ASSOCIATED(Face % BoundaryInfo % Left) ) THEN 3194 CALL AssignLocalNumber(Face, Face % BoundaryInfo % Left, Mesh) 3195 ELSE 3196 CALL AssignLocalNumber(Face, Face % BoundaryInfo % Right, Mesh) 3197 END IF 3198 ELSE IF (PRESENT(FaceDOFs)) THEN 3199 el_id = face % TYPE % ElementCode / 100 3200 Face % BDOFs = MAX(FaceDOFs(i), Face % BDOFs) 3201 IF ( PRESENT(inDOFs) ) Face % BDOFs = MAX(Face % BDOFs, InDOFs(el_id+6,5)) 3202 END IF 3203 3204 ! Get maximum dof for faces 3205 Mesh % MinFaceDOFs = MIN(Face % BDOFs, Mesh % MinFaceDOFs) 3206 Mesh % MaxFaceDOFs = MAX(Face % BDOFs, Mesh % MaxFaceDOFs) 3207 END DO 3208 END DO 3209 IF ( Mesh % MinFaceDOFs > Mesh % MaxFaceDOFs ) Mesh % MinFaceDOFs = MEsh % MaxFaceDOFs 3210 3211 ! Set local edges for boundary elements 3212 DO i=Mesh % NumberOfBulkElements + 1, & 3213 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 3214 Element => Mesh % Elements(i) 3215 3216 ! Here set local number and copy attributes to this boundary element for left parent. 3217 IF (ASSOCIATED(Element % BoundaryInfo % Left)) THEN 3218 ! Local edges are only assigned for p elements 3219 IF (ASSOCIATED(Element % BoundaryInfo % Left % PDefs)) THEN 3220 CALL AllocatePDefinitions(Element) 3221 Element % PDefs % isEdge = .TRUE. 3222 CALL AssignLocalNumber(Element, Element % BoundaryInfo % Left, Mesh) 3223 ! CYCLE 3224 END IF 3225 END IF 3226 3227 ! Here set local number and copy attributes to this boundary element for right parent 3228 IF (ASSOCIATED(Element % BoundaryInfo % Right)) THEN 3229 ! Local edges are only assigned for p elements 3230 IF (ASSOCIATED(Element % BoundaryInfo % Right % PDefs)) THEN 3231 CALL AllocatePDefinitions(Element) 3232 Element % PDefs % isEdge = .TRUE. 3233 CALL AssignLocalNumber(Element, Element % BoundaryInfo % Right, Mesh) 3234 END IF 3235 END IF 3236 3237 IF (AssignEdges) THEN 3238 IF (ASSOCIATED(Element % BoundaryInfo % Left)) THEN 3239 CALL AssignLocalNumber(Element,Element % BoundaryInfo % Left, Mesh, NoPE=.TRUE.) 3240 END IF 3241 IF (ASSOCIATED(Element % BoundaryInfo % Right)) THEN 3242 CALL AssignLocalNumber(Element,Element % BoundaryInfo % Right, Mesh, NoPE=.TRUE.) 3243 END IF 3244 END IF 3245 END DO 3246!------------------------------------------------------------------------------ 3247 END SUBROUTINE SetMeshEdgeFaceDofs 3248!------------------------------------------------------------------------------ 3249 3250!------------------------------------------------------------------------------ 3251 SUBROUTINE SetMeshMaxDOFs(Mesh) 3252!------------------------------------------------------------------------------ 3253 TYPE(Mesh_t) :: Mesh 3254!------------------------------------------------------------------------------ 3255 TYPE(Element_t), POINTER :: Element 3256 INTEGER :: i,j,n 3257 3258 ! Set gauss points for each p element 3259 DO i=1,Mesh % NumberOfBulkElements 3260 Element => Mesh % Elements(i) 3261 3262 IF ( ASSOCIATED(Element % PDefs) ) THEN 3263 Element % PDefs % GaussPoints = getNumberOfGaussPoints( Element, Mesh ) 3264 END IF 3265 3266 ! Set max element dofs here (because element size may have changed 3267 ! when edges and faces have been set). This is the absolute worst case. 3268 ! Element which has MaxElementDOFs may not even be present as a 3269 ! real element 3270 Mesh % MaxElementDOFs = MAX( Mesh % MaxElementDOFs, & 3271 Element % TYPE % NumberOfNodes + & 3272 Element % TYPE % NumberOfEdges * Mesh % MaxEdgeDOFs + & 3273 Element % TYPE % NumberOfFaces * Mesh % MaxFaceDOFs + & 3274 Element % BDOFs, & 3275 Element % DGDOFs ) 3276 3277 Mesh % MaxBDOFs = MAX( Element % BDOFs, Mesh % MaxBDOFs ) 3278 END DO 3279 3280 DO i=1,Mesh % NumberOFBulkElements 3281 Element => Mesh % Elements(i) 3282 IF ( Element % BDOFs > 0 ) THEN 3283 ALLOCATE( Element % BubbleIndexes(Element % BDOFs) ) 3284 DO j=1,Element % BDOFs 3285 Element % BubbleIndexes(j) = Mesh % MaxBDOFs*(i-1)+j 3286 END DO 3287 END IF 3288 END DO 3289!------------------------------------------------------------------------------ 3290 END SUBROUTINE SetMeshMaxDOFs 3291!------------------------------------------------------------------------------ 3292 3293 SUBROUTINE ReadTargetNames(Model,Filename) 3294 CHARACTER(LEN=*) :: FileName 3295 TYPE(Model_t) :: Model 3296!------------------------------------------------------------------------------ 3297 INTEGER, PARAMETER :: FileUnit = 10 3298 INTEGER, PARAMETER :: A=ICHAR('A'),Z=ICHAR('Z'),U2L=ICHAR('a')-ICHAR('A') 3299 INTEGER :: i,j,k,iostat,i1,i2,i3,n 3300 INTEGER :: ivals(256) 3301 CHARACTER(LEN=1024) :: str, name0, name1 3302 TYPE(ValueList_t), POINTER :: Vlist 3303 LOGICAL :: Found, AlreadySet 3304 3305 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', IOSTAT=iostat ) 3306 IF( iostat /= 0 ) THEN 3307 CALL Fatal('ReadTargetNames','Requested the use of entity names but this file does not exits: '//TRIM(FileName)) 3308 END IF 3309 3310 CALL Info('ReadTargetNames','Reading names info from file: '//TRIM(FileName)) 3311 3312 DO WHILE( .TRUE. ) 3313 READ(FileUnit,'(A)',IOSTAT=iostat) str 3314 IF( iostat /= 0 ) EXIT 3315 i = INDEX( str,'$') 3316 j = INDEX( str,'=') 3317 IF( i == 0 .OR. j == 0 ) CYCLE 3318 3319 i = i + 1 3320 DO WHILE(i<=LEN_TRIM(str) .AND. str(i:i)==' ') 3321 i = i + 1 3322 END DO 3323 3324 i1 = i 3325 i2 = j-1 3326 i3 = j+1 3327 3328 ! Move to lowercase since the "name" in sif file is also 3329 ! always in lowercase. 3330 DO i=i1,i2 3331 j = i+1-i1 3332 k = ICHAR(str(i:i)) 3333 IF ( k >= A .AND. k<= Z ) THEN 3334 name0(j:j) = CHAR(k+U2L) 3335 ELSE 3336 name0(j:j) = str(i:i) 3337 END IF 3338 END DO 3339 3340 n = str2ints( str(i3:),ivals ) 3341 IF( n == 0 ) THEN 3342 CALL Fatal('ReadTargetNames','Could not find arguments for: '//str(i1:i2)) 3343 END IF 3344 3345 AlreadySet = .FALSE. 3346 3347 DO i=1,Model % NumberOfBCs 3348 Vlist => Model % BCs(i) % Values 3349 name1 = ListGetString( Vlist,'Name',Found ) 3350 IF(.NOT. Found ) CYCLE 3351 IF( name0(1:i2-i1+1) == TRIM(name1) ) THEN 3352! PRINT *,'Name > '//TRIM(name1)//' < matches BC '//TRIM(I2S(i)) 3353 IF( AlreadySet ) THEN 3354 CALL Fatal('ReadTargetNames','Mapping of name is not unique: '//TRIM(name1) ) 3355 ELSE IF( ListCheckPresent( Vlist,'Target Boundaries') ) THEN 3356 CALL Info('ReadTargetNames','> Target Boundaries < already defined for BC '& 3357 //TRIM(I2S(i))) 3358 ELSE 3359 CALL ListAddIntegerArray( Vlist,'Target Boundaries',n,ivals(1:n)) 3360 AlreadySet = .TRUE. 3361 END IF 3362 END IF 3363 END DO 3364 3365 DO i=1,Model % NumberOfBodies 3366 Vlist => Model % Bodies(i) % Values 3367 name1 = ListGetString( Vlist,'Name',Found ) 3368 IF(.NOT. Found ) CYCLE 3369 IF( name0(1:i2-i1+1) == TRIM(name1) ) THEN 3370! PRINT *,'Name > '//TRIM(name1)//' < matches body '//TRIM(I2S(i)) 3371 IF( AlreadySet ) THEN 3372 CALL Fatal('ReadTargetNames','Mapping of name is not unique: '//TRIM(name1) ) 3373 ELSE IF( ListCheckPresent( Vlist,'Target Bodies') ) THEN 3374 CALL Info('ReadTargetNames','> Target Bodies < already defined for Body '& 3375 //TRIM(I2S(i))) 3376 ELSE 3377 CALL ListAddIntegerArray( Vlist,'Target Bodies',n,ivals(1:n)) 3378 AlreadySet = .TRUE. 3379 END IF 3380 END IF 3381 END DO 3382 3383 IF(.NOT. AlreadySet ) THEN 3384 CALL Warn('ReadTargetNames','Could not map name to Body nor BC: '//name0(1:i2-i1+1) ) 3385 END IF 3386 3387 END DO 3388 3389 CLOSE(FileUnit) 3390 3391 END SUBROUTINE ReadTargetNames 3392 3393 3394!------------------------------------------------------------------------------ 3395!> This subroutine reads elementwise input data from the file mesh.elements.data 3396!> and inserts the data into the structured data variable 3397!> Mesh % Elements(element_id) % PropertyData. The contents of the file should 3398!> be arranged as 3399!> 3400!> element: element_id_1 3401!> data_set_name_1: a_1 a_2 ... a_n 3402!> data_set_name_2: b_1 b_2 ... b_m 3403!> data_set_name_3: ... 3404!> end 3405!> element: ... 3406!> ... 3407!> end 3408!------------------------------------------------------------------------------ 3409 SUBROUTINE ReadElementPropertyFile(FileName,Mesh) 3410!------------------------------------------------------------------------------ 3411 CHARACTER(LEN=*) :: FileName 3412 TYPE(Mesh_t) :: Mesh 3413!------------------------------------------------------------------------------ 3414 INTEGER, PARAMETER :: MAXLEN=1024 3415 CHARACTER(LEN=:), ALLOCATABLE :: str 3416 INTEGER :: i,j,n 3417 INTEGER, PARAMETER :: FileUnit = 10 3418 REAL(KIND=dp) :: x 3419 TYPE(Element_t), POINTER :: Element 3420 TYPE(ElementData_t), POINTER :: PD,PD1 3421!------------------------------------------------------------------------------ 3422 ALLOCATE(CHARACTER(MAX_STRING_LEN)::str) 3423 3424 OPEN( Unit=FileUnit, File=FileName, STATUS='OLD', ERR=10 ) 3425 3426 DO WHILE( ReadAndTrim(FileUnit,str) ) 3427 READ( str(9:),*) i 3428 IF ( i < 0 .OR. i > Mesh % NumberOFBulkElements ) THEN 3429 CALL Fatal( 'ReadElementPropertyFile', 'Element id out of range.' ) 3430 END IF 3431 3432 IF ( SEQL( str, 'element:') ) THEN 3433 Element => Mesh % Elements(i) 3434 PD => Element % PropertyData 3435 3436 DO WHILE(ReadAndTrim(FileUnit,str)) 3437 IF ( str == 'end' ) EXIT 3438 3439 i = INDEX(str, ':') 3440 IF ( i<=0 ) CYCLE 3441 3442 IF ( .NOT.ASSOCIATED(PD) ) THEN 3443 ALLOCATE( Element % PropertyData ) 3444 PD => Element % PropertyData 3445 PD % Name = TRIM(str(1:i-1)) 3446 ELSE 3447 DO WHILE(ASSOCIATED(PD)) 3448 IF ( PD % Name==TRIM(str(1:i-1)) ) EXIT 3449 PD1 => PD 3450 PD => PD % Next 3451 END DO 3452 3453 IF (.NOT. ASSOCIATED(PD) ) THEN 3454 ALLOCATE(PD1 % Next) 3455 PD => PD1 % Next 3456 PD % Name = TRIM(str(1:i-1)) 3457 END IF 3458 END IF 3459 3460 j = i+1 3461 n = 0 3462 DO WHILE(j<=LEN_TRIM(str)) 3463 READ( str(j:), *, END=20,ERR=20 ) x 3464 n = n + 1 3465 DO WHILE(j<=LEN_TRIM(str) .AND. str(j:j)==' ') 3466 j = j + 1 3467 END DO 3468 DO WHILE(j<=LEN_TRIM(str) .AND. str(j:j)/=' ') 3469 j = j + 1 3470 END DO 3471 END DO 347220 CONTINUE 3473 IF ( n>0 ) THEN 3474 ALLOCATE(PD % Values(n)) 3475 j = i+1 3476 n = 1 3477 DO WHILE(j<=LEN_TRIM(str)) 3478 READ( str(j:), *, END=30,ERR=30 ) PD % Values(n) 3479 n = n + 1 3480 DO WHILE(j<=LEN_TRIM(str) .AND. str(j:j)==' ') 3481 j = j + 1 3482 END DO 3483 DO WHILE(j<=LEN_TRIM(str) .AND. str(j:j)/=' ') 3484 j = j + 1 3485 END DO 3486 END DO 348730 CONTINUE 3488 END IF 3489 END DO 3490 END IF 3491 END DO 3492 3493 CLOSE(FileUnit) 3494 349510 CONTINUE 3496 3497!------------------------------------------------------------------------------ 3498 END SUBROUTINE ReadElementPropertyFile 3499!------------------------------------------------------------------------------ 3500 3501 3502!------------------------------------------------------------------------------ 3503 SUBROUTINE MeshStabParams( Mesh ) 3504!------------------------------------------------------------------------------ 3505 TYPE(Mesh_t), POINTER :: Mesh 3506!------------------------------------------------------------------------------ 3507 TYPE(Solver_t), POINTER :: Solver 3508 INTEGER :: i,n, istat 3509 LOGICAL :: stat, Stabilize, UseLongEdge 3510 TYPE(Nodes_t) :: Nodes 3511 TYPE(Element_t), POINTER :: Element 3512!------------------------------------------------------------------------------ 3513 3514 CALL Info('MeshStabParams','Computing stabilization parameters',Level=7) 3515 CALL ResetTimer('MeshStabParams') 3516 3517 IF(.NOT. ASSOCIATED( Mesh ) ) THEN 3518 CALL Fatal('MeshStabParams','Mesh not associated') 3519 END IF 3520 3521 IF ( Mesh % NumberOfNodes <= 0 ) RETURN 3522 3523 Stabilize = .FALSE. 3524 3525 DO i=1,CurrentModel % NumberOfSolvers 3526 Solver => CurrentModel % Solvers(i) 3527 IF ( ASSOCIATED( Mesh, Solver % Mesh ) ) THEN 3528 Stabilize = Stabilize .OR. & 3529 ListGetLogical( Solver % Values, 'Stabilize', Stat ) 3530 Stabilize = Stabilize .OR. & 3531 ListGetString( Solver % Values, & 3532 'Stabilization Method', Stat )=='vms' 3533 Stabilize = Stabilize .OR. & 3534 ListGetString( Solver % Values, & 3535 'Stabilization Method', Stat )=='stabilized' 3536 END IF 3537 END DO 3538 3539 Mesh % Stabilize = Stabilize 3540 3541 IF( ListGetLogical(CurrentModel % Simulation, & 3542 "Skip Mesh Stabilization",Stat) ) RETURN 3543 3544 !IF( .NOT. Stabilize ) THEN 3545 ! CALL Info('MeshStabParams','No need to compute stabilization parameters',Level=10) 3546 ! RETURN 3547 !END IF 3548 3549 CALL AllocateVector( Nodes % x, Mesh % MaxElementNodes ) 3550 CALL AllocateVector( Nodes % y, Mesh % MaxElementNodes ) 3551 CALL AllocateVector( Nodes % z, Mesh % MaxElementNodes ) 3552 3553 UseLongEdge = ListGetLogical(CurrentModel % Simulation, & 3554 "Stabilization Use Longest Element Edge",Stat) 3555 3556 DO i=1,Mesh % NumberOfBulkElements+Mesh % NumberOfBoundaryElements 3557 Element => Mesh % Elements(i) 3558 n = Element % TYPE % NumberOfNodes 3559 Nodes % x(1:n) = Mesh % Nodes % x(Element % NodeIndexes) 3560 Nodes % y(1:n) = Mesh % Nodes % y(Element % NodeIndexes) 3561 Nodes % z(1:n) = Mesh % Nodes % z(Element % NodeIndexes) 3562 IF ( Mesh % Stabilize ) THEN 3563 CALL StabParam( Element, Nodes,n, & 3564 Element % StabilizationMK, Element % hK, UseLongEdge=UseLongEdge) 3565 ELSE 3566 Element % hK = ElementDiameter( Element, Nodes, UseLongEdge=UseLongEdge) 3567 END IF 3568 END DO 3569 3570 DEALLOCATE( Nodes % x, Nodes % y, Nodes % z ) 3571 3572 CALL CheckTimer('MeshStabParams',Level=7,Delete=.TRUE.) 3573!---------------------------------------------------------------------------- 3574 END SUBROUTINE MeshStabParams 3575!------------------------------------------------------------------------------ 3576 3577 3578 3579 3580!------------------------------------------------------------------------------ 3581!> Given two interface meshes check the angle between them using the normal 3582!> vectors of the first element. Also check that all other elements are 3583!> aligned with the first one. Only then is it possible to determine the angle. 3584!------------------------------------------------------------------------------ 3585 SUBROUTINE CheckInterfaceMeshAngle(BMesh1, BMesh2, Angles, GotAngles) 3586!------------------------------------------------------------------------------ 3587 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 3588 REAL(KIND=dp) :: Angles(3) 3589 LOGICAL :: GotAngles 3590 !--------------------------------------------------------------------------- 3591 TYPE(Mesh_t), POINTER :: PMesh 3592 TYPE(Element_t), POINTER :: Element 3593 TYPE(Nodes_t) :: ElementNodes 3594 INTEGER, POINTER :: NodeIndexes(:) 3595 INTEGER :: i,j,k,n 3596 REAL(KIND=dp) :: Normal(3), Normal1(3), Normal2(3), Dot1Min, Dot2Min, Alpha 3597 LOGICAL :: ConstantNormals 3598 3599 ! Currently check of the normal direction is not enforced since at this stage 3600 ! CurrentModel % Nodes may not exist! 3601 ! This means that there may be a 180 error in the directions. 3602 ! Therefore an angle smaller than 180 is always chosen. 3603 !----------------------------------------------------------------------------- 3604 N = MAX( BMesh1 % MaxElementNodes, BMesh2 % MaxElementNodes ) 3605 ALLOCATE(ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n) ) 3606 3607 DO k=1,2 3608 IF( k == 1 ) THEN 3609 PMesh => BMesh1 3610 ELSE 3611 PMesh => BMesh2 3612 END IF 3613 3614 ! we use the Dot2Min and Normal2 temporarily also for first mesh, with k=1 3615 !------------------------------------------------------------------------- 3616 DO i=1, PMesh % NumberOfBoundaryElements 3617 Element => PMesh % Elements(i) 3618 3619 n = Element % TYPE % NumberOfNodes 3620 NodeIndexes => Element % NodeIndexes 3621 3622 ElementNodes % x(1:n) = PMesh % Nodes % x(NodeIndexes(1:n)) 3623 ElementNodes % y(1:n) = PMesh % Nodes % y(NodeIndexes(1:n)) 3624 ElementNodes % z(1:n) = PMesh % Nodes % z(NodeIndexes(1:n)) 3625 3626 Normal = NormalVector( Element, ElementNodes, Check = .FALSE. ) 3627 3628 ! we use the Dot2Min and Normal2 temporarily also for first mesh, with k=1 3629 !------------------------------------------------------------------------- 3630 IF( i == 1 ) THEN 3631 Normal2 = Normal 3632 Dot2Min = 1.0_dp 3633 ELSE 3634 Dot2min = MIN( Dot2Min, SUM( Normal * Normal2 ) ) 3635 END IF 3636 END DO 3637 3638 IF( k == 1 ) THEN 3639 Normal1 = Normal2 3640 Dot1Min = Dot2Min 3641 END IF 3642 END DO 3643 3644 ConstantNormals = ( 1 - Dot1Min < 1.0d-6 ) .AND. ( 1 - Dot2Min < 1.0d-6 ) 3645 IF( ConstantNormals ) THEN 3646 WRITE(Message,'(A,3ES12.3)') 'Master normal: ',Normal1 3647 CALL Info('CheckInterfaceMeshAngle',Message,Level=8) 3648 3649 WRITE(Message,'(A,3ES12.3)') 'Initial Target normal: ',Normal2 3650 CALL Info('CheckInterfaceMeshAngle',Message,Level=8) 3651 3652 ! The full angle between the two normals 3653 Alpha = ACOS( SUM( Normal1 * Normal2 ) ) * 180.0_dp / PI 3654 WRITE(Message,'(A,ES12.3)') & 3655 'Suggested angle between two normals in degs (+/- 180): ',Alpha 3656 CALL Info('CheckInterfaceMeshAngle',Message,Level=8) 3657 ELSE 3658 CALL Warn('CheckInterfaceMeshAngle','Could not suggest rotation angle') 3659 END IF 3660 3661 3662 GotAngles = .FALSE. 3663 Angles = 0.0_dp 3664 IF( .NOT. ConstantNormals ) THEN 3665 CALL Warn('CheckInterfaceMeshAngle','Normals are not constant, cannot test for rotation!') 3666 ELSE IF( Alpha > EPSILON( Alpha ) ) THEN 3667 ! Rotation should be performed 3668 DO i=1,3 3669 IF( ABS ( Normal1(i) - Normal2(i) ) < EPSILON( Alpha ) ) THEN 3670 GotAngles = .TRUE. 3671 WRITE(Message,'(A,I0,A,ES12.3)') & 3672 'Rotation around axis ',i,' in degs ',Alpha 3673 CALL Info('CheckInterfaceMeshAngle',Message,Level=8) 3674 Angles(i) = Alpha 3675 EXIT 3676 END IF 3677 END DO 3678 IF(.NOT. GotAngles ) THEN 3679 CALL Warn('CheckInterfaceMeshAngle','could not define rotation axis, improve algorithm!') 3680 END IF 3681 END IF 3682 3683 DEALLOCATE(ElementNodes % x, ElementNodes % y, ElementNodes % z ) 3684 3685 END SUBROUTINE CheckInterfaceMeshAngle 3686!------------------------------------------------------------------------------ 3687 3688 3689!------------------------------------------------------------------------------ 3690!> The quadratic mesh should be such that the center nodes lie roughly between 3691!> the corner nodes. This routine checks that this is actually the case. 3692!> The intended use for the routine is different kind of mesh related debugging. 3693!------------------------------------------------------------------------------ 3694 SUBROUTINE InspectQuadraticMesh( Mesh, EnforceToCenter ) 3695 3696 TYPE(Mesh_t), TARGET :: Mesh 3697 LOGICAL, OPTIONAL :: EnforceToCenter 3698 3699 LOGICAL :: Enforce 3700 INTEGER :: i,n,k,k1,k2,k3,ElemCode,ElemFamily,ElemDegree,ErrCount,TotCount 3701 REAL(KIND=dp) :: Center(3),Ref(3),Dist,Length 3702 REAL(KIND=dp), POINTER :: x(:),y(:),z(:) 3703 3704 TYPE(Element_t), POINTER :: Element 3705 INTEGER, POINTER :: CenterMap(:,:) 3706 INTEGER, TARGET :: TriangleCenterMap(3,3), QuadCenterMap(4,3), & 3707 TetraCenterMap(6,3), BrickCenterMap(12,3), WedgeCenterMap(9,3), PyramidCenterMap(8,3) 3708 3709 CALL Info('InspectQuadraticMesh','Inspecting quadratic mesh for outliers') 3710 CALL Info('InspectQuadraticMesh','Number of nodes: '//TRIM(I2S(Mesh % NumberOfNodes)),Level=8) 3711 CALL Info('InspectQuadraticMesh','Number of bulk elements: '& 3712 //TRIM(I2S(Mesh % NumberOfBulkElements)),Level=8) 3713 CALL Info('InspectQuadraticMesh','Number of boundary elements: '& 3714 //TRIM(I2S(Mesh % NumberOfBoundaryElements)),Level=8) 3715 3716 3717 IF( PRESENT( EnforceToCenter ) ) THEN 3718 Enforce = EnforceToCenter 3719 ELSE 3720 Enforce = .FALSE. 3721 END IF 3722 3723 TriangleCenterMap(1,:) = [ 1, 2, 4] 3724 TriangleCenterMap(2,:) = [ 2, 3, 5] 3725 TriangleCenterMap(3,:) = [ 3, 1, 6] 3726 3727 QuadCenterMap(1,:) = [ 1, 2, 5] 3728 QuadCenterMap(2,:) = [ 2, 3, 6] 3729 QuadCenterMap(3,:) = [ 3, 4, 7] 3730 QuadCenterMap(4,:) = [ 4, 1, 8] 3731 3732 TetraCenterMap(1,:) = [ 1, 2, 5] 3733 TetraCenterMap(2,:) = [ 2, 3, 6] 3734 TetraCenterMap(3,:) = [ 3, 1, 7] 3735 TetraCenterMap(4,:) = [ 1, 4, 8] 3736 TetraCenterMap(5,:) = [ 2, 4, 9] 3737 TetraCenterMap(6,:) = [ 3, 4, 10] 3738 3739 BrickCenterMap(1,:) = [ 1, 2, 9 ] 3740 BrickCenterMap(2,:) = [ 2, 3, 10 ] 3741 BrickCenterMap(3,:) = [ 3, 4, 11 ] 3742 BrickCenterMap(4,:) = [ 4, 1, 12 ] 3743 BrickCenterMap(5,:) = [ 1, 5, 13 ] 3744 BrickCenterMap(6,:) = [ 2, 6, 14 ] 3745 BrickCenterMap(7,:) = [ 3, 7, 15 ] 3746 BrickCenterMap(8,:) = [ 4, 8, 16 ] 3747 BrickCenterMap(9,:) = [ 5, 6, 17 ] 3748 BrickCenterMap(10,:) = [ 6, 7, 18 ] 3749 BrickCenterMap(11,:) = [ 7, 8, 19 ] 3750 BrickCenterMap(12,:) = [ 8, 5, 20 ] 3751 3752 WedgeCenterMap(1,:) = [ 1, 2, 7 ] 3753 WedgeCenterMap(2,:) = [ 2, 3, 8 ] 3754 WedgeCenterMap(3,:) = [ 3, 1, 9 ] 3755 WedgeCenterMap(4,:) = [ 4, 5, 10 ] 3756 WedgeCenterMap(5,:) = [ 5, 6, 11 ] 3757 WedgeCenterMap(6,:) = [ 6, 4, 12 ] 3758 WedgeCenterMap(7,:) = [ 1, 4, 13 ] 3759 WedgeCenterMap(8,:) = [ 2, 5, 14 ] 3760 WedgeCenterMap(9,:) = [ 3, 6, 15 ] 3761 3762 PyramidCenterMap(1,:) = [ 1,2,6 ] 3763 PyramidCenterMap(2,:) = [ 2,3,7 ] 3764 PyramidCenterMap(3,:) = [ 3,4,8 ] 3765 PyramidCenterMap(4,:) = [ 4,1,9 ] 3766 PyramidCenterMap(5,:) = [ 1,5,10 ] 3767 PyramidCenterMap(6,:) = [ 2,5,11 ] 3768 PyramidCenterMap(7,:) = [ 3,5,12 ] 3769 PyramidCenterMap(8,:) = [ 4,5,13 ] 3770 3771 x => Mesh % Nodes % x 3772 y => Mesh % Nodes % y 3773 z => Mesh % Nodes % z 3774 3775 ! Loop over elements: 3776 ! ------------------- 3777 ErrCount = 0 3778 TotCount = 0 3779 3780 DO i=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 3781 Element => Mesh % Elements(i) 3782 3783 ElemCode = Element % TYPE % ElementCode 3784 ElemFamily = ElemCode / 100 3785 ElemDegree = Element % TYPE % BasisFunctionDegree 3786 3787 ! Only check quadratic elements! 3788 IF( ElemDegree /= 2 ) CYCLE 3789 3790 SELECT CASE( ElemFamily ) 3791 3792 CASE(3) 3793 n = 3 3794 CenterMap => TriangleCenterMap 3795 3796 CASE(4) 3797 n = 4 3798 CenterMap => QuadCenterMap 3799 3800 CASE(5) 3801 n = 6 3802 CenterMap => TetraCenterMap 3803 3804 CASE(6) 3805 n = 8 3806 CenterMap => PyramidCenterMap 3807 3808 CASE(7) 3809 n = 9 3810 CenterMap => WedgeCenterMap 3811 3812 CASE(8) 3813 n = 12 3814 CenterMap => BrickCenterMap 3815 3816 CASE DEFAULT 3817 CALL Fatal('InspectQuadraticMesh','Element type '//TRIM(I2S(ElemCode))//' not implemented!') 3818 3819 END SELECT 3820 3821 ! Loop over every edge of every element: 3822 ! -------------------------------------- 3823 DO k=1,n 3824 k1 = Element % NodeIndexes( CenterMap(k,1) ) 3825 k2 = Element % NodeIndexes( CenterMap(k,2) ) 3826 k3 = Element % NodeIndexes( CenterMap(k,3) ) 3827 3828 Center(1) = ( x(k1) + x(k2) ) / 2.0_dp 3829 Center(2) = ( y(k1) + y(k2) ) / 2.0_dp 3830 Center(3) = ( z(k1) + z(k2) ) / 2.0_dp 3831 3832 Ref(1) = x(k3) 3833 Ref(2) = y(k3) 3834 Ref(3) = z(k3) 3835 3836 Length = SQRT( (x(k1) - x(k2))**2.0 + (y(k1) - y(k2))**2.0 + (z(k1) - z(k2))**2.0 ) 3837 Dist = SQRT( SUM( (Center - Ref)**2.0 ) ) 3838 3839 TotCount = TotCount + 1 3840 IF( Dist > 0.01 * Length ) THEN 3841 ErrCount = ErrCount + 1 3842 PRINT *,'Center Displacement:',i,ElemCode,n,k,Dist/Length 3843 END IF 3844 3845 IF( Enforce ) THEN 3846 x(k3) = Center(1) 3847 y(k3) = Center(2) 3848 z(k3) = Center(3) 3849 END IF 3850 3851 END DO 3852 END DO 3853 3854 IF( TotCount > 0 ) THEN 3855 CALL Info('InspectQuadraticMesh','Number of outlier nodes is '& 3856 //TRIM(I2S(ErrCount))//' out of '//TRIM(I2S(TotCount)),Level=6) 3857 ELSE 3858 CALL Info('InspectQuadraticMesh','No quadratic elements to inspect',Level=8) 3859 END IF 3860 3861 END SUBROUTINE InspectQuadraticMesh 3862 3863 3864 3865 !------------------------------------------------------------------------------ 3866 !> Find axial, radial or rotational mortar boundary pairs. 3867 !------------------------------------------------------------------------------ 3868 SUBROUTINE DetectMortarPairs( Model, Mesh, Tol, BCMode, SameCoordinate ) 3869 !------------------------------------------------------------------------------ 3870 TYPE(Model_t) :: Model 3871 TYPE(Mesh_t), POINTER :: Mesh 3872 REAL(KIND=dp) :: Tol 3873 INTEGER :: BcMode 3874 LOGICAL :: SameCoordinate 3875 !------------------------------------------------------------------------------ 3876 INTEGER :: i,j,k,l,n,MinBC,MaxBC,BC,ElemCode 3877 TYPE(Element_t), POINTER :: Element, Parent, Left, Right, Elements(:) 3878 INTEGER, POINTER :: NodeIndexes(:) 3879 LOGICAL :: Found 3880 LOGICAL, ALLOCATABLE :: BCSet(:), BCPos(:), BCNeg(:), BCNot(:) 3881 INTEGER, ALLOCATABLE :: BCCount(:) 3882 REAL(KIND=dp) :: x,y,z,f 3883 REAL(KIND=dp), ALLOCATABLE :: BCVal(:) 3884 CHARACTER(LEN=MAX_NAME_LEN) :: str 3885 LOGICAL :: Debug = .FALSE., Hit 3886 3887 ! The code can detect pairs to be glued in different coordinate systems 3888 SELECT CASE( BCMode ) 3889 CASE( 1 ) 3890 str = 'x-coordinate' 3891 CASE( 2 ) 3892 str = 'y-coordinate' 3893 CASE( 3 ) 3894 str = 'z-coordinate' 3895 CASE( 4 ) 3896 str = 'radius' 3897 CASE( 5 ) 3898 str = 'angle' 3899 CASE DEFAULT 3900 CALL Fatal('DetectMortarPairs','Invalid BCMode: '//TRIM(I2S(BCMode))) 3901 END SELECT 3902 3903 CALL Info('DetectMortarPairs','Trying to find pairs in: '//TRIM(str),Level=6) 3904 3905 IF(.NOT. ASSOCIATED( Mesh ) ) THEN 3906 CALL Fatal('DetectMortarPairs','Mesh not associated!') 3907 END IF 3908 3909 IF( ParEnv % PEs > 1 ) THEN 3910 CALL Warn('DetectMortarPairs','Not implemented in parallel yet, be careful!') 3911 END IF 3912 3913 3914 ! Interface meshes consist of boundary elements only 3915 Elements => Mesh % Elements( Mesh % NumberOfBulkElements+1: ) 3916 3917 ! Find out the min and max constraint 3918 MinBC = HUGE( MinBC ) 3919 MaxBC = 0 3920 DO i=1, Mesh % NumberOfBoundaryElements 3921 Element => Elements(i) 3922 ElemCode = Element % Type % ElementCode 3923 IF (ElemCode<=200) CYCLE 3924 3925 BC = Element % BoundaryInfo % Constraint 3926 MinBC = MIN( MinBC, BC ) 3927 MaxBC = MAX( MaxBC, BC ) 3928 END DO 3929 3930 CALL Info('DetectMortarPairs','Minimum Constraint index: '//TRIM(I2S(MinBC)),Level=8) 3931 CALL Info('DetectMortarPairs','Maximum Constraint index: '//TRIM(I2S(MaxBC)),Level=8) 3932 IF( MaxBC - MinBC < 1 ) THEN 3933 CALL Warn('DetectMortarPairs','Needs at least two different BC indexes to create mortar pair!') 3934 RETURN 3935 END IF 3936 3937 ALLOCATE( BCVal( MinBC:MaxBC ) ) 3938 ALLOCATE( BCSet( MinBC:MaxBC ) ) 3939 ALLOCATE( BCNot( MinBC:MaxBC ) ) 3940 ALLOCATE( BCPos( MinBC:MaxBC ) ) 3941 ALLOCATE( BCNeg( MinBC:MaxBC ) ) 3942 ALLOCATE( BCCount( MinBC:MaxBC ) ) 3943 3944 BCVal = 0.0_dp 3945 BCSet = .FALSE. 3946 BCNot = .FALSE. 3947 BCPos = .FALSE. 3948 BCNeg = .FALSE. 3949 BCCount = 0 3950 3951 3952 DO i=1, Mesh % NumberOfBoundaryElements 3953 Element => Elements(i) 3954 ElemCode = Element % Type % ElementCode 3955 IF (ElemCode<=200) CYCLE 3956 3957 BC = Element % BoundaryInfo % Constraint 3958 3959 ! This boundary is already deemed not to be a good candidate 3960 IF( BCNot( BC ) ) CYCLE 3961 3962 n = Element % Type % NumberOfNodes 3963 3964 DO j=1,n 3965 k = Element % NodeIndexes(j) 3966 x = Mesh % Nodes % x(k) 3967 y = Mesh % Nodes % y(k) 3968 z = Mesh % Nodes % z(k) 3969 3970 ! Here f is a measure: x, y, z, radius, or angle 3971 SELECT CASE( BCMode ) 3972 CASE( 1 ) 3973 f = x 3974 CASE( 2 ) 3975 f = y 3976 CASE( 3 ) 3977 f = z 3978 CASE( 4 ) 3979 f = SQRT( x**2 + y**2 ) 3980 CASE( 5 ) 3981 f = ATAN2( y, x ) 3982 END SELECT 3983 3984 ! If the BC is not set then let the first be the one to compare against 3985 IF( .NOT. BCSet( BC ) ) THEN 3986 BCVal( BC ) = f 3987 BCSet( BC ) = .TRUE. 3988 IF( Debug ) PRINT *,'Compareing BC '//TRIM(I2S(BC))//' against:',f 3989 ELSE 3990 ! In consecutive rounds check that the level is consistent 3991 IF( ABS( f - BCVal(BC) ) > Tol ) THEN 3992 IF( Debug ) PRINT *,'Failing BC '//TRIM(I2S(BC))//' with:',f-BCVal(BC) 3993 BCNot( BC ) = .TRUE. 3994 EXIT 3995 END IF 3996 END IF 3997 END DO 3998 3999 IF( BCNot( BC ) ) CYCLE 4000 4001 Parent => Element % BoundaryInfo % Left 4002 IF( .NOT. ASSOCIATED( Parent ) ) THEN 4003 Parent => Element % BoundaryInfo % Right 4004 ELSE 4005 ! If there are two parents this is an internal BC 4006 IF( ASSOCIATED( Element % BoundaryInfo % Right ) ) THEN 4007 IF( Debug ) PRINT *,'Failing internal BC:',BC 4008 BCNot( BC ) = .TRUE. 4009 CYCLE 4010 END IF 4011 END IF 4012 4013 ! To define whether the boundar is on positive or negative side of the master element 4014 ! study the center point of the master element 4015 n = Parent % TYPE % NumberOfNodes 4016 x = SUM( Mesh % Nodes % x( Parent % NodeIndexes) ) / n 4017 y = SUM( Mesh % Nodes % y( Parent % NodeIndexes) ) / n 4018 z = SUM( Mesh % Nodes % z( Parent % NodeIndexes) ) / n 4019 4020 4021 SELECT CASE( BCMode ) 4022 CASE( 1 ) 4023 f = x 4024 CASE( 2 ) 4025 f = y 4026 CASE( 3 ) 4027 f = z 4028 CASE( 4 ) 4029 f = SQRT( x**2 + y**2 ) 4030 CASE( 5 ) 4031 f = ATAN2( y, x ) 4032 END SELECT 4033 4034 ! If the parent element is on alternating sides then this cannot be a proper boundary 4035 IF( f > BCVal( BC ) ) THEN 4036 IF( BCNeg( BC ) ) THEN 4037 IF( Debug ) PRINT *,'Failing inconsistent negative BC:',BC 4038 BCNot( BC ) = .TRUE. 4039 BCNeg( BC ) = .FALSE. 4040 CYCLE 4041 END IF 4042 BCPos( BC ) = .TRUE. 4043 ELSE 4044 IF( BCPos( BC ) ) THEN 4045 IF( Debug ) PRINT *,'Failing inconsistent positive BC:',BC 4046 BCNot( BC ) = .TRUE. 4047 BCPos( BC ) = .FALSE. 4048 CYCLE 4049 END IF 4050 BCNeg( BC ) = .TRUE. 4051 END IF 4052 END DO ! Number of boundary elements 4053 4054 IF( BCMode == 5 ) THEN 4055 BCVal = 180.0_dp * BCVal / PI 4056 END IF 4057 4058 j = COUNT( BCPos ) 4059 IF( Debug ) THEN 4060 IF( j > 0 ) THEN 4061 IF( Debug ) PRINT *,'Positive constant levels: ',j 4062 DO i=MinBC,MaxBC 4063 IF( BCPos(i) ) PRINT *,'BC:',i,BCVal(i) 4064 END DO 4065 END IF 4066 END IF 4067 4068 k = COUNT( BCNeg ) 4069 IF( Debug ) THEN 4070 IF( k > 0 ) THEN 4071 PRINT *,'Negative constant levels: ',k 4072 DO i=MinBC,MaxBC 4073 IF( BCNeg(i) ) PRINT *,'BC:',i,BCVal(i) 4074 END DO 4075 END IF 4076 END IF 4077 4078 IF( j * k == 0 ) THEN 4079 PRINT *,'Not enough candidate sides found' 4080 RETURN 4081 END IF 4082 4083 IF( SameCoordinate ) THEN 4084 DO i=MinBC,MaxBC 4085 Hit = .FALSE. 4086 IF( BCPos(i) ) THEN 4087 DO j=MinBC,MaxBC 4088 IF ( BCNeg(j) ) THEN 4089 IF( ABS( BCVal(i) - BCVal(j)) < Tol ) THEN 4090 Hit = .TRUE. 4091 EXIT 4092 END IF 4093 END IF 4094 END DO 4095 IF( .NOT. Hit ) THEN 4096 BCPos(i) = .FALSE. 4097 IF( Debug ) PRINT *,'Removing potential positive hit:',i 4098 END IF 4099 END IF 4100 IF( BCNeg(i) ) THEN 4101 Hit = .FALSE. 4102 DO j=MinBC,MaxBC 4103 IF ( BCPos(j) ) THEN 4104 IF( ABS( BCVal(i) - BCVal(j)) < Tol ) THEN 4105 Hit = .TRUE. 4106 EXIT 4107 END IF 4108 END IF 4109 END DO 4110 IF( .NOT. Hit ) THEN 4111 BCNeg(i) = .FALSE. 4112 IF( Debug ) PRINT *,'Removing potential negative hit:',i 4113 END IF 4114 END IF 4115 END DO 4116 4117 IF( .NOT. ANY( BCPos ) ) THEN 4118 PRINT *,'No possible pairs found at same location' 4119 RETURN 4120 END IF 4121 END IF 4122 4123 4124 k = 0 4125 DO i=MinBC,MaxBC 4126 IF( BCPos(i) ) THEN 4127 Hit = .FALSE. 4128 DO j=MinBC,i-1 4129 IF( BCPos(j) ) THEN 4130 IF( ABS( BCVal(i) - BCVal(j) ) < Tol ) THEN 4131 Hit = .TRUE. 4132 EXIT 4133 END IF 4134 END IF 4135 END DO 4136 IF(Hit ) THEN 4137 BCCount(i) = BCCount(j) 4138 ELSE 4139 k = k + 1 4140 BCCount(i) = k 4141 END IF 4142 END IF 4143 END DO 4144 PRINT *,'Found number of positive levels:',k 4145 4146 4147 k = 0 4148 DO i=MinBC,MaxBC 4149 IF( BCNeg(i) ) THEN 4150 Hit = .FALSE. 4151 DO j=MinBC,i-1 4152 IF( BCNeg(j) ) THEN 4153 IF( ABS( BCVal(i) - BCVal(j) ) < Tol ) THEN 4154 Hit = .TRUE. 4155 EXIT 4156 END IF 4157 END IF 4158 END DO 4159 IF(Hit ) THEN 4160 BCCount(i) = BCCount(j) 4161 ELSE 4162 k = k + 1 4163 BCCount(i) = -k 4164 END IF 4165 END IF 4166 END DO 4167 PRINT *,'Found number of negative levels:',k 4168 4169 PRINT *,'Slave BCs: ' 4170 DO i=MinBC,MaxBC 4171 IF( BCPos(i) ) PRINT *,'BC:',i,BCVal(i) 4172 END DO 4173 PRINT *,'Master BCs: ' 4174 DO i=MinBC,MaxBC 4175 IF( BCNeg(i) ) PRINT *,'BC:',i,BCVal(i) 4176 END DO 4177 4178 END SUBROUTINE DetectMortarPairs 4179 4180 4181 4182!------------------------------------------------------------------------------ 4183!> Create master and slave mesh for the interface in order to at a later 4184!> stage create projector matrix to implement periodicity or mortar elements. 4185!> The idea is to use a reduced set of elements and thereby speed up the 4186!> mapping process. Also this gives more flexibility in transformation 4187!> operations since the nodes may be ereased after use. 4188!------------------------------------------------------------------------------ 4189 SUBROUTINE CreateInterfaceMeshes( Model, Mesh, This, Trgt, BMesh1, BMesh2, & 4190 Success ) 4191!------------------------------------------------------------------------------ 4192 TYPE(Model_t) :: Model 4193 INTEGER :: This, Trgt 4194 TYPE(Mesh_t), TARGET :: Mesh 4195 TYPE(Matrix_t), POINTER :: Projector 4196 LOGICAL :: Success 4197!------------------------------------------------------------------------------ 4198 INTEGER :: i,j,k,l,m,n,n1,n2,k1,k2,ind,Constraint,DIM,ii,jj,kk 4199 TYPE(Element_t), POINTER :: Element, Left, Right, Elements(:) 4200 LOGICAL :: ThisActive, TargetActive 4201 INTEGER, POINTER :: NodeIndexes(:), Perm1(:), Perm2(:), PPerm(:) 4202 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2, PMesh 4203 LOGICAL :: OnTheFlyBC, CheckForHalo, NarrowHalo, NoHalo, SplitQuadratic, Found 4204 4205 TYPE(Element_t), POINTER :: Parent,q 4206 INTEGER :: en, in, HaloCount, ActiveCount, ElemCode, nSplit 4207 INTEGER :: SplitMap(4), SplitSizes(5) 4208 LOGICAL, ALLOCATABLE :: ActiveNode(:) 4209 4210 LOGICAL :: TagNormalFlip, Turn 4211 TYPE(Nodes_t) :: ElementNodes 4212 REAL(KIND=dp) :: Normal(3) 4213 4214 CALL Info('CreateInterfaceMeshes','Making a list of elements at interface',Level=9) 4215 4216 4217 IF ( This <= 0 .OR. Trgt <= 0 ) THEN 4218 CALL Fatal('CreateInterfaceMeshes','Invalid target boundaries') 4219 END IF 4220 4221 ! Interface meshes consist of boundary elements only 4222 Elements => Mesh % Elements( Mesh % NumberOfBulkElements+1: ) 4223 4224 ! We need direction of initial normal if we have a "normal projector" 4225 TagNormalFlip = ListGetLogical( Model % BCs(This) % Values,'Normal Projector',Found ) 4226 IF( TagNormalFlip ) THEN 4227 CALL Info('CreateInterfaceMeshes','Storing initial information on normal directions',Level=12) 4228 n = Mesh % MaxElementNodes 4229 ALLOCATE( ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n) ) 4230 END IF 4231 4232 4233 SplitQuadratic = ListGetLogical( Model % Simulation,'Mortar BCs Split Quadratic',Found ) 4234 IF( Mesh % NumberOfFaces > 0 .OR. Mesh % NumberOfEdges > 0 ) THEN 4235 SplitQuadratic = .FALSE. 4236 END IF 4237 IF( SplitQuadratic ) CALL Info('CreateInterfaceMeshes',& 4238 'Quadratic elements will be split',Level=7) 4239 4240 4241 4242 ! If the target is larger than number of BCs given then 4243 ! it has probably been created on-the-fly from a discontinuous boundary. 4244 OnTheFlyBC = ( Trgt > Model % NumberOfBCs ) 4245 4246 ! In parallel we may have some excess halo elements. 4247 ! To eliminate them mark the nodes that are associated to elements truly owned. 4248 NarrowHalo = .FALSE. 4249 NoHalo = .FALSE. 4250 4251 IF( ParEnv % PEs > 1 ) THEN 4252 ! Account for halo elements that share some nodes for the master boundary 4253 NarrowHalo = ListGetLogical(Model % Solver % Values,'Projector Narrow Halo',Found) 4254 4255 ! Do not allow for any halo elements for the master boundary 4256 IF( .NOT. Found ) THEN 4257 NoHalo = ListGetLogical(Model % Solver % Values,'Projector No Halo',Found) 4258 END IF 4259 4260 IF(.NOT. Found ) THEN 4261 IF( ListGetLogical(Model % Solver % Values, 'Partition Local Constraints',Found) ) THEN 4262 NarrowHalo = .TRUE. 4263 ELSE 4264 NoHalo = .TRUE. 4265 END IF 4266 END IF 4267 END IF 4268 4269 ! This is just temporarily set to false always until the logic has been tested. 4270 CheckForHalo = NarrowHalo .OR. NoHalo 4271 4272 IF( CheckForHalo ) THEN 4273 CALL Info('CreateInterfaceMeshes','Checking for halo elements',Level=15) 4274 ALLOCATE( ActiveNode( Mesh % NumberOfNodes ) ) 4275 HaloCount = 0 4276 ActiveNode = .FALSE. 4277 DO i=1, Mesh % NumberOfBoundaryElements 4278 Element => Elements(i) 4279 IF (Element % TYPE % ElementCode<=200) CYCLE 4280 4281 Left => Element % BoundaryInfo % Left 4282 IF( ASSOCIATED( Left ) ) THEN 4283 IF( Left % PartIndex == ParEnv % MyPe ) THEN 4284 ActiveNode( Left % NodeIndexes ) = .TRUE. 4285 ELSE 4286 HaloCount = HaloCount + 1 4287 END IF 4288 END IF 4289 4290 Right => Element % BoundaryInfo % Right 4291 IF( ASSOCIATED( Right ) ) THEN 4292 IF( Right % PartIndex == ParEnv % MyPe ) THEN 4293 ActiveNode( Right % NodeIndexes ) = .TRUE. 4294 ELSE 4295 HaloCount = HaloCount + 1 4296 END IF 4297 END IF 4298 END DO 4299 4300 ! No halo element found on the boundary so no need to check them later 4301 IF( HaloCount == 0 ) THEN 4302 CALL Info('CreateInterfaceMeshes','Found no halo elements to eliminate',Level=15) 4303 DEALLOCATE( ActiveNode ) 4304 CheckForHalo = .FALSE. 4305 ELSE 4306 CALL Info('CreateInterfaceMeshes','Number of halo elements to eliminate: '& 4307 //TRIM(I2S(HaloCount)),Level=12) 4308 END IF 4309 END IF 4310 4311 4312! Search elements in this boundary and its periodic 4313! counterpart: 4314! -------------------------------------------------- 4315 n1 = 0 4316 n2 = 0 4317 HaloCount = 0 4318 DO i=1, Mesh % NumberOfBoundaryElements 4319 Element => Elements(i) 4320 ElemCode = Element % Type % ElementCode 4321 IF (ElemCode<=200) CYCLE 4322 4323 nSplit = 1 4324 IF( SplitQuadratic ) THEN 4325 IF( ElemCode == 306 .OR. ElemCode == 409 ) THEN 4326 nSplit = 4 4327 ELSE IF( ElemCode == 408 ) THEN 4328 nSplit = 5 4329 END IF 4330 END IF 4331 4332 Constraint = Element % BoundaryInfo % Constraint 4333 IF( Model % BCs(This) % Tag == Constraint ) THEN 4334 IF( CheckForHalo ) THEN 4335 IF( NarrowHalo ) THEN 4336 IF( ANY(ActiveNode(Element % NodeIndexes) ) ) THEN 4337 n1 = n1 + nSplit 4338 ELSE 4339 HaloCount = HaloCount + 1 4340 END IF 4341 ELSE IF( NoHalo ) THEN 4342 ThisActive = .FALSE. 4343 Left => Element % BoundaryInfo % Left 4344 IF( ASSOCIATED( Left ) ) THEN 4345 ThisActive = ( Left % PartIndex == ParEnv % MyPe ) 4346 END IF 4347 Right => Element % BoundaryInfo % Right 4348 IF( ASSOCIATED( Right ) ) THEN 4349 ThisActive = ThisActive .OR. & 4350 ( Right % PartIndex == ParEnv % MyPe ) 4351 END IF 4352 IF( ThisActive ) THEN 4353 n1 = n1 + nSplit 4354 ELSE 4355 HaloCount = HaloCount + 1 4356 END IF 4357 END IF 4358 ELSE 4359 n1 = n1 + nSplit 4360 END IF 4361 END IF 4362 4363 IF( OnTheFlyBC ) THEN 4364 IF( Trgt == Constraint ) n2 = n2 + nSplit 4365 ELSE 4366 IF ( Model % BCs(Trgt) % Tag == Constraint ) n2 = n2 + nSplit 4367 END IF 4368 END DO 4369 4370 IF( CheckForHalo ) THEN 4371 CALL Info('CreateInterfaceMeshes','Number of halo elements eliminated: '& 4372 //TRIM(I2S(HaloCount)),Level=12) 4373 END IF 4374 4375 IF ( n1 <= 0 .OR. n2 <= 0 ) THEN 4376 ! This is too conservative in parallel 4377 ! CALL Warn('CreateInterfaceMeshes','There are no active boundaries!') 4378 Success = .FALSE. 4379 RETURN 4380 END IF 4381 4382 4383! Initialize mesh structures for boundaries, this 4384! is for getting the mesh projector: 4385! ------------------------------------------------ 4386 BMesh1 % Parent => Mesh 4387 BMesh2 % Parent => Mesh 4388 4389 WRITE(Message,'(A,I0,A,I0)') 'Number of interface elements: ',n1,', ',n2 4390 CALL Info('CreateInterfaceMeshes',Message,Level=9) 4391 4392 CALL AllocateVector( BMesh1 % Elements,n1 ) 4393 CALL AllocateVector( BMesh2 % Elements,n2 ) 4394 CALL AllocateVector( Perm1, Mesh % NumberOfNodes ) 4395 CALL AllocateVector( Perm2, Mesh % NumberOfNodes ) 4396 4397 IF( TagNormalFlip ) THEN 4398 ALLOCATE( BMesh1 % PeriodicFlip(n1) ) 4399 ALLOCATE( BMesh2 % PeriodicFlip(n2) ) 4400 BMesh1 % PeriodicFlip = .FALSE. 4401 BMesh2 % PeriodicFlip = .FALSE. 4402 END IF 4403 4404 4405! Fill in the mesh element structures with the 4406! boundary elements: 4407! --------------------------------------------- 4408 n1 = 0 4409 n2 = 0 4410 Perm1 = 0 4411 Perm2 = 0 4412 BMesh1 % MaxElementNodes = 0 4413 BMesh2 % MaxElementNodes = 0 4414 4415 4416 DO i=1, Mesh % NumberOfBoundaryElements 4417 Element => Elements(i) 4418 4419 ElemCode = Element % Type % ElementCode 4420 IF (ElemCode <= 200) CYCLE 4421 4422 IF( TagNormalFlip ) THEN 4423 n = Element % TYPE % NumberOfNodes 4424 NodeIndexes => Element % NodeIndexes 4425 4426 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes(1:n)) 4427 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes(1:n)) 4428 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes(1:n)) 4429 4430 Normal = NormalVector( Element,ElementNodes,Check=.TRUE.,& 4431 Parent = Element % BoundaryInfo % Left, Turn = Turn ) 4432 END IF 4433 4434 nSplit = 1 4435 IF( SplitQuadratic ) THEN 4436 IF( ElemCode == 306 .OR. ElemCode == 409 ) THEN 4437 nSplit = 4 4438 ELSE IF( ElemCode == 408 ) THEN 4439 nSplit = 5 4440 END IF 4441 END IF 4442 4443 Constraint = Element % BoundaryInfo % Constraint 4444 4445 ThisActive = ( Model % BCs(This) % Tag == Constraint ) 4446 IF( ThisActive .AND. CheckForHalo ) THEN 4447 IF( NarrowHalo ) THEN 4448 IF( .NOT. ANY(ActiveNode(Element % NodeIndexes) ) ) THEN 4449 ThisActive = .FALSE. 4450 END IF 4451 ELSE IF( NoHalo ) THEN 4452 ThisActive = .FALSE. 4453 Left => Element % BoundaryInfo % Left 4454 IF( ASSOCIATED( Left ) ) THEN 4455 ThisActive = ( Left % PartIndex == ParEnv % MyPe ) 4456 END IF 4457 Right => Element % BoundaryInfo % Right 4458 IF( ASSOCIATED( Right ) ) THEN 4459 ThisActive = ThisActive .OR. & 4460 ( Right % PartIndex == ParEnv % MyPe ) 4461 END IF 4462 END IF 4463 END IF 4464 4465 IF( OnTheFlyBC ) THEN 4466 TargetActive = ( Trgt == Constraint ) 4467 ELSE 4468 TargetActive = ( Model % BCs(Trgt) % Tag == Constraint ) 4469 END IF 4470 4471 IF(.NOT. (ThisActive .OR. TargetActive ) ) CYCLE 4472 4473 ! Set the pointers accordingly so we need to code the complex stuff 4474 ! only once. 4475 IF ( ThisActive ) THEN 4476 n1 = n1 + nSplit 4477 ind = n1 4478 PMesh => BMesh1 4479 PPerm => Perm1 4480 ELSE 4481 n2 = n2 + nSplit 4482 ind = n2 4483 PMesh => BMesh2 4484 PPerm => Perm2 4485 END IF 4486 4487 4488 IF( nSplit > 1 ) THEN 4489 IF( ElemCode == 408 ) THEN 4490 SplitSizes(1:nSplit) = [ 4,3,3,3,3 ] 4491 DO ii=1,nSplit 4492 jj = ind-nSplit+ii 4493 m = SplitSizes(ii) 4494 4495 SELECT CASE (ii) 4496 CASE( 1 ) 4497 SplitMap(1:m) = [ 5,6,7,8 ] 4498 CASE( 2 ) 4499 SplitMap(1:m) = [ 1, 5, 8 ] 4500 CASE( 3 ) 4501 SplitMap(1:m) = [ 2, 6, 5 ] 4502 CASE( 4 ) 4503 SplitMap(1:m) = [ 3, 7, 6 ] 4504 CASE( 5 ) 4505 SplitMap(1:m) = [ 4, 8, 7 ] 4506 END SELECT 4507 4508 CALL AllocateVector(PMesh % Elements(jj) % NodeIndexes, m ) 4509 PMesh % Elements(jj) % NodeIndexes(1:m) = & 4510 Element % NodeIndexes(SplitMap(1:m)) 4511 PMesh % Elements(jj) % TYPE => GetElementType(101*m) 4512 IF( ThisActive ) THEN 4513 PMesh % Elements(jj) % BoundaryInfo => Element % BoundaryInfo 4514 END IF 4515 END DO 4516 PMesh % MaxElementNodes = MAX( PMesh % MaxElementNodes, 4 ) 4517 4518 ELSE IF( ElemCode == 409 ) THEN 4519 SplitSizes(1:n) = [ 4,4,4,4 ] 4520 DO ii=1,nSplit 4521 jj = ind-nSplit+ii 4522 m = SplitSizes(ii) 4523 4524 SELECT CASE (ii) 4525 CASE( 1 ) 4526 SplitMap(1:m) = [ 1, 5, 9, 8 ] 4527 CASE( 2 ) 4528 SplitMap(1:m) = [ 2, 6, 9, 5 ] 4529 CASE( 3 ) 4530 SplitMap(1:m) = [ 3, 7, 9, 6 ] 4531 CASE( 4 ) 4532 SplitMap(1:m) = [ 4, 8, 9, 7 ] 4533 END SELECT 4534 4535 CALL AllocateVector(PMesh % Elements(jj) % NodeIndexes, m ) 4536 PMesh % Elements(jj) % NodeIndexes(1:m) = & 4537 Element % NodeIndexes(SplitMap(1:m)) 4538 PMesh % Elements(jj) % TYPE => GetElementType(101*m) 4539 IF( ThisActive ) THEN 4540 PMesh % Elements(jj) % BoundaryInfo => Element % BoundaryInfo 4541 END IF 4542 END DO 4543 PMesh % MaxElementNodes = MAX( PMesh % MaxElementNodes, 4 ) 4544 4545 ELSE IF( ElemCode == 306 ) THEN 4546 SplitSizes(1:n) = [ 3,3,3,3 ] 4547 DO ii=1,nSplit 4548 jj = ind-nSplit+ii 4549 m = SplitSizes(ii) 4550 4551 SELECT CASE (ii) 4552 CASE( 1 ) 4553 SplitMap(1:m) = [ 1, 4, 6 ] 4554 CASE( 2 ) 4555 SplitMap(1:m) = [ 2, 5, 4 ] 4556 CASE( 3 ) 4557 SplitMap(1:m) = [ 3, 6, 5 ] 4558 CASE( 4 ) 4559 SplitMap(1:m) = [ 4, 5, 6 ] 4560 END SELECT 4561 4562 CALL AllocateVector(PMesh % Elements(j) % NodeIndexes, m ) 4563 PMesh % Elements(jj) % NodeIndexes(1:m) = & 4564 Element % NodeIndexes(SplitMap(1:m)) 4565 PMesh % Elements(jj) % TYPE => GetElementType(101*m) 4566 IF( ThisActive ) THEN 4567 PMesh % Elements(jj) % BoundaryInfo => Element % BoundaryInfo 4568 END IF 4569 END DO 4570 PMesh % MaxElementNodes = MAX( PMesh % MaxElementNodes, 3 ) 4571 END IF 4572 n = Element % TYPE % NumberOfNodes 4573 PPerm( Element % NodeIndexes(1:n) ) = 1 4574 4575 ELSE 4576 n = Element % TYPE % NumberOfNodes 4577 PMesh % MaxElementNodes = MAX( PMesh % MaxElementNodes, n ) 4578 PMesh % Elements(ind) = Element 4579 4580 IF( TagNormalFlip ) THEN 4581 PMesh % PeriodicFlip(ind) = Turn 4582 END IF 4583 4584 CALL AllocateVector(PMesh % Elements(ind) % NodeIndexes,n ) 4585 4586 IF( Mesh % NumberOfFaces == 0 .OR. Mesh % NumberOfEdges == 0 ) THEN 4587 PMesh % Elements(ind) % NodeIndexes(1:n) = Element % NodeIndexes(1:n) 4588 PPerm( Element % NodeIndexes(1:n) ) = 1 4589 ELSE 4590 ! If we have edge dofs we want the face element be associated with the 4591 ! face list since that only has properly defined edge indexes. 4592 Parent => Element % BoundaryInfo % Left 4593 IF(.NOT. ASSOCIATED( Parent ) ) THEN 4594 Parent => Element % BoundaryInfo % Right 4595 END IF 4596 4597 q => Find_Face(Mesh,Parent,Element) 4598 4599 PMesh % Elements(ind) % NodeIndexes(1:n) = q % NodeIndexes(1:n) 4600 4601 ! set the elementindex to be faceindex as it may be needed 4602 ! for the edge elements. 4603 PMesh % Elements(ind) % ElementIndex = q % ElementIndex 4604 4605 IF(ASSOCIATED(q % Pdefs)) THEN 4606 ALLOCATE(Pmesh % Elements(ind) % Pdefs) 4607 PMesh % Elements(ind) % PDefs = q % Pdefs 4608 END IF 4609 4610 ! Set also the owner partition 4611 ! PMesh % Elements(ind) % PartIndex = q % PartIndex 4612 4613 en = q % TYPE % NumberOfEdges 4614 ALLOCATE(PMesh % Elements(ind) % EdgeIndexes(en)) 4615 Pmesh % Elements(ind) % EdgeIndexes(1:en) = q % EdgeIndexes(1:en) 4616 4617 PPerm( q % NodeIndexes(1:n) ) = 1 4618 END IF 4619 END IF 4620 4621 4622 END DO 4623 4624! Fill in the mesh node structures with the 4625! boundary nodes: 4626! ----------------------------------------- 4627 BMesh1 % NumberOfBulkElements = n1 4628 BMesh2 % NumberOfBulkElements = n2 4629 4630 BMesh2 % NumberOfNodes = COUNT(Perm2 > 0) 4631 BMesh1 % NumberOfNodes = COUNT(Perm1 > 0) 4632 4633 ! As there were some active boundary elements this condition should 4634 ! really never be possible 4635 IF (BMesh1 % NumberOfNodes==0 .OR. BMesh2 % NumberOfNOdes==0) THEN 4636 CALL Fatal('CreateInterfaceMeshes','No active nodes on periodic boundary!') 4637 END IF 4638 4639 WRITE(Message,'(A,I0,A,I0)') 'Number of interface nodes: ',& 4640 BMesh1 % NumberOfNodes, ', ',BMesh2 % NumberOfNOdes 4641 CALL Info('CreateInterfaceMeshes',Message,Level=9) 4642 4643 ALLOCATE( BMesh1 % Nodes ) 4644 CALL AllocateVector( BMesh1 % Nodes % x, BMesh1 % NumberOfNodes ) 4645 CALL AllocateVector( BMesh1 % Nodes % y, BMesh1 % NumberOfNodes ) 4646 CALL AllocateVector( BMesh1 % Nodes % z, BMesh1 % NumberOfNodes ) 4647 4648 ALLOCATE( BMesh2 % Nodes ) 4649 CALL AllocateVector( BMesh2 % Nodes % x, BMesh2 % NumberOfNodes ) 4650 CALL AllocateVector( BMesh2 % Nodes % y, BMesh2 % NumberOfNodes ) 4651 CALL AllocateVector( BMesh2 % Nodes % z, BMesh2 % NumberOfNodes ) 4652 4653 CALL AllocateVector( Bmesh1 % InvPerm, BMesh1 % NumberOfNodes ) 4654 CALL AllocateVector( Bmesh2 % InvPerm, BMesh2 % NumberOfNodes ) 4655 4656 ! Now, create the master and target meshes that only include the active elements 4657 !--------------------------------------------------------------------------- 4658 k1 = 0; k2 = 0 4659 DO i=1,Mesh % NumberOfNodes 4660 4661 IF ( Perm1(i) > 0 ) THEN 4662 k1 = k1 + 1 4663 Perm1(i) = k1 4664 BMesh1 % InvPerm(k1) = i 4665 4666 BMesh1 % Nodes % x(k1) = Mesh % Nodes % x(i) 4667 BMesh1 % Nodes % y(k1) = Mesh % Nodes % y(i) 4668 BMesh1 % Nodes % z(k1) = Mesh % Nodes % z(i) 4669 END IF 4670 4671 IF ( Perm2(i) > 0 ) THEN 4672 k2 = k2 + 1 4673 Perm2(i) = k2 4674 BMesh2 % InvPerm(k2) = i 4675 4676 BMesh2 % Nodes % x(k2) = Mesh % Nodes % x(i) 4677 BMesh2 % Nodes % y(k2) = Mesh % Nodes % y(i) 4678 BMesh2 % Nodes % z(k2) = Mesh % Nodes % z(i) 4679 END IF 4680 END DO 4681 4682! Finally, Renumber the element node pointers to use 4683! only boundary nodes: 4684! --------------------------------------------------- 4685 4686 DO i=1,n1 4687 BMesh1 % Elements(i) % NodeIndexes = Perm1(BMesh1 % Elements(i) % NodeIndexes) 4688 END DO 4689 4690 DO i=1,n2 4691 BMesh2 % Elements(i) % NodeIndexes = Perm2(BMesh2 % Elements(i) % NodeIndexes) 4692 END DO 4693 DEALLOCATE( Perm1, Perm2 ) 4694 4695 IF( CheckForHalo ) DEALLOCATE( ActiveNode ) 4696 4697 Success = .TRUE. 4698 4699 END SUBROUTINE CreateInterfaceMeshes 4700 !--------------------------------------------------------------------------- 4701 4702 4703 !--------------------------------------------------------------------------- 4704 !> Given two meshes that should occupy the same domain in space 4705 !> use rotation, scaling and translation to achieve this goal. 4706 !--------------------------------------------------------------------------- 4707 SUBROUTINE OverlayIntefaceMeshes(BMesh1, BMesh2, BParams ) 4708 !--------------------------------------------------------------------------- 4709 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 4710 TYPE(Valuelist_t), POINTER :: BParams 4711 !-------------------------------------------------------------------------- 4712 LOGICAL :: GotIt, GotRotate 4713 REAL(KIND=dp) :: x1_min(3),x1_max(3),x2_min(3),x2_max(3),x2r_min(3),x2r_max(3) 4714 REAL(KIND=dp) :: x(4), RotMatrix(4,4),TrsMatrix(4,4),SclMatrix(4,4), & 4715 TrfMatrix(4,4),Identity(4,4),Angles(3),Alpha,scl(3),s1,s2 4716 REAL(KIND=dp), POINTER :: PArray(:,:) 4717 INTEGER :: i,j,k 4718 4719 ! First, check the bounding boxes 4720 !--------------------------------------------------------------------------- 4721 x1_min(1) = MINVAL( BMesh1 % Nodes % x ) 4722 x1_min(2) = MINVAL( BMesh1 % Nodes % y ) 4723 x1_min(3) = MINVAL( BMesh1 % Nodes % z ) 4724 4725 x1_max(1) = MAXVAL( BMesh1 % Nodes % x ) 4726 x1_max(2) = MAXVAL( BMesh1 % Nodes % y ) 4727 x1_max(3) = MAXVAL( BMesh1 % Nodes % z ) 4728 4729 WRITE(Message,'(A,3ES15.6)') 'Minimum values for this periodic BC: ',x1_min 4730 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4731 WRITE(Message,'(A,3ES15.6)') 'Maximum values for this periodic BC: ',x1_max 4732 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4733 4734 x2_min(1) = MINVAL( BMesh2 % Nodes % x ) 4735 x2_min(2) = MINVAL( BMesh2 % Nodes % y ) 4736 x2_min(3) = MINVAL( BMesh2 % Nodes % z ) 4737 4738 x2_max(1) = MAXVAL( BMesh2 % Nodes % x ) 4739 x2_max(2) = MAXVAL( BMesh2 % Nodes % y ) 4740 x2_max(3) = MAXVAL( BMesh2 % Nodes % z ) 4741 4742 WRITE(Message,'(A,3ES15.6)') 'Minimum values for target periodic BC:',x2_min 4743 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4744 WRITE(Message,'(A,3ES15.6)') 'Maximum values for target periodic BC:',x2_max 4745 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4746 4747! If whole transformation matrix given, it will be used directly 4748! -------------------------------------------------------------- 4749 Parray => ListGetConstRealArray( BParams,'Periodic BC Matrix', Gotit ) 4750 IF ( GotIt ) THEN 4751 DO i=1,SIZE(Parray,1) 4752 DO j=1,SIZE(Parray,2) 4753 TrfMatrix(i,j) = Parray(j,i) 4754 END DO 4755 END DO 4756 ELSE 4757 ! Otherwise check for rotation, scaling and translation 4758 !------------------------------------------------------ 4759 4760 ! Initialize the mapping matrices 4761 Identity = 0.0d0 4762 DO i=1,4 4763 Identity(i,i) = 1.0d0 4764 END DO 4765 TrsMatrix = Identity 4766 RotMatrix = Identity 4767 SclMatrix = Identity 4768 4769 ! Rotations: 4770 ! These are called first since they are not accounted for in the 4771 ! automatic scaling and translation. 4772 ! --------------------------------------------------------------- 4773 Angles = 0.0_dp 4774 Parray => ListGetConstRealArray( BParams,'Periodic BC Rotate', GotRotate ) 4775 IF( GotRotate ) THEN 4776 Angles(1:3) = Parray(1:3,1) 4777 ELSE 4778 IF( ListGetLogical( BParams,'Periodic BC Rotate Automatic', GotIt) ) THEN 4779 CALL CheckInterfaceMeshAngle( BMesh1, BMesh2, Angles, GotRotate ) 4780 END IF 4781 END IF 4782 4783 IF ( GotRotate ) THEN 4784 WRITE(Message,'(A,3ES15.6)') 'Rotating target with: ',Angles 4785 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4786 4787 DO i=1,3 4788 Alpha = Angles(i) * PI / 180.0_dp 4789 IF( ABS(Alpha) < TINY(Alpha) ) CYCLE 4790 TrfMatrix = Identity 4791 4792 SELECT CASE(i) 4793 CASE(1) 4794 TrfMatrix(2,2) = COS(Alpha) 4795 TrfMatrix(2,3) = -SIN(Alpha) 4796 TrfMatrix(3,2) = SIN(Alpha) 4797 TrfMatrix(3,3) = COS(Alpha) 4798 CASE(2) 4799 TrfMatrix(1,1) = COS(Alpha) 4800 TrfMatrix(1,3) = -SIN(Alpha) 4801 TrfMatrix(3,1) = SIN(Alpha) 4802 TrfMatrix(3,3) = COS(Alpha) 4803 CASE(3) 4804 TrfMatrix(1,1) = COS(Alpha) 4805 TrfMatrix(1,2) = -SIN(Alpha) 4806 TrfMatrix(2,1) = SIN(Alpha) 4807 TrfMatrix(2,2) = COS(Alpha) 4808 END SELECT 4809 4810 RotMatrix = MATMUL( RotMatrix, TrfMatrix ) 4811 END DO 4812 4813 DO i = 1, BMesh2 % NumberOfNodes 4814 x(1) = BMesh2 % Nodes % x(i) 4815 x(2) = BMesh2 % Nodes % y(i) 4816 x(3) = BMesh2 % Nodes % z(i) 4817 4818 x(4) = 1.0_dp 4819 x = MATMUL( RotMatrix, x ) 4820 4821 BMesh2 % Nodes % x(i) = x(1) 4822 BMesh2 % Nodes % y(i) = x(2) 4823 BMesh2 % Nodes % z(i) = x(3) 4824 END DO 4825 4826 x2r_min(1) = MINVAL( BMesh2 % Nodes % x ) 4827 x2r_min(2) = MINVAL( BMesh2 % Nodes % y ) 4828 x2r_min(3) = MINVAL( BMesh2 % Nodes % z ) 4829 4830 x2r_max(1) = MAXVAL( BMesh2 % Nodes % x ) 4831 x2r_max(2) = MAXVAL( BMesh2 % Nodes % y ) 4832 x2r_max(3) = MAXVAL( BMesh2 % Nodes % z ) 4833 4834 WRITE(Message,'(A,3ES15.6)') 'Minimum values for rotated target:',x2r_min 4835 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4836 4837 WRITE(Message,'(A,3ES15.6)') 'Maximum values for rotated target:',x2r_max 4838 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4839 ELSE 4840 x2r_min = x2_min 4841 x2r_max = x2_max 4842 END IF 4843 4844! Scaling: 4845! This is either given or enforced by requiring bounding boxes to be of the same size 4846! ----------------------------------------------------------------------------------- 4847 Parray => ListGetConstRealArray( BParams,'Periodic BC Scale', Gotit ) 4848 IF ( GotIt ) THEN 4849 DO i=1,SIZE(Parray,1) 4850 SclMatrix(i,i) = Parray(i,1) 4851 END DO 4852 ELSE 4853 ! Define scaling from the bounding boxes 4854 ! This assumes isotropic scaling since component-wise scaling 4855 ! was prone to errors. 4856 !------------------------------------------------------ 4857 s1 = SUM( ( x1_max(1:3) - x1_min(1:3) ) ** 2 ) 4858 s2 = SUM( ( x2r_max(1:3) - x2r_min(1:3) ) ** 2 ) 4859 IF( s2 > EPSILON( s2 ) ) THEN 4860 scl(1:3) = SQRT( s1 / s2 ) 4861 ELSE 4862 scl(1:3) = 1.0_dp 4863 END IF 4864 4865 WRITE(Message,'(A,3ES15.6)') 'Scaling with: ',scl(1:3) 4866 CALL Info('OverlayInterfaceMeshes',Message) 4867 DO i=1,3 4868 SclMatrix(i,i) = scl(i) 4869 END DO 4870 END IF 4871 4872! Translations: 4873! And finally define translations 4874! ------------- 4875 Parray => ListGetConstRealArray( BParams,'Periodic BC Translate', Gotit ) 4876 IF ( gotit ) THEN 4877 DO i=1,SIZE(Parray,1) 4878 TrsMatrix(4,i) = Parray(i,1) 4879 END DO 4880 ELSE 4881 ! Define translations so that the lower left corner is the same 4882 !------------------------------------------------------------- 4883 DO i=1,3 4884 TrsMatrix(4,i) = x1_min(i) - SclMatrix(i,i) * x2r_min(i) 4885 END DO 4886 END IF 4887 WRITE(Message,'(A,3ES15.6)') 'Translation: ',TrsMatrix(4,1:3) 4888 CALL Info('OverlayInterfaceMeshes',Message) 4889 TrfMatrix = MATMUL( SclMatrix, TrsMatrix ) 4890 END IF 4891 4892! Now transform the coordinates: 4893! ------------------------------ 4894 DO i=1,BMesh2 % NumberOfNodes 4895 x(1) = BMesh2 % Nodes % x(i) 4896 x(2) = BMesh2 % Nodes % y(i) 4897 x(3) = BMesh2 % Nodes % z(i) 4898 x(4) = 1.0d0 4899 x = MATMUL( x, TrfMatrix ) 4900 BMesh2 % Nodes % x(i) = x(1) / x(4) 4901 BMesh2 % Nodes % y(i) = x(2) / x(4) 4902 BMesh2 % Nodes % z(i) = x(3) / x(4) 4903 END DO 4904 4905 IF(.FALSE.) THEN 4906 x2r_min(1) = MINVAL( BMesh2 % Nodes % x ) 4907 x2r_min(2) = MINVAL( BMesh2 % Nodes % y ) 4908 x2r_min(3) = MINVAL( BMesh2 % Nodes % z ) 4909 4910 x2r_max(1) = MAXVAL( BMesh2 % Nodes % x ) 4911 x2r_max(2) = MAXVAL( BMesh2 % Nodes % y ) 4912 x2r_max(3) = MAXVAL( BMesh2 % Nodes % z ) 4913 4914 WRITE(Message,'(A,3ES15.6)') 'Minimum values for transformed target:',x2r_min 4915 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4916 4917 WRITE(Message,'(A,3ES15.6)') 'Maximum values for transformed target:',x2r_max 4918 CALL Info('OverlayInterfaceMeshes',Message,Level=8) 4919 END IF 4920 4921 END SUBROUTINE OverlayIntefaceMeshes 4922 !--------------------------------------------------------------------------- 4923 4924 4925 4926 !--------------------------------------------------------------------------- 4927 !> Given two interface meshes for nonconforming rotating boundaries make 4928 !> a coordinate transformation to each node of the slave boundary (BMesh1) so that 4929 !> they hit the master boundary (BMesh2). In case of anti-periodic projector 4930 !> mark the nodes that need an odd number of periods. 4931 !--------------------------------------------------------------------------- 4932 SUBROUTINE PreRotationalProjector(BMesh1, BMesh2, MirrorNode ) 4933 !--------------------------------------------------------------------------- 4934 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 4935 LOGICAL, ALLOCATABLE :: MirrorNode(:) 4936 !-------------------------------------------------------------------------- 4937 LOGICAL :: AntiPeriodic 4938 REAL(KIND=dp) :: F2min,F2max,dFii2,Fii 4939 INTEGER :: i, Nfii, SectorMax 4940 INTEGER, ALLOCATABLE :: SectorCount(:) 4941 4942 AntiPeriodic = ALLOCATED( MirrorNode ) 4943 IF( AntiPeriodic ) MirrorNode = .FALSE. 4944 4945 F2Min = MINVAL( BMesh2 % Nodes % x ) 4946 F2Max = MAXVAL( BMesh2 % Nodes % x ) 4947 dFii2 = F2Max - F2Min 4948 SectorMax = CEILING( 360.0_dp / dFii2 ) 4949 4950 WRITE( Message,'(A,I0)') 'Maximum number of sectors: ',SectorMax 4951 CALL Info('PreRotationalProjector',Message,Level=8) 4952 4953 ALLOCATE( SectorCount(-SectorMax:SectorMax)) 4954 SectorCount = 0 4955 4956 DO i = 1, BMesh1 % NumberOfNodes 4957 Fii = BMesh1 % Nodes % x(i) 4958 Nfii = FLOOR( (Fii-F2min) / dFii2 ) 4959 BMesh1 % Nodes % x(i) = BMesh1 % Nodes % x(i) - Nfii * dFii2 4960 SectorCount(Nfii) = SectorCount(Nfii) + 1 4961 IF( AntiPeriodic ) THEN 4962 IF( MODULO(Nfii,2) /= 0 ) THEN 4963 MirrorNode(i) = .TRUE. 4964 END IF 4965 END IF 4966 END DO 4967 4968 IF( SectorCount(0) < BMesh1 % NumberOfNodes ) THEN 4969 CALL Info('PreRotationalProjector','Number of nodes by sectors',Level=8) 4970 DO i=-SectorMax,SectorMax 4971 IF( SectorCount(i) > 0 ) THEN 4972 WRITE( Message,'(A,I0,A,I0)') 'Sector:',i,' Nodes:',SectorCount(i) 4973 CALL Info('PreRotationalProjector',Message,Level=8) 4974 END IF 4975 END DO 4976 IF( AntiPeriodic ) THEN 4977 WRITE( Message,'(A,I0)') 'Number of mirror nodes:',COUNT(MirrorNode) 4978 CALL Info('PreRotationalProjector',Message,Level=8) 4979 END IF 4980 ELSE 4981 CALL Info('PreRotationalProjector','No nodes needed mapping') 4982 END IF 4983 4984 END SUBROUTINE PreRotationalProjector 4985!------------------------------------------------------------------------------ 4986 4987 4988!------------------------------------------------------------------------------ 4989!> Postprocess projector so that it changes the sign of the anti-periodic 4990!> entries as assigns by the MirrorNode flag. 4991!------------------------------------------------------------------------------ 4992 SUBROUTINE PostRotationalProjector( Proj, MirrorNode ) 4993!------------------------------------------------------------------------------ 4994 TYPE(Matrix_t) :: Proj !< Projection matrix 4995 LOGICAL, ALLOCATABLE :: MirrorNode(:) !< Is the node a mirror node or not 4996!-------------------------------------------------------------------------- 4997 INTEGER, POINTER :: Cols(:),Rows(:) 4998 REAL(KIND=dp), POINTER :: Values(:) 4999 INTEGER :: i,j,n 5000!------------------------------------------------------------------------------ 5001 5002 IF( .NOT. ALLOCATED( MirrorNode ) ) RETURN 5003 IF( COUNT( MirrorNode ) == 0 ) RETURN 5004 5005 n = Proj % NumberOfRows 5006 Rows => Proj % Rows 5007 Cols => Proj % Cols 5008 Values => Proj % Values 5009 5010 DO i=1,n 5011 IF( MirrorNode(i) ) THEN 5012 DO j = Rows(i),Rows(i+1)-1 5013 Values(j) = -Values(j) 5014 END DO 5015 END IF 5016 END DO 5017 5018!------------------------------------------------------------------------------ 5019 END SUBROUTINE PostRotationalProjector 5020!------------------------------------------------------------------------------ 5021 5022!------------------------------------------------------------------------------ 5023 FUNCTION Find_Face(Mesh,Parent,Element) RESULT(ptr) 5024!------------------------------------------------------------------------------ 5025 TYPE(Element_t), POINTER :: Ptr 5026 TYPE(Mesh_t) :: Mesh 5027 TYPE(Element_t) :: Parent, Element 5028 5029 INTEGER :: i,j,k,n 5030 5031 Ptr => NULL() 5032 DO i=1,Parent % TYPE % NumberOfFaces 5033 Ptr => Mesh % Faces(Parent % FaceIndexes(i)) 5034 n=0 5035 DO j=1,Ptr % TYPE % NumberOfNodes 5036 DO k=1,Element % TYPE % NumberOfNodes 5037 IF (Ptr % NodeIndexes(j) == Element % NodeIndexes(k)) n=n+1 5038 END DO 5039 END DO 5040 IF (n==Ptr % TYPE % NumberOfNodes) EXIT 5041 END DO 5042!------------------------------------------------------------------------------ 5043 END FUNCTION Find_Face 5044!------------------------------------------------------------------------------ 5045 5046 !---------------------------------------------------------------------------------------- 5047 !> Given a temporal triangle "ElementT", calculate mass matrix contributions for projection 5048 !> for the slave element "Element" and master element "ElementM". 5049 !> The nubmering associated to these surface meshes is InvPerm and InvPermM, respectively. 5050 !> This is lifted at an outer level in the hope that it would be called by number of 5051 !> routines in the future. 5052 !---------------------------------------------------------------------------------------- 5053 SUBROUTINE TemporalTriangleMortarAssembly(ElementT, NodesT, Element, Nodes, ElementM, NodesM, & 5054 Biorthogonal, DualMaster, DualLCoeff, NoGaussPoints, Projector, NodeScale, & 5055 NodePerm, InvPerm, InvPermM, SumArea ) 5056 !---------------------------------------------------------------------------------------- 5057 TYPE(Element_t) :: ElementT 5058 TYPE(Element_t), POINTER :: Element, ElementM 5059 TYPE(Nodes_t) :: NodesT, Nodes, NodesM 5060 LOGICAL :: Biorthogonal, DualMaster, DualLCoeff 5061 INTEGER :: NoGaussPoints 5062 TYPE(Matrix_t) :: Projector 5063 REAL(KIND=dp) :: NodeScale, SumArea 5064 INTEGER, POINTER :: NodePerm(:), InvPerm(:), InvPermM(:) 5065 !---------------------------------------------------------------------------------------- 5066 5067 TYPE(Element_t), POINTER :: ElementP, ElementLin 5068 TYPE(GaussIntegrationPoints_t) :: IPT 5069 REAL(KIND=dp) :: area, xt, yt, zt = 0.0_dp, u, v, w, um, vm, wm, & 5070 detJ, val, val_dual, weight 5071 REAL(KIND=dp), ALLOCATABLE :: BasisT(:),Basis(:), BasisM(:), MASS(:,:), CoeffBasis(:) 5072 INTEGER :: i,j,jj,n,ne,nM,neM,ElemCode,LinCode,ElemCodeM,LinCodeM,nip,nrow,AllocStat 5073 INTEGER, POINTER :: Indexes(:),IndexesM(:) 5074 LOGICAL :: Stat, AllocationsDone = .FALSE. 5075 5076 SAVE :: BasisT, Basis, BasisM, CoeffBasis, MASS 5077 5078 IF(.NOT. AllocationsDone ) THEN 5079 n = CurrentModel % Mesh % MaxElementNodes 5080 ALLOCATE( BasisT(3),Basis(n), BasisM(n), CoeffBasis(n), MASS(n,n), STAT = AllocStat ) 5081 IF( AllocStat /= 0 ) CALL Fatal('TemporalTriangleMortarAssembly','Allocation error!') 5082 AllocationsDone = .TRUE. 5083 END IF 5084 5085 5086 n = Element % TYPE % NumberOfNodes 5087 ne = Element % TYPE % ElementCode / 100 5088 ElemCode = Element % TYPE % ElementCode 5089 LinCode = 101 * ne 5090 Indexes => Element % NodeIndexes 5091 5092 nM = ElementM % TYPE % NumberOfNodes 5093 neM = ElementM % TYPE % ElementCode / 100 5094 ElemCodeM = Element % TYPE % ElementCode 5095 LinCodeM = 101 * neM 5096 IndexesM => ElementM % NodeIndexes 5097 5098 IF( NoGaussPoints > 0 ) THEN 5099 IPT = GaussPoints( ElementT, NoGaussPoints, PreferenceElement = .FALSE. ) 5100 ELSE 5101 IPT = GaussPoints( ElementT, PreferenceElement = .FALSE. ) 5102 END IF 5103 5104 IF(BiOrthogonal) THEN 5105 MASS = 0 5106 CoeffBasis = 0 5107 area = 0._dp 5108 DO nip=1, IPT % n 5109 stat = ElementInfo( ElementT,NodesT,IPT % u(nip),& 5110 IPT % v(nip),IPT % w(nip),detJ,BasisT) 5111 IF(.NOT. Stat ) EXIT 5112 5113 ! We will actually only use the global coordinates and the integration weight 5114 ! from the temporal mesh. 5115 5116 ! Global coordinates of the integration point 5117 xt = SUM( BasisT(1:3) * NodesT % x(1:3) ) 5118 yt = SUM( BasisT(1:3) * NodesT % y(1:3) ) 5119 5120 ! Integration weight for current integration point 5121 Weight = DetJ * IPT % s(nip) 5122 area = area + weight 5123 5124 ! Integration point at the slave element 5125 IF( ElemCode /= LinCode ) THEN 5126 ElementLin % TYPE => GetElementType( LinCode, .FALSE. ) 5127 ElementLin % NodeIndexes => Element % NodeIndexes 5128 ElementP => ElementLin 5129 CALL GlobalToLocal( u, v, w, xt, yt, zt, ElementP, Nodes ) 5130 ELSE 5131 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 5132 END IF 5133 5134 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 5135 IF(.NOT. Stat) CYCLE 5136 5137 DO i=1,n 5138 DO j=1,n 5139 MASS(i,j) = MASS(i,j) + weight * Basis(i) * Basis(j) 5140 END DO 5141 CoeffBasis(i) = CoeffBasis(i) + Weight * Basis(i) 5142 END DO 5143 END DO 5144 5145 ! Even if there would be multiple ip points, area is still the same... 5146 IF(Area<1.d-12) RETURN 5147 5148 CALL InvertMatrix( MASS, n ) 5149 5150 DO i=1,n 5151 DO j=1,n 5152 MASS(i,j) = MASS(i,j) * CoeffBasis(i) 5153 END DO 5154 END DO 5155 END IF 5156 5157 ! Integration over the temporal element using integration points of that element 5158 DO nip=1, IPT % n 5159 stat = ElementInfo( ElementT,NodesT,IPT % u(nip),& 5160 IPT % v(nip),IPT % w(nip),detJ,BasisT) 5161 IF(.NOT. Stat) EXIT 5162 5163 ! We will actually only use the global coordinates and the integration weight 5164 ! from the temporal mesh. 5165 5166 ! Global coordinates of the integration point 5167 xt = SUM( BasisT(1:3) * NodesT % x(1:3) ) 5168 yt = SUM( BasisT(1:3) * NodesT % y(1:3) ) 5169 5170 ! Integration weight for current integration point 5171 weight = DetJ * IPT % s(nip) 5172 sumarea = sumarea + weight 5173 5174 ! Integration point at the slave element 5175 IF( ElemCode /= LinCode ) THEN 5176 ElementLin % TYPE => GetElementType( LinCode, .FALSE. ) 5177 ElementLin % NodeIndexes => Element % NodeIndexes 5178 ElementP => ElementLin 5179 CALL GlobalToLocal( u, v, w, xt, yt, zt, ElementP, Nodes ) 5180 ELSE 5181 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 5182 END IF 5183 5184 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 5185 5186 ! Integration point at the master element 5187 IF( ElemCodeM /= LinCodeM ) THEN 5188 ElementLin % TYPE => GetElementType( LinCodeM, .FALSE. ) 5189 ElementLin % NodeIndexes => ElementM % NodeIndexes 5190 ElementP => ElementLin 5191 CALL GlobalToLocal( um, vm, wm, xt, yt, zt, ElementP, NodesM ) 5192 ELSE 5193 CALL GlobalToLocal( um, vm, wm, xt, yt, zt, ElementM, NodesM ) 5194 END IF 5195 5196 stat = ElementInfo( ElementM, NodesM, um, vm, wm, detJ, BasisM ) 5197 IF(.NOT. Stat) CYCLE 5198 5199 ! Add the nodal dofs 5200 IF(BiOrthogonal) THEN 5201 CoeffBasis = 0._dp 5202 DO i=1,n 5203 DO j=1,n 5204 CoeffBasis(i) = CoeffBasis(i) + MASS(i,j) * Basis(j) 5205 END DO 5206 END DO 5207 END IF 5208 5209 DO j=1,n 5210 jj = Indexes(j) 5211 5212 nrow = NodePerm(InvPerm(jj)) 5213 IF( nrow == 0 ) CYCLE 5214 5215 Projector % InvPerm(nrow) = InvPerm(jj) 5216 val = Basis(j) * weight 5217 IF(Biorthogonal) val_dual = CoeffBasis(j) * weight 5218 5219 DO i=1,n 5220 IF( ABS( val * Basis(i) ) < 1.0d-10 ) CYCLE 5221 5222 !Nslave = Nslave + 1 5223 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 5224 InvPerm(Indexes(i)), Basis(i) * val ) 5225 5226 IF(BiOrthogonal) THEN 5227 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 5228 InvPerm(Indexes(i)), Basis(i) * val_dual ) 5229 END IF 5230 END DO 5231 5232 DO i=1,nM 5233 IF( ABS( val * BasisM(i) ) < 1.0d-12 ) CYCLE 5234 5235 !Nmaster = Nmaster + 1 5236 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 5237 InvPermM(IndexesM(i)), -NodeScale * BasisM(i) * val ) 5238 5239 IF(BiOrthogonal) THEN 5240 IF(DualMaster .OR. DualLCoeff) THEN 5241 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 5242 InvPermM(IndexesM(i)), -NodeScale * BasisM(i) * val_dual ) 5243 ELSE 5244 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 5245 InvPermM(IndexesM(i)), -NodeScale * BasisM(i) * val ) 5246 END IF 5247 END IF 5248 END DO 5249 END DO 5250 END DO 5251 5252 END SUBROUTINE TemporalTriangleMortarAssembly 5253 5254 5255 !--------------------------------------------------------------------------- 5256 !> Create a projector for mapping between interfaces using the Galerkin method 5257 !> A temporal mesh structure with a node for each Gaussian integration point is 5258 !> created. Then this projector matrix is transferred to a projector on the nodal 5259 !> coordinates. 5260 !--------------------------------------------------------------------------- 5261 FUNCTION NormalProjector(BMesh2, BMesh1, BC) RESULT ( Projector ) 5262 !--------------------------------------------------------------------------- 5263 USE Lists 5264 5265 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 5266 TYPE(ValueList_t), POINTER :: BC 5267 TYPE(Matrix_t), POINTER :: Projector 5268 !-------------------------------------------------------------------------- 5269 INTEGER, POINTER :: InvPerm1(:), InvPerm2(:) 5270 INTEGER, POINTER :: Rows(:),Cols(:) 5271 REAL(KIND=dp), POINTER :: Values(:) 5272 TYPE(Mesh_t), POINTER :: Mesh 5273 TYPE(Matrix_t), POINTER :: DualProjector 5274 LOGICAL :: Found, Parallel, BiOrthogonalBasis, & 5275 CreateDual, DualSlave, DualMaster, DualLCoeff 5276 REAL(KIND=dp) :: NodeScale 5277 INTEGER, POINTER :: NodePerm(:) 5278 TYPE(Element_t), POINTER :: Element 5279 INTEGER :: i,n,m 5280 5281 CALL Info('NormalProjector','Creating projector between 3D surfaces',Level=7) 5282 5283 Parallel = ( ParEnv % PEs > 1 ) 5284 Mesh => CurrentModel % Mesh 5285 BMesh1 % Parent => NULL() 5286 BMesh2 % Parent => NULL() 5287 5288 InvPerm1 => BMesh1 % InvPerm 5289 InvPerm2 => BMesh2 % InvPerm 5290 5291 ! Create a list matrix that allows for unspecified entries in the matrix 5292 ! structure to be introduced. 5293 Projector => AllocateMatrix() 5294 Projector % FORMAT = MATRIX_LIST 5295 Projector % ProjectorType = PROJECTOR_TYPE_GALERKIN 5296 5297 CreateDual = ListGetLogical( BC,'Create Dual Projector',Found ) 5298 IF( CreateDual ) THEN 5299 DualProjector => AllocateMatrix() 5300 DualProjector % FORMAT = MATRIX_LIST 5301 DualProjector % ProjectorType = PROJECTOR_TYPE_GALERKIN 5302 Projector % EMatrix => DualProjector 5303 END IF 5304 5305 ! Check whether biorthogonal basis for projectors requested: 5306 ! ---------------------------------------------------------- 5307 BiOrthogonalBasis = ListGetLogical( BC, 'Use Biorthogonal Basis', Found) 5308 ! If we want to eliminate the constraints we have to have a biortgonal basis 5309 IF(.NOT. Found ) THEN 5310 BiOrthogonalBasis = ListGetLogical( CurrentModel % Solver % Values, & 5311 'Eliminate Linear Constraints',Found ) 5312 IF( BiOrthogonalBasis ) THEN 5313 CALL Info('NormalProjector',& 5314 'Enforcing > Use Biorthogonal Basis < to True to enable elimination',Level=8) 5315 CALL ListAddLogical( BC, 'Use Biorthogonal Basis',.TRUE. ) 5316 END IF 5317 END IF 5318 5319 IF (BiOrthogonalBasis) THEN 5320 DualSlave = ListGetLogical(BC, 'Biorthogonal Dual Slave', Found) 5321 IF(.NOT.Found) DualSlave = .TRUE. 5322 5323 DualMaster = ListGetLogical(BC, 'Biorthogonal Dual Master', Found) 5324 IF(.NOT.Found) DualMaster = .TRUE. 5325 5326 DualLCoeff = ListGetLogical(BC, 'Biorthogonal Dual Lagrange Coefficients', Found) 5327 IF(.NOT.Found) DualLCoeff = .FALSE. 5328 5329 IF(DualLCoeff) THEN 5330 DualSlave = .FALSE. 5331 DualMaster = .FALSE. 5332 CALL ListAddLogical( CurrentModel % Solver % Values, 'Use Transpose Values',.FALSE.) 5333 ELSE 5334 CALL ListAddLogical( CurrentModel % Solver % Values, 'Use Transpose Values',.TRUE.) 5335 END IF 5336 5337 Projector % Child => AllocateMatrix() 5338 Projector % Child % Format = MATRIX_LIST 5339 CALL Info('NormalProjector','Using biorthogonal basis, as requested',Level=8) 5340 END IF 5341 5342 5343 ALLOCATE( NodePerm( Mesh % NumberOfNodes ) ) 5344 NodePerm = 0 5345 5346 ! in parallel only consider nodes that truly are part of this partition 5347 DO i=1,BMesh1 % NumberOfBulkElements 5348 Element => BMesh1 % Elements(i) 5349 IF( Parallel ) THEN 5350 IF( Element % PartIndex /= ParEnv % MyPe ) CYCLE 5351 END IF 5352 NodePerm( InvPerm1( Element % NodeIndexes ) ) = 1 5353 END DO 5354 n = 0 5355 DO i = 1, Mesh % NumberOfNodes 5356 IF( NodePerm(i) > 0 ) THEN 5357 n = n + 1 5358 NodePerm(i) = n 5359 END IF 5360 END DO 5361 CALL Info('NormalProjector','Initial number of slave nodes '//TRIM(I2S(n))//& 5362 ' out of '//TRIM(I2S(BMesh1 % NumberOfNodes ) ), Level = 10 ) 5363 5364 ALLOCATE( Projector % InvPerm(n) ) 5365 Projector % InvPerm = 0 5366 5367 DualMaster = ListGetLogical(BC, 'Biorthogonal Dual Master', Found) 5368 IF(.NOT.Found) DualMaster = .TRUE. 5369 5370 NodeScale = ListGetConstReal( BC, 'Mortar BC Scaling', Found) 5371 IF(.NOT. Found ) NodeScale = 1.0_dp 5372 5373 5374 ! Here we create the projector 5375 !-------------------------------------------------------------- 5376 CALL NormalProjectorWeak3D() 5377 !-------------------------------------------------------------- 5378 5379 5380 ! Now change the matrix format to CRS from list matrix 5381 !-------------------------------------------------------------- 5382 CALL List_toCRSMatrix(Projector) 5383 CALL CRS_SortMatrix(Projector,.TRUE.) 5384 CALL Info('NormalProjector','Number of rows in projector: '& 5385 //TRIM(I2S(Projector % NumberOfRows)),Level=12) 5386 CALL Info('NormalProjector','Number of entries in projector: '& 5387 //TRIM(I2S(SIZE(Projector % Values))),Level=12) 5388 5389 IF(ASSOCIATED(Projector % Child)) THEN 5390 CALL List_toCRSMatrix(Projector % Child) 5391 CALL CRS_SortMatrix(Projector % Child,.TRUE.) 5392 END IF 5393 5394 IF( CreateDual ) THEN 5395 CALL List_toCRSMatrix(DualProjector) 5396 CALL CRS_SortMatrix(DualProjector,.TRUE.) 5397 END IF 5398 5399 m = COUNT( Projector % InvPerm > 0 ) 5400 IF( m > 0 ) THEN 5401 CALL Info('NormalProjector','Projector % InvPerm set for dofs: '//TRIM(I2S(m)),Level=7) 5402 END IF 5403 m = COUNT( Projector % InvPerm == 0 ) 5404 IF( m > 0 ) THEN 5405 CALL Warn('NormalProjector','Projector % InvPerm not set in for dofs: '//TRIM(I2S(m))) 5406 END IF 5407 5408 CALL Info('NormalProjector','Projector created',Level=10) 5409 5410 5411 5412 CONTAINS 5413 5414 5415 !---------------------------------------------------------------------- 5416 ! Create weak projector in a generic 3D case using local coordinates. 5417 ! For each slave element we move into local normal-tangential coordinates 5418 ! and use the same coordinate system for the candidate master elements 5419 ! as well. Only the rought 1st selection is made in the original coordinate 5420 ! system. Using the n-t coordinate system we can again operate in a local 5421 ! x-y coordinate system. 5422 !---------------------------------------------------------------------- 5423 SUBROUTINE NormalProjectorWeak3D() 5424 5425 INTEGER, TARGET :: IndexesT(3) 5426 INTEGER, POINTER :: Indexes(:), IndexesM(:) 5427 INTEGER :: i,j,n,jj,ii,sgn0,k,kmax,ind,indM,nip,nn,ne,inds(10),nM,neM,iM,i2,i2M 5428 INTEGER :: ElemCands, TotCands, ElemHits, TotHits, EdgeHits, CornerHits, & 5429 MaxErrInd, MinErrInd, InitialHits, ActiveHits, TimeStep, Nrange1, NoGaussPoints, & 5430 AllocStat, NrangeAve, nrow, SubTri 5431 TYPE(Element_t), POINTER :: Element, ElementM, ElementP 5432 TYPE(Element_t) :: ElementT 5433 TYPE(Element_t), TARGET :: ElementLin 5434 TYPE(GaussIntegrationPoints_t) :: IP, IPT 5435 TYPE(Nodes_t) :: Nodes, NodesM, NodesT 5436 REAL(KIND=dp) :: x(10),y(10),xt,yt,zt,xmax,ymax,xmin,ymin,xmaxm,ymaxm,& 5437 xminm,yminm,DetJ,Wtemp,q,u,v,w,RefArea,dArea,& 5438 SumArea,MaxErr,MinErr,Err,Depth,MinDepth,MaxDepth,phi(10),Point(3),uvw(3), & 5439 val_dual, zmin, zmax, zave, zminm, zmaxm, uq, vq, TolS, & 5440 MaxNormalDot, ElemdCoord(3), ElemH, MaxElemH(2), MinElemH(2) 5441 REAL(KIND=dp) :: A(2,2), B(2), C(2), absA, detA, rlen, & 5442 x1, x2, y1, y2, x1M, x2M, y1M, y2M, x0, y0, dist 5443 REAL(KIND=dp) :: TotRefArea, TotSumArea 5444 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 5445 LOGICAL :: Stat, CornerFound(4), CornerFoundM(4) 5446 TYPE(Mesh_t), POINTER :: Mesh 5447 TYPE(Variable_t), POINTER :: TimestepVar 5448 TYPE(Mesh_t), POINTER :: pMesh 5449 TYPE(Nodes_t) :: Center2 5450 REAL(KIND=dp) :: Center(3), MaxDistance, Normal(3), Tangent(3), Tangent2(3), & 5451 NormalM(3), r(3) 5452 5453 ! These are used temporarily for debugging purposes 5454 INTEGER :: SaveInd, MaxSubElem, MaxSubTriangles, DebugInd, iMesh 5455 LOGICAL :: SaveElem, DebugElem, SaveErr 5456 CHARACTER(LEN=20) :: FileName 5457 5458 CHARACTER(LEN=MAX_NAME_LEN) :: Caller='NormalProjectorWeak3D' 5459 5460 CALL Info(Caller,'Creating weak constraints using a generic integrator',Level=8) 5461 5462 Mesh => CurrentModel % Solver % Mesh 5463 5464 MaxDistance = ListGetCReal( BC,'Projector Max Distance',Found ) 5465 5466 SaveInd = ListGetInteger( BC,'Projector Save Element Index',Found ) 5467 DebugInd = ListGetInteger( BC,'Projector Debug Element Index',Found ) 5468 SaveErr = ListGetLogical( BC,'Projector Save Fraction',Found) 5469 MaxNormalDot = ListGetCReal( BC,'Max Search Normal',Found) 5470 IF(.NOT. Found ) MaxNormalDot = -0.1 5471 5472 TimestepVar => VariableGet( Mesh % Variables,'Timestep',ThisOnly=.TRUE. ) 5473 Timestep = NINT( TimestepVar % Values(1) ) 5474 5475 IF( SaveErr ) THEN 5476 FileName = 'frac_'//TRIM(I2S(TimeStep))//'.dat' 5477 OPEN( 11,FILE=Filename) 5478 END IF 5479 5480 n = Mesh % MaxElementNodes 5481 ALLOCATE( Nodes % x(n), Nodes % y(n), Nodes % z(n), & 5482 NodesM % x(n), NodesM % y(n), NodesM % z(n), & 5483 NodesT % x(3), NodesT % y(3), NodesT % z(3), Basis(n), & 5484 STAT = AllocStat ) 5485 IF( AllocStat /= 0 ) CALL Fatal('AddProjectorWeakGeneric','Allocation error 1') 5486 5487 MaxErr = 0.0_dp 5488 MinErr = HUGE( MinErr ) 5489 MinDepth = HUGE( MinDepth ) 5490 MaxDepth = -HUGE( MaxDepth ) 5491 MaxErrInd = 0 5492 MinErrInd = 0 5493 zt = 0.0_dp 5494 NodesT % z = 0.0_dp 5495 5496 ! The temporal triangle used in the numerical integration 5497 ElementT % TYPE => GetElementType( 303, .FALSE. ) 5498 ElementT % NodeIndexes => IndexesT 5499 5500 ! Use optionally user defined integration rules 5501 NoGaussPoints = ListGetInteger( BC,'Mortar BC Gauss Points',Found ) 5502 IF( NoGaussPoints > 0 ) THEN 5503 IPT = GaussPoints( ElementT, NoGaussPoints, PreferenceElement = .FALSE. ) 5504 ELSE 5505 IPT = GaussPoints( ElementT, PreferenceElement = .FALSE. ) 5506 END IF 5507 CALL Info(Caller,'Number of integration points for temporal triangle: '& 5508 //TRIM(I2S(IPT % n)),Level=7) 5509 5510 TotCands = 0 5511 TotHits = 0 5512 EdgeHits = 0 5513 CornerHits = 0 5514 InitialHits = 0 5515 ActiveHits = 0 5516 TotRefArea = 0.0_dp 5517 TotSumArea = 0.0_dp 5518 Point = 0.0_dp 5519 MaxSubTriangles = 0 5520 MaxSubElem = 0 5521 5522 ! Save center of elements for master mesh for fast rough test 5523 n = BMesh2 % NumberOfBulkElements 5524 ALLOCATE( Center2 % X(n), Center2 % y(n), Center2 % z(n) ) 5525 5526 MaxElemH = 0.0_dp 5527 MinElemH = HUGE( ElemH ) 5528 5529 ! Calculate maximum and minimum elementsize for slave and master mesh 5530 DO iMesh=1,2 5531 IF( iMesh == 1 ) THEN 5532 pMesh => BMesh1 5533 ELSE 5534 pMesh => BMesh2 5535 END IF 5536 5537 DO ind=1,pMesh % NumberOfBulkElements 5538 Element => pMesh % Elements(ind) 5539 Indexes => Element % NodeIndexes 5540 n = Element % TYPE % NumberOfNodes 5541 ne = Element % TYPE % ElementCode / 100 5542 5543 ! Calculate maximum size of element 5544 ElemdCoord(1) = MAXVAL( pMesh % Nodes % x(Indexes(1:ne)) ) - & 5545 MINVAL( pMesh % Nodes % x(Indexes(1:ne)) ) 5546 ElemdCoord(2) = MAXVAL( pMesh % Nodes % y(Indexes(1:ne)) ) - & 5547 MINVAL( pMesh % Nodes % y(Indexes(1:ne)) ) 5548 ElemdCoord(3) = MAXVAL( pMesh % Nodes % z(Indexes(1:ne)) ) - & 5549 MINVAL( pMesh % Nodes % z(Indexes(1:ne)) ) 5550 5551 ElemH = SQRT( SUM( ElemdCoord**2 ) ) 5552 5553 MaxElemH(iMesh) = MAX( MaxElemH(iMesh), ElemH ) 5554 MinElemH(iMesh) = MIN( MinElemH(iMesh), ElemH ) 5555 5556 IF( iMesh == 2 ) THEN 5557 Center2 % x(ind) = SUM( pMesh % Nodes % x(Indexes(1:ne)) ) / ne 5558 Center2 % y(ind) = SUM( pMesh % Nodes % y(Indexes(1:ne)) ) / ne 5559 Center2 % z(ind) = SUM( pMesh % Nodes % z(Indexes(1:ne)) ) / ne 5560 END IF 5561 5562 END DO 5563 5564 !PRINT *,'Element size range:',MinElemH(iMesh),MaxElemH(iMesh) 5565 END DO 5566 5567 ! Use tolerances related to minimum elementsize 5568 TolS = 1.0d-8 * MINVAL( MinElemH ) 5569 5570 ! Maximum theoretical distance of centerpoints 5571 ElemH = 0.5 * SUM( MaxElemH ) 5572 5573 IF( MaxDistance < ElemH ) THEN 5574 CALL Info(Caller,'Increasing search distance radius') 5575 !PRINT *,'MaxDistance:',MaxDistance,ElemH 5576 MaxDistance = 1.2 * ElemH ! some tolerance! 5577 END IF 5578 5579 DO ind=1,BMesh1 % NumberOfBulkElements 5580 5581 ! Optionally save the submesh for specified element, for vizualization and debugging 5582 SaveElem = ( SaveInd == ind ) 5583 DebugElem = ( DebugInd == ind ) 5584 5585 IF( DebugElem ) THEN 5586 PRINT *,'Debug element turned on: '//TRIM(I2S(ind)) 5587 PRINT *,'Element is p-element:',isActivePElement(element) 5588 END IF 5589 5590 Element => BMesh1 % Elements(ind) 5591 Indexes => Element % NodeIndexes 5592 5593 n = Element % TYPE % NumberOfNodes 5594 ne = Element % TYPE % NumberOfEdges 5595 5596 ! The coordinates of the boundary element 5597 Nodes % x(1:n) = BMesh1 % Nodes % x(Indexes(1:n)) 5598 Nodes % y(1:n) = BMesh1 % Nodes % y(Indexes(1:n)) 5599 Nodes % z(1:n) = BMesh1 % Nodes % z(Indexes(1:n)) 5600 5601 ! Center in the original coordinates 5602 Center(1) = SUM( Nodes % x(1:ne) ) / ne 5603 Center(2) = SUM( Nodes % y(1:ne) ) / ne 5604 Center(3) = SUM( Nodes % z(1:ne) ) / ne 5605 5606 ! Find the new normal-tangential coordinate system for this particular element 5607 Normal = NormalVector( Element, Nodes, Check = .FALSE. ) 5608 IF( BMesh1 % PeriodicFlip(ind) ) Normal = -Normal 5609 CALL TangentDirections( Normal,Tangent,Tangent2 ) 5610 5611 IF( DebugElem ) THEN 5612 PRINT *,'Center of element:',Center 5613 PRINT *,'Normal:',Normal,BMesh1 % PeriodicFlip(ind) 5614 PRINT *,'Tangent:',Tangent 5615 PRINT *,'Tangent2:',Tangent2 5616 END IF 5617 5618 ! Move to local normal-tangential coordinate system for the slave element 5619 DO i=1,n 5620 r(1) = Nodes % x(i) 5621 r(2) = Nodes % y(i) 5622 r(3) = Nodes % z(i) 5623 5624 ! Coordinate projected to nt-coordinates 5625 Nodes % x(i) = SUM( Tangent * r ) 5626 Nodes % y(i) = SUM( Tangent2 * r ) 5627 Nodes % z(i) = SUM( Normal * r ) 5628 END DO 5629 5630 ! Even for quadratic elements only work with corner nodes (n >= ne) 5631 xmin = MINVAL(Nodes % x(1:ne)) 5632 xmax = MAXVAL(Nodes % x(1:ne)) 5633 5634 ymin = MINVAL(Nodes % y(1:ne)) 5635 ymax = MAXVAL(Nodes % y(1:ne)) 5636 5637 zmin = MINVAL( Nodes % z(1:ne)) 5638 zmax = MAXVAL( Nodes % z(1:ne)) 5639 zave = SUM( Nodes % z(1:ne) ) / ne 5640 5641 ! Compute the reference area 5642 u = 0.0_dp; v = 0.0_dp; w = 0.0_dp; 5643 5644 IF( DebugElem ) THEN 5645 PRINT *,'Element n-t range:' 5646 PRINT *,'xrange:',xmin,xmax 5647 PRINT *,'yrange:',ymin,ymax 5648 PRINT *,'zrange:',zmin,zmax 5649 END IF 5650 5651 ! Nullify z since we don't need it anymore after registering (zmin,zmax) 5652 Nodes % z = 0.0_dp 5653 5654 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 5655 5656 IP = GaussPoints( Element, PreferenceElement = .FALSE. ) 5657 RefArea = detJ * SUM( IP % s(1:IP % n) ) 5658 SumArea = 0.0_dp 5659 5660 IF( SaveElem ) THEN 5661 FileName = 't'//TRIM(I2S(TimeStep))//'_a.dat' 5662 OPEN( 10,FILE=Filename) 5663 DO i=1,ne 5664 WRITE( 10, * ) Nodes % x(i), Nodes % y(i), Nodes % z(i) 5665 END DO 5666 CLOSE( 10 ) 5667 END IF 5668 5669 DO i=1,n 5670 j = InvPerm1(Indexes(i)) 5671 nrow = NodePerm(j) 5672 IF( nrow == 0 ) CYCLE 5673 CALL List_AddMatrixIndex(Projector % ListMatrix, nrow, j ) 5674 IF(ASSOCIATED(Projector % Child)) & 5675 CALL List_AddMatrixIndex(Projector % Child % ListMatrix, nrow, j ) 5676 END DO 5677 5678 ! Currently a n^2 loop but it could be improved 5679 !-------------------------------------------------------------------- 5680 ElemCands = 0 5681 ElemHits = 0 5682 SubTri = 0 5683 5684 DO indM=1,BMesh2 % NumberOfBulkElements 5685 5686 ! Rough search, note that this cannot be too tight since then 5687 ! we loose also the contacts. 5688 IF( ABS( Center(1) - Center2 % x(indM) ) > MaxDistance ) CYCLE 5689 IF( ABS( Center(2) - Center2 % y(indM) ) > MaxDistance ) CYCLE 5690 IF( ABS( Center(3) - Center2 % z(indM) ) > MaxDistance ) CYCLE 5691 5692 IF( DebugElem ) THEN 5693 PRINT *,'Candidate Elem Center:',indM,Center2 % x(indM),& 5694 Center2 % y(indM),Center2 % z(indM) 5695 END IF 5696 5697 ElementM => BMesh2 % Elements(indM) 5698 IndexesM => ElementM % NodeIndexes 5699 5700 nM = ElementM % TYPE % NumberOfNodes 5701 neM = ElementM % TYPE % ElementCode / 100 5702 5703 DO i=1,nM 5704 j = IndexesM(i) 5705 r(1) = BMesh2 % Nodes % x(j) 5706 r(2) = BMesh2 % Nodes % y(j) 5707 r(3) = BMesh2 % Nodes % z(j) 5708 5709 ! Coordinate projected to nt-coordinates 5710 NodesM % x(i) = SUM( Tangent * r ) 5711 NodesM % y(i) = SUM( Tangent2 * r ) 5712 NodesM % z(i) = SUM( Normal * r ) 5713 END DO 5714 5715 ! Now we can make the 2nd quick search in the nt-system. 5716 ! Now the tangential coordinates can be treated exactly. 5717 xminm = MINVAL( NodesM % x(1:neM) ) 5718 IF( xminm > xmax ) CYCLE 5719 5720 xmaxm = MAXVAL( NodesM % x(1:neM) ) 5721 IF( xmaxm < xmin ) CYCLE 5722 5723 yminm = MINVAL( NodesM % y(1:neM)) 5724 IF( yminm > ymax ) CYCLE 5725 5726 ymaxm = MAXVAL( NodesM % y(1:neM)) 5727 IF( ymaxm < ymin ) CYCLE 5728 5729 zminm = MINVAL( NodesM % z(1:neM) ) 5730 IF( zminm > zmax + MaxDistance ) CYCLE 5731 5732 zmaxm = MAXVAL( NodesM % z(1:neM) ) 5733 IF( zmaxm < zmin - MaxDistance ) CYCLE 5734 5735 NormalM = NormalVector( ElementM, NodesM, Check = .FALSE. ) 5736 IF( BMesh2 % PeriodicFlip(indM) ) NormalM = -NormalM 5737 5738 IF( DebugElem ) THEN 5739 PRINT *,'ElementM n-t range:' 5740 PRINT *,'xrange:',xminm,xmaxm 5741 PRINT *,'yrange:',yminm,ymaxm 5742 PRINT *,'zrange:',zminm,zmaxm 5743 PRINT *,'Candidate elem normal:',NormalM, BMesh2 % PeriodicFlip(indM) 5744 END IF 5745 5746 ! We must compare this normal to the nt-system where the slave normal is (0,0,1) 5747 ! Positive normal means that this element is pointing to the same direction! 5748 IF( NormalM(3) >= MaxNormalDot ) THEN 5749 IF( DebugElem ) PRINT *,'Normals are not facing!' 5750 CYCLE 5751 END IF 5752 5753 ! Nullify z since we don't need it anymore 5754 NodesM % z = 0.0_dp 5755 5756 k = 0 5757 ElemCands = ElemCands + 1 5758 CornerFound = .FALSE. 5759 CornerFoundM = .FALSE. 5760 5761 ! Check through the nodes that are created in the intersections of any two edge 5762 DO i=1,ne 5763 x1 = Nodes % x(i) 5764 y1 = Nodes % y(i) 5765 i2 = i + 1 5766 IF( i2 > ne ) i2 = 1 ! check the (ne,1) edge also 5767 x2 = Nodes % x(i2) 5768 y2 = Nodes % y(i2) 5769 5770 DO iM=1,neM 5771 x1M = NodesM % x(iM) 5772 y1M = NodesM % y(iM) 5773 i2M = iM + 1 5774 IF( i2M > neM ) i2M = 1 5775 x2M = NodesM % x(i2M) 5776 y2M = NodesM % y(i2M) 5777 5778 ! Upon solution this is tampered so it must be initialized 5779 ! before each solution. 5780 A(1,1) = x2 - x1 5781 A(2,1) = y2 - y1 5782 A(1,2) = x1M - x2M 5783 A(2,2) = y1M - y2M 5784 5785 detA = A(1,1)*A(2,2)-A(1,2)*A(2,1) 5786 absA = SUM(ABS(A(1,1:2))) * SUM(ABS(A(2,1:2))) 5787 5788 ! Lines are almost parallel => no intersection possible 5789 ! Check the dist at the end of the line segments. 5790 IF(ABS(detA) < 1.0d-8 * absA + 1.0d-20 ) CYCLE 5791 5792 B(1) = x1M - x1 5793 B(2) = y1M - y1 5794 5795 CALL InvertMatrix( A,2 ) 5796 C(1:2) = MATMUL(A(1:2,1:2),B(1:2)) 5797 5798 ! Check that the hit is within the line segment 5799 IF(ANY(C(1:2) < 0.0) .OR. ANY(C(1:2) > 1.0d0)) CYCLE 5800 5801 ! We have a hit, two line segments can have only one hit 5802 k = k + 1 5803 5804 x(k) = x1 + C(1) * (x2-x1) 5805 y(k) = y1 + C(1) * (y2-y1) 5806 5807 ! If the point of intersection is at the end of a line-segment it 5808 ! is also a corner node. 5809 IF(ABS(C(1)) < 1.0d-6 ) THEN 5810 CornerFound(i) = .TRUE. 5811 ELSE IF( ABS(C(1)-1.0_dp ) < 1.0d-6 ) THEN 5812 CornerFound(i2) = .TRUE. 5813 END IF 5814 5815 IF(ABS(C(2)) < 1.0d-6 ) THEN 5816 CornerFoundM(iM) = .TRUE. 5817 ELSE IF( ABS(C(2)-1.0_dp ) < 1.0d-6 ) THEN 5818 CornerFoundM(i2M) = .TRUE. 5819 END IF 5820 5821 EdgeHits = EdgeHits + 1 5822 END DO 5823 END DO 5824 5825 IF( DebugElem ) THEN 5826 PRINT *,'EdgeHits:',k,COUNT(CornerFound),COUNT(CornerFoundM) 5827 END IF 5828 5829 ! Check the nodes that are one of the existing nodes i.e. corner nodes 5830 ! that are located inside in either element. We have to check both combinations. 5831 DO i=1,ne 5832 ! This corner was already determined active as the end of edge 5833 IF( CornerFound(i) ) CYCLE 5834 5835 Point(1) = Nodes % x(i) 5836 IF( Point(1) < xminm - tolS ) CYCLE 5837 IF( Point(1) > xmaxm + tolS ) CYCLE 5838 5839 Point(2) = Nodes % y(i) 5840 IF( Point(2) < yminm - TolS ) CYCLE 5841 IF( Point(2) > ymaxm + TolS ) CYCLE 5842 5843 ! The edge intersections should catch the sharp hits so here we can use hard criteria 5844 Found = PointInElement( ElementM, NodesM, Point, uvw, LocalEps = 1.0d-8 ) 5845 IF( Found ) THEN 5846 k = k + 1 5847 x(k) = Point(1) 5848 y(k) = Point(2) 5849 CornerHits = CornerHits + 1 5850 END IF 5851 END DO 5852 5853 5854 ! Possible corner hits for the master element 5855 DO i=1,neM 5856 IF( CornerFoundM(i) ) CYCLE 5857 5858 Point(1) = NodesM % x(i) 5859 IF( Point(1) < xmin - tols ) CYCLE 5860 IF( Point(1) > xmax + tols ) CYCLE 5861 5862 Point(2) = NodesM % y(i) 5863 IF( Point(2) < ymin - Tols ) CYCLE 5864 IF( Point(2) > ymax + Tols ) CYCLE 5865 5866 Found = PointInElement( Element, Nodes, Point, uvw, LocalEps = 1.0d-8 ) 5867 IF( Found ) THEN 5868 k = k + 1 5869 x(k) = Point(1) 5870 y(k) = Point(2) 5871 CornerHits = CornerHits + 1 5872 END IF 5873 END DO 5874 5875 IF( DebugElem ) THEN 5876 PRINT *,'Total and corner hits:',k,CornerHits 5877 END IF 5878 5879 kmax = k 5880 IF( kmax < 3 ) CYCLE 5881 5882 sgn0 = 1 5883 5884 InitialHits = InitialHits + kmax 5885 5886 ! The polygon is convex and hence its center lies inside the polygon 5887 xt = SUM(x(1:kmax)) / kmax 5888 yt = SUM(y(1:kmax)) / kmax 5889 5890 ! Set the angle from the center and order the nodes so that they 5891 ! can be easily triangulated. 5892 DO k=1,kmax 5893 phi(k) = ATAN2( y(k)-yt, x(k)-xt ) 5894 inds(k) = k 5895 END DO 5896 5897 IF( DebugElem ) THEN 5898 PRINT *,'Polygon Coords:',k 5899 PRINT *,'x:',x(1:k) 5900 PRINT *,'y:',y(1:k) 5901 PRINT *,'PolygonArea:',(MAXVAL(x(1:k))-MINVAL(x(1:k)))*(MAXVAL(y(1:k))-MINVAL(y(1:k))) 5902 PRINT *,'Center:',xt,yt 5903 PRINT *,'Phi:',phi(1:kmax) 5904 END IF 5905 5906 CALL SortR(kmax,inds,phi) 5907 5908 x(1:kmax) = x(inds(1:kmax)) 5909 y(1:kmax) = y(inds(1:kmax)) 5910 5911 IF( DebugElem ) THEN 5912 PRINT *,'Sorted Inds:',inds(1:kmax) 5913 PRINT *,'Sorted Phi:',phi(1:kmax) 5914 END IF 5915 5916 ! Eliminate redundant corners from the polygon 5917 j = 1 5918 DO k=2,kmax 5919 dist = (x(j)-x(k))**2 + (y(j)-y(k))**2 5920 IF( dist > Tols ) THEN 5921 j = j + 1 5922 IF( j /= k ) THEN 5923 x(j) = x(k) 5924 y(j) = y(k) 5925 END IF 5926 END IF 5927 END DO 5928 5929 IF( DebugElem ) THEN 5930 IF( kmax > j ) PRINT *,'Corners reduced to:',j 5931 END IF 5932 5933 kmax = j 5934 IF( kmax < 3 ) CYCLE 5935 5936 ElemHits = ElemHits + 1 5937 ActiveHits = ActiveHits + kmax 5938 5939 IF( kmax > MaxSubTriangles ) THEN 5940 MaxSubTriangles = kmax 5941 MaxSubElem = ind 5942 END IF 5943 5944 IF( SaveElem ) THEN 5945 FileName = 't'//TRIM(I2S(TimeStep))//'_b'//TRIM(I2S(ElemHits))//'.dat' 5946 OPEN( 10,FILE=FileName) 5947 DO i=1,nM 5948 WRITE( 10, * ) NodesM % x(i), NodesM % y(i) 5949 END DO 5950 CLOSE( 10 ) 5951 5952 FileName = 't'//TRIM(I2S(TimeStep))//'_c'//TRIM(I2S(ElemHits))//'.dat' 5953 OPEN( 10,FILE=FileName) 5954 WRITE( 10, * ) xt, yt 5955 CLOSE( 10 ) 5956 5957 FileName = 't'//TRIM(I2S(TimeStep))//'_e'//TRIM(I2S(ElemHits))//'.dat' 5958 OPEN( 10,FILE=FileName) 5959 DO i=1,kmax 5960 WRITE( 10, * ) x(i), y(i) 5961 END DO 5962 CLOSE( 10 ) 5963 END IF 5964 5965 Depth = zave - SUM( NodesM % z(1:neM) )/neM 5966 MaxDepth = MAX( Depth, MaxDepth ) 5967 MinDepth = MIN( Depth, MinDepth ) 5968 5969 ! Deal the case with multiple corners by making 5970 ! triangulariation using one corner point. 5971 ! This should be ok as the polygon is always convex. 5972 NodesT % x(1) = x(1) 5973 NodesT % y(1) = y(1) 5974 5975 DO k=1,kmax-2 5976 5977 ! This check over area also automatically elimiates redundant nodes 5978 ! that were detected twice. 5979 dArea = 0.5_dp*ABS( (x(k+1)-x(1))*(y(k+2)-y(1)) -(x(k+2)-x(1))*(y(k+1)-y(1))) 5980 5981 IF( dArea < TolS**2 * RefArea ) CYCLE 5982 5983 ! Triangle is created by keeping one corner node fixed and rotating through 5984 ! the other nodes. 5985 NodesT % x(2) = x(k+1) 5986 NodesT % y(2) = y(k+1) 5987 NodesT % x(3) = x(k+2) 5988 NodesT % y(3) = y(k+2) 5989 5990 IF( DebugElem ) THEN 5991 PRINT *,'Temporal element n-t coordinates',k 5992 PRINT *,'x:',NodesT % x 5993 PRINT *,'y:',NodesT % y 5994 END IF 5995 5996 IF( SaveElem ) THEN 5997 SubTri = SubTri + 1 5998 FileName = 't'//TRIM(I2S(TimeStep))//'_s'//TRIM(I2S(SubTri))//'.dat' 5999 OPEN( 10,FILE=FileName) 6000 DO i=1,3 6001 WRITE( 10, * ) NodesT % x(i), NodesT % y(i) 6002 END DO 6003 CLOSE( 10 ) 6004 END IF 6005 6006 CALL TemporalTriangleMortarAssembly(ElementT, NodesT, Element, Nodes, ElementM, NodesM, & 6007 BiorthogonalBasis, DualMaster, DualLCoeff, NoGaussPoints, Projector, NodeScale, & 6008 NodePerm, InvPerm1, InvPerm2, SumArea ) 6009 END DO 6010 6011 IF( DebugElem ) PRINT *,'Element integrated:',indM,SumArea,RefArea,SumArea / RefArea 6012 6013 ! If we have integrated enough area we are done! 6014 IF( SumArea > RefArea*(1.0_dp - 1.0e-6) ) EXIT 6015 6016 END DO ! indM 6017 6018 IF( SaveElem ) THEN 6019 FileName = 't'//TRIM(I2S(TimeStep))//'_n.dat' 6020 OPEN( 10,FILE=Filename) 6021 OPEN( 10,FILE=FileName) 6022 WRITE( 10, * ) ElemHits 6023 CLOSE( 10 ) 6024 END IF 6025 6026 TotCands = TotCands + ElemCands 6027 TotHits = TotHits + ElemHits 6028 TotSumArea = TotSumArea + SumArea 6029 TotRefArea = TotRefArea + RefArea 6030 6031 Err = SumArea / RefArea 6032 IF( Err > MaxErr ) THEN 6033 MaxErr = Err 6034 MaxErrInd = Err 6035 END IF 6036 IF( Err < MinErr ) THEN 6037 MinErr = Err 6038 MinErrInd = ind 6039 END IF 6040 6041 IF( SaveErr ) THEN 6042 WRITE( 11, * ) ind,SUM( Nodes % x(1:ne))/ne, SUM( Nodes % y(1:ne))/ne, Err 6043 END IF 6044 6045 END DO 6046 6047 IF( SaveErr ) CLOSE(11) 6048 6049 6050 DEALLOCATE( Nodes % x, Nodes % y, Nodes % z, & 6051 NodesM % x, NodesM % y, NodesM % z, & 6052 NodesT % x, NodesT % y, NodesT % z, & 6053 Center2 % x, Center2 % y, Center2 % z, Basis ) 6054 6055 CALL Info(Caller,'Number of integration pair candidates: '& 6056 //TRIM(I2S(TotCands)),Level=10) 6057 CALL Info(Caller,'Number of integration pairs: '& 6058 //TRIM(I2S(TotHits)),Level=10) 6059 6060 CALL Info(Caller,'Number of edge intersections: '& 6061 //TRIM(I2S(EdgeHits)),Level=10) 6062 CALL Info(Caller,'Number of corners inside element: '& 6063 //TRIM(I2S(EdgeHits)),Level=10) 6064 6065 CALL Info(Caller,'Number of initial corners: '& 6066 //TRIM(I2S(InitialHits)),Level=10) 6067 CALL Info(Caller,'Number of active corners: '& 6068 //TRIM(I2S(ActiveHits)),Level=10) 6069 6070 CALL Info(Caller,'Number of most subelement corners: '& 6071 //TRIM(I2S(MaxSubTriangles)),Level=10) 6072 CALL Info(Caller,'Element of most subelement corners: '& 6073 //TRIM(I2S(MaxSubElem)),Level=10) 6074 6075 WRITE( Message,'(A,ES12.5)') 'Total reference area:',TotRefArea 6076 CALL Info(Caller,Message,Level=8) 6077 WRITE( Message,'(A,ES12.5)') 'Total integrated area:',TotSumArea 6078 CALL Info(Caller,Message,Level=8) 6079 6080 Err = TotSumArea / TotRefArea 6081 WRITE( Message,'(A,ES15.6)') 'Average ratio in area integration:',Err 6082 CALL Info(Caller,Message,Level=5) 6083 6084 WRITE( Message,'(A,I0,A,ES12.4)') & 6085 'Maximum relative discrepancy in areas (element: ',MaxErrInd,'):',MaxErr-1.0_dp 6086 CALL Info(Caller,Message,Level=6) 6087 WRITE( Message,'(A,I0,A,ES12.4)') & 6088 'Minimum relative discrepancy in areas (element: ',MinErrInd,'):',MinErr-1.0_dp 6089 CALL Info(Caller,Message,Level=6) 6090 6091 WRITE( Message,'(A,ES12.4)') & 6092 'Minimum depth in normal direction:',MinDepth 6093 CALL Info(Caller,Message,Level=8) 6094 WRITE( Message,'(A,ES12.4)') & 6095 'Maximum depth in normal direction:',MaxDepth 6096 CALL Info(Caller,Message,Level=8) 6097 6098 END SUBROUTINE NormalProjectorWeak3D 6099 6100 END FUNCTION NormalProjector 6101 6102 6103 6104 !--------------------------------------------------------------------------- 6105 !> Create a projector for mapping between interfaces using the Galerkin method 6106 !> A temporal mesh structure with a node for each Gaussian integration point is 6107 !> created. Then this projector matrix is transferred to a projector on the nodal 6108 !> coordinates. 6109 !--------------------------------------------------------------------------- 6110 FUNCTION NodalProjector(BMesh2, BMesh1, & 6111 UseQuadrantTree, Repeating, AntiRepeating ) & 6112 RESULT ( Projector ) 6113 !--------------------------------------------------------------------------- 6114 USE Lists 6115 6116 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 6117 LOGICAL :: UseQuadrantTree, Repeating, AntiRepeating 6118 TYPE(Matrix_t), POINTER :: Projector 6119 !-------------------------------------------------------------------------- 6120 INTEGER, POINTER :: InvPerm1(:), InvPerm2(:) 6121 LOGICAL, ALLOCATABLE :: MirrorNode(:) 6122 INTEGER :: i,j,k,n 6123 INTEGER, POINTER :: Rows(:),Cols(:) 6124 REAL(KIND=dp), POINTER :: Values(:) 6125 6126 BMesh1 % Parent => NULL() 6127 BMesh2 % Parent => NULL() 6128 6129 InvPerm1 => BMesh1 % InvPerm 6130 InvPerm2 => BMesh2 % InvPerm 6131 6132 ! Set the nodes of Mesh1 to be in the interval defined by Mesh2 6133 !----------------------------------------------------------------- 6134 IF( Repeating ) THEN 6135 IF( AntiRepeating ) THEN 6136 ALLOCATE( MirrorNode( BMesh1 % NumberOfNodes ) ) 6137 MirrorNode = .FALSE. 6138 END IF 6139 CALL PreRotationalProjector(BMesh1, BMesh2, MirrorNode ) 6140 END IF 6141 6142 ! Create the projector using nodal points 6143 ! This corresponds to numerical integration of the collocation method. 6144 !----------------------------------------------------------------- 6145 Projector => MeshProjector( BMesh2, BMesh1, UseQuadrantTree ) 6146 Projector % ProjectorType = PROJECTOR_TYPE_NODAL 6147 6148 Values => Projector % Values 6149 Cols => Projector % Cols 6150 Rows => Projector % Rows 6151 6152 ! One needs to change the sign of the projector for the mirror nodes 6153 !----------------------------------------------------------------------------- 6154 IF( Repeating .AND. AntiRepeating ) THEN 6155 CALL PostRotationalProjector( Projector, MirrorNode ) 6156 DEALLOCATE( MirrorNode ) 6157 END IF 6158 6159 ! Now return from the indexes of the interface mesh system to the 6160 ! original mesh system. 6161 !----------------------------------------------------------------- 6162 n = SIZE( InvPerm1 ) 6163 ALLOCATE( Projector % InvPerm(n) ) 6164 Projector % InvPerm = InvPerm1 6165 6166 DO i=1,Projector % NumberOfRows 6167 DO j = Rows(i), Rows(i+1)-1 6168 k = Cols(j) 6169 IF ( k > 0 ) Cols(j) = InvPerm2(k) 6170 END DO 6171 END DO 6172 6173 END FUNCTION NodalProjector 6174!------------------------------------------------------------------------------ 6175 6176 !--------------------------------------------------------------------------- 6177 !> Create a nodal projector related to discontinuous interface. 6178 !--------------------------------------------------------------------------- 6179 FUNCTION NodalProjectorDiscont( Mesh, bc ) RESULT ( Projector ) 6180 !--------------------------------------------------------------------------- 6181 USE Lists 6182 6183 TYPE(Mesh_t), POINTER :: Mesh 6184 INTEGER :: bc 6185 TYPE(Matrix_t), POINTER :: Projector 6186 !-------------------------------------------------------------------------- 6187 TYPE(Model_t), POINTER :: Model 6188 INTEGER, POINTER :: NodePerm(:) 6189 INTEGER :: i,j,n,m 6190 INTEGER, POINTER :: Rows(:),Cols(:), InvPerm(:) 6191 REAL(KIND=dp), POINTER :: Values(:) 6192 LOGICAL :: Found 6193 6194 CALL Info('NodalProjectorDiscont','Creating nodal projector for discontinuous boundary',Level=7) 6195 6196 Projector => Null() 6197 IF( .NOT. Mesh % DisContMesh ) THEN 6198 CALL Warn('NodalProjectorDiscont','Discontinuous mesh not created?') 6199 RETURN 6200 END IF 6201 6202 Model => CurrentModel 6203 j = 0 6204 DO i=1,Model % NumberOfBCs 6205 IF( ListGetLogical(Model % BCs(i) % Values,'Discontinuous Boundary',Found) ) THEN 6206 j = j + 1 6207 END IF 6208 END DO 6209 ! This is a temporal limitations 6210 IF( j > 1 ) THEN 6211 CALL Warn('NodalProjectorDiscont','One BC (not '& 6212 //TRIM(I2S(j))//') only for discontinuous boundary!') 6213 END IF 6214 6215 6216 NodePerm => Mesh % DisContPerm 6217 n = SIZE( NodePerm ) 6218 m = COUNT( NodePerm > 0 ) 6219 6220 Projector => AllocateMatrix() 6221 Projector % ProjectorType = PROJECTOR_TYPE_NODAL 6222 Projector % ProjectorBC = bc 6223 6224 ALLOCATE( Projector % Cols(m) ) 6225 ALLOCATE( Projector % Values(m) ) 6226 ALLOCATE( Projector % Rows(m+1) ) 6227 ALLOCATE( Projector % InvPerm(m) ) 6228 6229 Cols => Projector % Cols 6230 Values => Projector % Values 6231 Rows => Projector % Rows 6232 InvPerm => Projector % InvPerm 6233 Projector % NumberOfRows = m 6234 6235 Values = 1.0_dp 6236 DO i=1,m+1 6237 Rows(i) = i 6238 END DO 6239 6240 DO i=1,n 6241 j = NodePerm(i) 6242 IF( j == 0 ) CYCLE 6243 Cols(j) = n + j 6244 InvPerm(j) = i 6245 END DO 6246 6247 END FUNCTION NodalProjectorDiscont 6248!------------------------------------------------------------------------------ 6249 6250 6251 !--------------------------------------------------------------------------------- 6252 ! Create a permutation to eliminate edges in a conforming case. 6253 !--------------------------------------------------------------------------------- 6254 SUBROUTINE ConformingEdgePerm( Mesh, BMesh1, BMesh2, PerPerm, PerFlip, AntiPeriodic ) 6255 TYPE(Mesh_t), POINTER :: Mesh, BMesh1, BMesh2 6256 INTEGER, POINTER :: PerPerm(:) 6257 LOGICAL, POINTER :: PerFlip(:) 6258 LOGICAL, OPTIONAL :: AntiPeriodic 6259 !--------------------------------------------------------------------------------- 6260 INTEGER :: n, ind, indm, e, em, eind, eindm, k1, k2, km1, km2, sgn0, sgn, i1, i2, & 6261 noedges, noedgesm, Nundefined, n0 6262 TYPE(Element_t), POINTER :: Edge, EdgeM 6263 INTEGER, POINTER :: Indexes(:), IndexesM(:) 6264 REAL(KIND=dp) :: xm1, xm2, ym1, ym2, x1, y1, x2, y2, y2m, nrow 6265 INTEGER, ALLOCATABLE :: PeriodicEdge(:), EdgeInds(:), EdgeIndsM(:) 6266 REAL(KIND=dp), ALLOCATABLE :: EdgeX(:,:), EdgeY(:,:), EdgeMX(:,:), EdgeMY(:,:) 6267 REAL(KIND=dp) :: coordprod, indexprod, ss, minss, maxminss 6268 INTEGER :: minuscount, samecount, mini, doubleusecount 6269 LOGICAL :: Parallel, AntiPer 6270 LOGICAL, ALLOCATABLE :: EdgeUsed(:) 6271 6272 6273 CALL Info('ConformingEdgePerm','Creating permutation for elimination of conforming edges',Level=8) 6274 6275 n = Mesh % NumberOfEdges 6276 IF( n == 0 ) RETURN 6277 6278 AntiPer = .FALSE. 6279 IF( PRESENT( AntiPeriodic ) ) AntiPer = AntiPeriodic 6280 6281 CALL CreateEdgeCenters( Mesh, BMesh1, noedges, EdgeInds, EdgeX, EdgeY ) 6282 CALL Info('ConformingEdgePerm','Number of edges in slave mesh: '//TRIM(I2S(noedges)),Level=10) 6283 6284 CALL CreateEdgeCenters( Mesh, BMesh2, noedgesm, EdgeIndsM, EdgeMX, EdgeMY ) 6285 CALL Info('ConformingEdgePerm','Number of edges in master mesh: '//TRIM(I2S(noedgesm)),Level=10) 6286 6287 IF( noedges == 0 ) RETURN 6288 IF( noedgesm == 0 ) RETURN 6289 6290 ALLOCATE( PeriodicEdge(noedges),EdgeUsed(noedgesm)) 6291 PeriodicEdge = 0 6292 EdgeUsed = .FALSE. 6293 maxminss = 0.0_dp 6294 n0 = Mesh % NumberOfNodes 6295 Parallel = ( ParEnv % PEs > 1 ) 6296 samecount = 0 6297 doubleusecount = 0 6298 6299 DO i1=1,noedges 6300 x1 = EdgeX(3,i1) 6301 y1 = EdgeY(3,i1) 6302 6303 IF( PerPerm( EdgeInds(i1) + n0 ) > 0 ) CYCLE 6304 6305 minss = HUGE(minss) 6306 mini = 0 6307 6308 DO i2=1,noedgesm 6309 x2 = EdgeMX(3,i2) 6310 y2 = EdgeMY(3,i2) 6311 6312 ss = (x1-x2)**2 + (y1-y2)**2 6313 IF( ss < minss ) THEN 6314 minss = ss 6315 mini = i2 6316 END IF 6317 END DO 6318 6319 IF( EdgeInds(i1) == EdgeIndsM(mini) ) THEN 6320 samecount = samecount + 1 6321 CYCLE 6322 END IF 6323 6324 IF( EdgeUsed(mini ) ) THEN 6325 doubleusecount = doubleusecount + 1 6326 ELSE 6327 EdgeUsed(mini) = .TRUE. 6328 END IF 6329 6330 ! we have a hit 6331 PeriodicEdge(i1) = mini 6332 maxminss = MAX( maxminss, minss ) 6333 END DO 6334 6335 WRITE(Message,'(A,ES12.4)') 'Maximum minimum deviation in edge centers:',SQRT(maxminss) 6336 CALL Info('ConformingEdgePerm',Message,Level=8) 6337 6338 minuscount = 0 6339 6340 DO e=1,noedges 6341 eind = EdgeInds(e) 6342 6343 ! This has already been set 6344 IF( PerPerm(eind+n0) > 0 ) CYCLE 6345 6346 ! Get the conforming counterpart 6347 em = PeriodicEdge(e) 6348 IF( em == 0 ) CYCLE 6349 eindm = EdgeIndsM(em) 6350 6351 ! Get the coordinates and indexes of the 1st edge 6352 Edge => Mesh % Edges(eind) 6353 k1 = Edge % NodeIndexes( 1 ) 6354 k2 = Edge % NodeIndexes( 2 ) 6355 IF(Parallel) THEN 6356 k1 = Mesh % ParallelInfo % GlobalDOFs(k1) !BMesh1 % InvPerm(k1)) 6357 k2 = Mesh % ParallelInfo % GlobalDOFs(k2) !BMesh1 % InvPerm(k2)) 6358 END IF 6359 6360 ! We cannot use the (x,y) coordinates of the full "Mesh" as the boundary meshes 6361 ! have been mapped such that interpolation is possible. 6362 x1 = EdgeX(1,e) 6363 x2 = EdgeX(2,e) 6364 y1 = EdgeY(1,e) 6365 y2 = EdgeY(2,e) 6366 6367 ! Get the coordinates and indexes of the 2nd edge 6368 EdgeM => Mesh % Edges(eindm) 6369 km1 = EdgeM % NodeIndexes( 1 ) 6370 km2 = EdgeM % NodeIndexes( 2 ) 6371 IF(Parallel) THEN 6372 km1 = Mesh % ParallelInfo % GlobalDOFs(km1) !BMesh2 % InvPerm(km1)) 6373 km2 = Mesh % ParallelInfo % GlobalDOFs(km2) !BMesh2 % InvPerm(km2)) 6374 END IF 6375 6376 xm1 = EdgeMX(1,em) 6377 xm2 = EdgeMX(2,em) 6378 ym1 = EdgeMY(1,em) 6379 ym2 = EdgeMY(2,em) 6380 6381 coordprod = (x1-x2)*(xm1-xm2) + (y1-y2)*(ym1-ym2) 6382 indexprod = (k1-k2)*(km1-km2) 6383 6384 IF( coordprod * indexprod < 0 ) THEN 6385 minuscount = minuscount + 1 6386 PerFlip(eind+n0) = .NOT. AntiPer 6387 !PRINT *,'prod:',coordprod,indexprod 6388 !PRINT *,'x:',x1,x2,xm1,xm2 6389 !PRINT *,'y:',y1,y2,ym1,ym2 6390 !PRINT *,'k:',k1,k2,km1,km2 6391 ELSE 6392 PerFlip(eind+n0) = AntiPer 6393 END IF 6394 6395 ! Mark that this is set so it don't need to be set again 6396 PerPerm(eind+n0) = eindm + n0 6397 END DO 6398 6399 DEALLOCATE( EdgeInds, EdgeX, EdgeY ) 6400 DEALLOCATE( EdgeIndsM, EdgeMX, EdgeMY ) 6401 DEALLOCATE( PeriodicEdge ) 6402 6403 IF( samecount > 0 ) THEN 6404 CALL Info('ConformingEdgePerm','Number of edges are the same: '//TRIM(I2S(samecount)),Level=8) 6405 END IF 6406 6407 IF( minuscount == 0 ) THEN 6408 CALL Info('ConformingEdgePerm','All edges in conforming projector have consistent sign!',Level=8) 6409 ELSE 6410 CALL Info('ConformingEdgePerm','Flipped sign of '//TRIM(I2S(minuscount))//& 6411 ' (out of '//TRIM(I2S(noedges))//') edge projectors',Level=6) 6412 END IF 6413 6414 IF( doubleusecount > 0 ) THEN 6415 CALL Fatal('ConformingEdgePerm','This is not conforming! Number of edges used twice: '//TRIM(I2S(doubleusecount))) 6416 END IF 6417 6418 6419 CONTAINS 6420 6421 ! Create edge centers for the mapping routines. 6422 !------------------------------------------------------------------------------ 6423 SUBROUTINE CreateEdgeCenters( Mesh, EdgeMesh, noedges, EdgeInds, EdgeX, EdgeY ) 6424 6425 TYPE(Mesh_t), POINTER :: Mesh 6426 TYPE(Mesh_t), POINTER :: EdgeMesh 6427 INTEGER :: noedges 6428 INTEGER, ALLOCATABLE :: EdgeInds(:) 6429 REAL(KIND=dp), ALLOCATABLE :: EdgeX(:,:), EdgeY(:,:) 6430 6431 LOGICAL, ALLOCATABLE :: EdgeDone(:) 6432 INTEGER :: ind, eind, i, i1, i2, k1, k2, ktmp 6433 TYPE(Element_t), POINTER :: Element 6434 INTEGER, POINTER :: EdgeMap(:,:), Indexes(:) 6435 LOGICAL :: AllocationsDone 6436 6437 6438 ALLOCATE( EdgeDone( Mesh % NumberOfEdges ) ) 6439 AllocationsDone = .FALSE. 6440 6441 6442100 noedges = 0 6443 EdgeDone = .FALSE. 6444 6445 DO ind=1,EdgeMesh % NumberOfBulkElements 6446 6447 Element => EdgeMesh % Elements(ind) 6448 EdgeMap => GetEdgeMap( Element % TYPE % ElementCode / 100) 6449 6450 Indexes => Element % NodeIndexes 6451 6452 DO i = 1,Element % TYPE % NumberOfEdges 6453 6454 eind = Element % EdgeIndexes(i) 6455 6456 IF( EdgeDone(eind) ) CYCLE 6457 6458 noedges = noedges + 1 6459 EdgeDone(eind) = .TRUE. 6460 6461 IF( ALLOCATED( EdgeInds ) ) THEN 6462 ! Get the nodes of the edge 6463 i1 = EdgeMap(i,1) 6464 i2 = EdgeMap(i,2) 6465 6466 ! These point to the local boundary mesh 6467 k1 = Indexes( i1 ) 6468 k2 = Indexes( i2 ) 6469 6470 ! Ensure that the order of node is consistent with the global mesh 6471 ! because this is later used to check the sign of the edge. 6472 IF( EdgeMesh % InvPerm(k1) /= Mesh % Edges(eind) % NodeIndexes(1) ) THEN 6473 IF( EdgeMesh % InvPerm(k1) /= Mesh % Edges(eind) % NodeIndexes(2) ) THEN 6474 PRINT *,'We have a problem with the edges:',k1,k2 6475 END IF 6476 ktmp = k1 6477 k1 = k2 6478 k2 = ktmp 6479 END IF 6480 6481 EdgeX(1,noedges) = EdgeMesh % Nodes % x(k1) 6482 EdgeX(2,noedges) = EdgeMesh % Nodes % x(k2) 6483 6484 EdgeY(1,noedges) = EdgeMesh % Nodes % y(k1) 6485 EdgeY(2,noedges) = EdgeMesh % Nodes % y(k2) 6486 6487 ! The center of the edge (note we skip multiplication by 0.5 is it is redundant) 6488 EdgeX(3,noedges) = EdgeX(1,noedges) + EdgeX(2,noedges) 6489 EdgeY(3,noedges) = EdgeY(1,noedges) + EdgeY(2,noedges) 6490 6491 EdgeInds(noedges) = eind 6492 END IF 6493 END DO 6494 END DO 6495 6496 IF(noedges > 0 .AND. .NOT. AllocationsDone ) THEN 6497 CALL Info('CreateEdgeCenters','Allocating stuff for edges',Level=20) 6498 ALLOCATE( EdgeInds(noedges), EdgeX(3,noedges), EdgeY(3,noedges) ) 6499 AllocationsDone = .TRUE. 6500 GOTO 100 6501 END IF 6502 6503 DEALLOCATE( EdgeDone ) 6504 6505 END SUBROUTINE CreateEdgeCenters 6506 6507 6508 END SUBROUTINE ConformingEdgePerm 6509 6510 6511 6512 ! Create a permutation to eliminate nodes in a conforming case. 6513 !---------------------------------------------------------------------- 6514 SUBROUTINE ConformingNodePerm( Mesh, BMesh1, BMesh2, PerPerm, PerFlip, AntiPeriodic ) 6515 TYPE(Mesh_t), POINTER :: Mesh, BMesh1, BMesh2 6516 INTEGER, POINTER :: PerPerm(:) 6517 LOGICAL, POINTER, OPTIONAL :: PerFlip(:) 6518 LOGICAL, OPTIONAL :: AntiPeriodic 6519 !---------------------------------------------------------------------- 6520 INTEGER :: n, i1, i2, j1, j2, k1, k2, mini, samecount, doubleusecount 6521 REAL(KIND=dp) :: x1, y1, z1, x2, y2, z2 6522 REAL(KIND=dp) :: ss, minss, maxminss 6523 LOGICAL, ALLOCATABLE :: NodeUsed(:) 6524 6525 6526 CALL Info('ConformingNodePerm','Creating permutations for conforming nodes',Level=8) 6527 6528 n = 0 6529 IF( PRESENT( PerFlip ) ) n = n + 1 6530 IF( PRESENT( AntiPeriodic ) ) n = n + 1 6531 IF( n == 1 ) THEN 6532 CALL Fatal('ConformingNodePerm','Either have zero or two optional parameters!') 6533 END IF 6534 6535 n = Mesh % NumberOfNodes 6536 IF( n == 0 ) RETURN 6537 6538 IF( Bmesh1 % NumberOfNodes == 0 ) RETURN 6539 IF( Bmesh2 % NumberOfNodes == 0 ) RETURN 6540 6541 maxminss = 0.0_dp 6542 samecount = 0 6543 doubleusecount = 0 6544 6545 ALLOCATE( NodeUsed(BMesh2 % NumberOfNodes) ) 6546 NodeUsed = .FALSE. 6547 6548 DO i1=1,Bmesh1 % NumberOfNodes 6549 6550 j1 = BMesh1 % InvPerm(i1) 6551 IF( PerPerm(j1) > 0 ) CYCLE 6552 6553 x1 = BMesh1 % Nodes % x(i1) 6554 y1 = BMesh1 % Nodes % y(i1) 6555 z1 = BMesh1 % Nodes % z(i1) 6556 6557 minss = HUGE(minss) 6558 mini = 0 6559 6560 DO i2=1,Bmesh2 % NumberOfNodes 6561 x2 = BMesh2 % Nodes % x(i2) 6562 y2 = BMesh2 % Nodes % y(i2) 6563 z2 = BMesh2 % Nodes % z(i2) 6564 6565 ss = (x1-x2)**2 + (y1-y2)**2 + (z1-z2)**2 6566 IF( ss < minss ) THEN 6567 minss = ss 6568 mini = i2 6569 END IF 6570 6571 ! This should be a hit even in conservative terms. 6572 IF( minss < EPSILON( minss ) ) EXIT 6573 END DO 6574 6575 ! Assume that the closest node is a hit 6576 IF( j1 == BMesh2 % InvPerm(mini) ) THEN 6577 samecount = samecount + 1 6578 CYCLE 6579 END IF 6580 6581 IF( NodeUsed(mini ) ) THEN 6582 doubleusecount = doubleusecount + 1 6583 ELSE 6584 NodeUsed(mini) = .TRUE. 6585 END IF 6586 6587 PerPerm(j1) = BMesh2 % InvPerm(mini) 6588 6589 maxminss = MAX( maxminss, minss ) 6590 6591 IF( PRESENT( PerFlip ) ) THEN 6592 IF( AntiPeriodic ) PerFlip(j1) = .TRUE. 6593 END IF 6594 END DO 6595 6596 IF( samecount > 0 ) THEN 6597 CALL Info('ConformingNodePerm','Number of nodes are the same: '//TRIM(I2S(samecount)),Level=8) 6598 END IF 6599 6600 WRITE(Message,'(A,ES12.4)') 'Maximum minimum deviation in node coords:',SQRT(maxminss) 6601 CALL Info('ConformingNodePerm',Message,Level=8) 6602 6603 IF( doubleusecount > 0 ) THEN 6604 CALL Fatal('ConformingNodePerm','This is not conforming! Number of nodes used twice: '//TRIM(I2S(doubleusecount))) 6605 END IF 6606 6607 END SUBROUTINE ConformingNodePerm 6608 !---------------------------------------------------------------------- 6609 6610 6611 6612 !--------------------------------------------------------------------------- 6613 !> Create a projector for mixed nodal / edge problems assuming constant level 6614 !> in the 2nd direction. This kind of projector is suitable for 2D meshes where 6615 !> the mortar line is effectively 1D, or to 3D cases that have been created by 6616 !> extrusion. 6617 !--------------------------------------------------------------------------- 6618 FUNCTION LevelProjector( BMesh1, BMesh2, Repeating, AntiRepeating, & 6619 FullCircle, Radius, DoNodes, DoEdges, NodeScale, EdgeScale, BC ) & 6620 RESULT ( Projector ) 6621 !--------------------------------------------------------------------------- 6622 USE Lists 6623 USE Messages 6624 USE Types 6625 USE GeneralUtils 6626 IMPLICIT NONE 6627 6628 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2, Mesh 6629 LOGICAL :: DoNodes, DoEdges 6630 LOGICAL :: Repeating, AntiRepeating, FullCircle, NotAllQuads, NotAllQuads2 6631 REAL(KIND=dp) :: Radius, NodeScale, EdgeScale 6632 TYPE(ValueList_t), POINTER :: BC 6633 TYPE(Matrix_t), POINTER :: Projector 6634 !-------------------------------------------------------------------------- 6635 INTEGER, POINTER :: InvPerm1(:), InvPerm2(:) 6636 LOGICAL :: StrongNodes, StrongEdges, StrongLevelEdges, StrongExtrudedEdges, & 6637 StrongSkewEdges, StrongConformingEdges, StrongConformingNodes 6638 LOGICAL :: Found, Parallel, SelfProject, EliminateUnneeded, SomethingUndone, & 6639 EdgeBasis, PiolaVersion, GenericIntegrator, Rotational, Cylindrical, WeakProjector, & 6640 StrongProjector, CreateDual, HaveMaxDistance 6641 REAL(KIND=dp) :: XmaxAll, XminAll, YminAll, YmaxAll, Xrange, Yrange, & 6642 RelTolX, RelTolY, XTol, YTol, RadTol, MaxSkew1, MaxSkew2, SkewTol, & 6643 ArcCoeff, EdgeCoeff, NodeCoeff, MaxDistance 6644 INTEGER :: NoNodes1, NoNodes2, MeshDim 6645 INTEGER :: i,j,k,n,m,Nrange,Nrange2, nrow, Naxial 6646 INTEGER, ALLOCATABLE :: EdgePerm(:),NodePerm(:),DualNodePerm(:) 6647 INTEGER :: EdgeRow0, FaceRow0, EdgeCol0, FaceCol0, ProjectorRows 6648 TYPE(Element_t), POINTER :: Element 6649 INTEGER, POINTER :: NodeIndexes(:) 6650 REAL(KIND=dp), ALLOCATABLE :: Cond(:) 6651 TYPE(Matrix_t), POINTER :: DualProjector 6652 LOGICAL :: DualMaster, DualSlave, DualLCoeff, BiorthogonalBasis 6653 LOGICAL :: SecondOrder 6654 6655 CALL Info('LevelProjector','Creating projector for a levelized mesh',Level=7) 6656 6657 IF(.NOT. (DoEdges .OR. DoNodes ) ) THEN 6658 CALL Warn('LevelProjector','Nothing to do, no nonodes, no edges!') 6659 RETURN 6660 END IF 6661 6662 EdgeCoeff = ListGetConstReal( BC,'Projector Edge Multiplier',Found ) 6663 IF( .NOT. Found ) EdgeCoeff = ListGetConstReal( CurrentModel % Simulation,& 6664 'Projector Edge Multiplier',Found ) 6665 IF( .NOT. Found ) EdgeCoeff = 1.0_dp 6666 6667 NodeCoeff = ListGetConstReal( BC,'Projector Node Multiplier',Found ) 6668 IF( .NOT. Found ) NodeCoeff = ListGetConstReal( CurrentModel % Simulation,& 6669 'Projector Node Multiplier',Found ) 6670 IF( .NOT. Found ) NodeCoeff = 1.0_dp 6671 6672 Rotational = ListGetLogical( BC,'Rotational Projector',Found ) .OR. & 6673 ListGetLogical( BC,'Anti Rotational Projector',Found ) 6674 Cylindrical = ListGetLogical( BC,'Cylindrical Projector',Found ) 6675 6676 MaxDistance = ListGetCReal( BC,'Projector Max Distance', HaveMaxDistance) 6677 IF(.NOT. HaveMaxDistance ) THEN 6678 MaxDistance = ListGetCReal( CurrentModel % Solver % Values,& 6679 'Projector Max Distance', HaveMaxDistance) 6680 END IF 6681 6682 Naxial = ListGetInteger( BC,'Axial Projector Periods',Found ) 6683 6684 Parallel = ( ParEnv % PEs > 1 ) 6685 Mesh => CurrentModel % Mesh 6686 BMesh1 % Parent => NULL() 6687 BMesh2 % Parent => NULL() 6688 6689 ! Create a projector in style P=I-Q, or rather just P=Q. 6690 SelfProject = .TRUE. 6691 6692 ! Range is needed to define tolerances, and to map the angle in case 6693 ! the master mesh is treated as a repeating structure. 6694 XMaxAll = MAXVAL(BMesh2 % Nodes % x) 6695 XMinAll = MINVAL(BMesh2 % Nodes % x) 6696 XRange = XMaxAll - XMinAll 6697 6698 YMaxAll = MAXVAL(BMesh2 % Nodes % y) 6699 YMinAll = MINVAL(BMesh2 % Nodes % y) 6700 YRange = YMaxAll - YMinAll 6701 6702 ! Fix here the relative tolerance used to define the search tolerance 6703 RelTolY = 1.0d-4 6704 ! In the case of infinite target we can have tighter criteria 6705 IF( FullCircle .OR. Repeating ) THEN 6706 RelTolX = 1.0d-6 6707 ELSE 6708 RelTolX = RelTolY 6709 END IF 6710 YTol = RelTolY * YRange 6711 XTol = RelTolX * XRange 6712 6713 ! Determine the coefficient that turns possible angles into units of 6714 ! ach-lenth. If this is not rotational then there are no angles. 6715 IF( Rotational .OR. Cylindrical ) THEN 6716 ArcCoeff = (2*PI*Radius)/360.0_dp 6717 ELSE 6718 ArcCoeff = 1.0_dp 6719 END IF 6720 6721 ! We have a weak projector if it is requested 6722 WeakProjector = ListGetLogical( BC, 'Galerkin Projector', Found ) 6723 6724 StrongProjector = ListGetLogical( BC,'Level Projector Strong',Found ) 6725 IF( StrongProjector .AND. WeakProjector ) THEN 6726 CALL Fatal('LevelProjector','Projector cannot be weak (Galerkin) and strong at the same time!') 6727 END IF 6728 6729 MeshDim = Mesh % MeshDim 6730 IF( MeshDim == 3 ) THEN 6731 Element => BMesh1 % Elements(1) 6732 IF( Element % TYPE % DIMENSION == 1 ) THEN 6733 CALL Warn('LevelProjector','Enforcing 1D integration for 1D boundary elements in 3D mesh!') 6734 MeshDim = 2 6735 END IF 6736 END IF 6737 6738 ! Generic integrator does not make any assumptions on the way the mesh 6739 ! is constructured. Otherwise constant strides in y-direction is assumed. 6740 ! For weak strategy always use the generic integrator. 6741 GenericIntegrator = ListGetLogical( BC,'Level Projector Generic',Found ) 6742 IF(.NOT. Found ) GenericIntegrator = WeakProjector 6743 6744 ! Maximum skew in degrees before treating edges as skewed 6745 SkewTol = 0.1_dp 6746 6747 ! Check whether generic integrator should be enforced 6748 IF( DoEdges .AND. .NOT. GenericIntegrator ) THEN 6749 IF( Naxial > 0 ) THEN 6750 GenericIntegrator = .TRUE. 6751 CALL Info('LevelProjector','Generic integrator enforced for axial projector',Level=6) 6752 END IF 6753 6754 ! It is assumed that that the target mesh is always un-skewed 6755 ! Make a test here to be able to skip it later. No test is needed 6756 ! if the generic integrator is enforced. 6757 IF(.NOT. GenericIntegrator ) THEN 6758 MaxSkew1 = CheckMeshSkew( BMesh1, NotAllQuads ) 6759 IF( NotAllQuads ) THEN 6760 CALL Info('LevelProjector','This mesh has also triangles',Level=8) 6761 END IF 6762 WRITE( Message,'(A,ES12.3)') 'Maximum skew in this mesh: ',MaxSkew1 6763 CALL Info('LevelProjector',Message,Level=8) 6764 6765 MaxSkew2 = CheckMeshSkew( BMesh2, NotAllQuads2 ) 6766 IF( NotAllQuads2 ) THEN 6767 CALL Info('LevelProjector','Target mesh has also triangles',Level=8) 6768 END IF 6769 WRITE( Message,'(A,ES12.3)') 'Maximum skew in target mesh: ',MaxSkew2 6770 CALL Info('LevelProjector',Message,Level=8) 6771 6772 IF( NotAllQuads .OR. NotAllQuads2 .OR. MaxSkew2 > SkewTol ) THEN 6773 IF( MaxSkew2 > MaxSkew1 .AND. MaxSkew1 < SkewTol ) THEN 6774 CALL Warn('LevelProjector','You could try switching the master and target BC!') 6775 END IF 6776 CALL Warn('LevelProjector','Target mesh has too much skew, using generic integrator when needed!') 6777 GenericIntegrator = .TRUE. 6778 END IF 6779 END IF 6780 6781 IF( GenericIntegrator ) THEN 6782 CALL Info('LevelProjector','Edge projection for the BC requires weak projector!',Level=7) 6783 CALL Fatal('LevelProjector','We cannot use fully strong projector as wished in this geometry!') 6784 END IF 6785 END IF 6786 6787 ! The projectors for nodes and edges can be created either in a strong way 6788 ! or weak way in the special case that the nodes are located in extruded layers. 6789 ! The strong way results to a sparse projector. For constant 6790 ! levels it can be quite optimal, except for the edges with a skew. 6791 ! If strong projector is used for all edges then "StrideProjector" should 6792 ! be recovered. 6793 6794 IF( DoNodes ) THEN 6795 StrongNodes = ListGetLogical( BC,'Level Projector Nodes Strong',Found ) 6796 6797 StrongConformingNodes = ListGetLogical( BC,'Level Projector Conforming Nodes Strong', Found ) 6798 6799 IF(.NOT. Found) StrongNodes = ListGetLogical( BC,'Level Projector Strong',Found ) 6800 IF(.NOT. Found) StrongNodes = .NOT. GenericIntegrator 6801 END IF 6802 6803 IF( DoEdges ) THEN 6804 StrongEdges = ListGetLogical( BC,'Level Projector Strong',Found ) 6805 IF(.NOT. Found ) StrongEdges = ListGetLogical( BC,'Level Projector Plane Edges Strong', Found ) 6806 IF(.NOT. Found ) StrongEdges = .NOT. GenericIntegrator 6807 6808 StrongLevelEdges = ListGetLogical( BC,'Level Projector Plane Edges Strong', Found ) 6809 IF( .NOT. Found ) StrongLevelEdges = StrongEdges 6810 IF( StrongLevelEdges .AND. GenericIntegrator ) THEN 6811 CALL Info('LevelProjector','Using strong level edges with partially weak projector',Level=7) 6812 END IF 6813 6814 StrongConformingEdges = ListGetLogical( BC,'Level Projector Conforming Edges Strong', Found ) 6815 6816 StrongExtrudedEdges = ListGetLogical( BC,'Level Projector Extruded Edges Strong', Found ) 6817 IF( .NOT. Found ) StrongExtrudedEdges = StrongEdges 6818 IF( StrongExtrudedEdges .AND. GenericIntegrator ) THEN 6819 CALL Info('LevelProjector','Using strong extruded edges with partially weak projector',Level=7) 6820 END IF 6821 6822 ! There is no strong strategy for skewed edges currently 6823 StrongSkewEdges = .FALSE. 6824 END IF 6825 6826 6827 ! If the number of periods is enforced use that instead since 6828 ! the Xrange periodicity might not be correct if the mesh has skew. 6829 IF( Rotational ) THEN 6830 IF( FullCircle ) THEN 6831 Xrange = 360.0_dp 6832 ELSE 6833 i = ListGetInteger( BC,'Rotational Projector Periods',Found,minv=1 ) 6834 IF( GenericIntegrator .AND. .NOT. Found ) THEN 6835 CALL Fatal('LevelProjector',& 6836 'Generic integrator requires > Rotational Projector Periods <') 6837 END IF 6838 Xrange = 360.0_dp / i 6839 END IF 6840 END IF 6841 6842 ! This is the tolerance used to define constant direction in radians 6843 ! For consistency it should not be sloppier than the SkewTol 6844 ! but it could be equally sloppy as below. 6845 RadTol = PI * SkewTol / 180.0_dp 6846 6847 ! Given the inverse permutation compute the initial number of 6848 ! nodes in both cases. 6849 NoNodes1 = BMesh1 % NumberOfNodes 6850 NoNodes2 = BMesh2 % NumberOfNodes 6851 6852 InvPerm1 => BMesh1 % InvPerm 6853 InvPerm2 => BMesh2 % InvPerm 6854 6855 ! Create a list matrix that allows for unspecified entries in the matrix 6856 ! structure to be introduced. 6857 Projector => AllocateMatrix() 6858 Projector % FORMAT = MATRIX_LIST 6859 Projector % ProjectorType = PROJECTOR_TYPE_GALERKIN 6860 6861 CreateDual = ListGetLogical( BC,'Create Dual Projector',Found ) 6862 IF( CreateDual ) THEN 6863 DualProjector => AllocateMatrix() 6864 DualProjector % FORMAT = MATRIX_LIST 6865 DualProjector % ProjectorType = PROJECTOR_TYPE_GALERKIN 6866 Projector % EMatrix => DualProjector 6867 END IF 6868 6869 ! Check whether biorthogonal basis for projectors requested: 6870 ! ---------------------------------------------------------- 6871 BiOrthogonalBasis = ListGetLogical( BC, 'Use Biorthogonal Basis', Found) 6872 6873 ! If we want to eliminate the constraints we have to have a biortgonal basis 6874 IF(.NOT. Found ) THEN 6875 BiOrthogonalBasis = ListGetLogical( CurrentModel % Solver % Values, & 6876 'Eliminate Linear Constraints',Found ) 6877 IF( BiOrthogonalBasis ) THEN 6878 CALL Info('LevelProjector',& 6879 'Enforcing > Use Biorthogonal Basis < to True to enable elimination',Level=8) 6880 CALL ListAddLogical( BC, 'Use Biorthogonal Basis',.TRUE. ) 6881 END IF 6882 END IF 6883 6884 IF (BiOrthogonalBasis) THEN 6885 IF( DoEdges ) THEN 6886 CALL Warn('LevelProjector','Biorthogonal basis cannot be combined with edge elements!') 6887 END IF 6888 6889 DualSlave = ListGetLogical(BC, 'Biorthogonal Dual Slave', Found) 6890 IF(.NOT.Found) DualSlave = .TRUE. 6891 6892 DualMaster = ListGetLogical(BC, 'Biorthogonal Dual Master', Found) 6893 IF(.NOT.Found) DualMaster = .TRUE. 6894 6895 DualLCoeff = ListGetLogical(BC, 'Biorthogonal Dual Lagrange Coefficients', Found) 6896 IF(.NOT.Found) DualLCoeff = .FALSE. 6897 6898 IF(DualLCoeff) THEN 6899 DualSlave = .FALSE. 6900 DualMaster = .FALSE. 6901 CALL ListAddLogical( CurrentModel % Solver % Values, 'Use Transpose Values',.FALSE.) 6902 ELSE 6903 CALL ListAddLogical( CurrentModel % Solver % Values, 'Use Transpose Values',.TRUE.) 6904 END IF 6905 6906 Projector % Child => AllocateMatrix() 6907 Projector % Child % Format = MATRIX_LIST 6908 CALL Info('LevelProjector','Using biorthogonal basis, as requested',Level=8) 6909 END IF 6910 6911 6912 PiolaVersion = ListGetLogical( CurrentModel % Solver % Values, & 6913 'Use Piola Transform', Found) 6914 SecondOrder = ListGetLogical( CurrentModel % Solver % Values, & 6915 'Quadratic Approximation', Found) 6916 6917 ! At the 1st stage determine the maximum size of the projector 6918 ! If the strong projector is used then the numbering is done as we go 6919 ! this way we can eliminate unneeded rows. 6920 ! For the weak projector there is no need to eliminate rows. 6921 IF( DoNodes ) THEN 6922 ALLOCATE( NodePerm( Mesh % NumberOfNodes ) ) 6923 NodePerm = 0 6924 6925 ! in parallel only consider nodes that truly are part of this partition 6926 DO i=1,BMesh1 % NumberOfBulkElements 6927 Element => BMesh1 % Elements(i) 6928 IF( Parallel ) THEN 6929 IF( Element % PartIndex /= ParEnv % MyPe ) CYCLE 6930 END IF 6931 NodePerm( InvPerm1( Element % NodeIndexes ) ) = 1 6932 END DO 6933 6934 n = SUM( NodePerm ) 6935 CALL Info('LevelProjector','Initial number of slave nodes '//TRIM(I2S(n))//& 6936 ' out of '//TRIM(I2S(BMesh1 % NumberOfNodes ) ), Level = 10 ) 6937 6938 ! Eliminate the redundant nodes by default. 6939 ! These are noded that depend on themselves. 6940 EliminateUnneeded = ListGetLogical( BC,& 6941 'Level Projector Eliminate Redundant Nodes',Found ) 6942 IF(.NOT. Found ) EliminateUnneeded = .TRUE. 6943 6944 IF( EliminateUnneeded ) THEN 6945 m = 0 6946 n = SUM( NodePerm ) 6947 CALL Info('LevelProjector',& 6948 'Number of potential nodes in projector: '//TRIM(I2S(n)),Level=10) 6949 ! Now eliminate the nodes which also occur in the other mesh 6950 ! These must be redundant edges 6951 DO i=1, SIZE(InvPerm2) 6952 j = InvPerm2(i) 6953 IF( NodePerm(j) /= 0 ) THEN 6954 NodePerm(j) = 0 6955 !PRINT *,'Removing node:',j,Mesh % Nodes % x(j), Mesh % Nodes % y(j) 6956 m = m + 1 6957 END IF 6958 END DO 6959 IF( m > 0 ) THEN 6960 CALL Info('LevelProjector',& 6961 'Eliminating redundant nodes from projector: '//TRIM(I2S(m)),Level=10) 6962 END IF 6963 END IF 6964 6965 IF( CreateDual ) THEN 6966 ALLOCATE( DualNodePerm( Mesh % NumberOfNodes ) ) 6967 DualNodePerm = 0 6968 6969 DO i=1,BMesh2 % NumberOfBulkElements 6970 Element => BMesh2 % Elements(i) 6971 IF( Parallel ) THEN 6972 IF( Element % PartIndex /= ParEnv % MyPe ) CYCLE 6973 END IF 6974 DualNodePerm( InvPerm2( Element % NodeIndexes ) ) = 1 6975 END DO 6976 6977 IF( EliminateUnneeded ) THEN 6978 m = 0 6979 n = SUM( DualNodePerm ) 6980 CALL Info('LevelProjector',& 6981 'Number of potential nodes in dual projector: '//TRIM(I2S(n)),Level=10) 6982 ! Now eliminate the nodes which also occur in the other mesh 6983 ! These must be redundant edges 6984 DO i=1, SIZE(InvPerm1) 6985 j = InvPerm1(i) 6986 IF( DualNodePerm(j) /= 0 ) THEN 6987 DualNodePerm(j) = 0 6988 PRINT *,'Removing dual node:',j,Mesh % Nodes % x(j), Mesh % Nodes % y(j) 6989 m = m + 1 6990 END IF 6991 END DO 6992 IF( m > 0 ) THEN 6993 CALL Info('LevelProjector',& 6994 'Eliminating redundant dual nodes from projector: '//TRIM(I2S(m)),Level=10) 6995 END IF 6996 END IF 6997 END IF 6998 6999 IF( ListCheckPresent( BC,'Level Projector Condition') ) THEN 7000 ALLOCATE( Cond( Mesh % MaxElementNodes ) ) 7001 Cond = 1.0_dp 7002 m = 0 7003 DO i=1, BMesh1 % NumberOfBulkElements 7004 Element => Mesh % Elements( BMesh1 % Elements(i) % ElementIndex ) 7005 CurrentModel % CurrentElement => Element 7006 n = Element % TYPE % NumberOfNodes 7007 NodeIndexes => Element % NodeIndexes 7008 Cond(1:n) = ListGetReal( BC,'Level Projector Condition', n, NodeIndexes ) 7009 DO j=1,n 7010 k = NodeIndexes(j) 7011 IF( NodePerm(k) /= 0 ) THEN 7012 IF( Cond(j) < 0.0 ) THEN 7013 m = m + 1 7014 NodePerm(k) = 0 7015 END IF 7016 END IF 7017 END DO 7018 END DO 7019 CALL Info('LevelProjector','Eliminated nodes with negative condition: '//& 7020 TRIM(I2S(m)),Level=10) 7021 DEALLOCATE( Cond ) 7022 END IF 7023 7024 m = 0 7025 DO i=1,Mesh % NumberOfNodes 7026 IF( NodePerm(i) > 0 ) THEN 7027 m = m + 1 7028 NodePerm(i) = m 7029 END IF 7030 END DO 7031 7032 CALL Info('LevelProjector',& 7033 'Number of active nodes in projector: '//TRIM(I2S(m)),Level=8) 7034 EdgeRow0 = m 7035 7036 IF( CreateDual ) THEN 7037 m = 0 7038 DO i=1,Mesh % NumberOfNodes 7039 IF( DualNodePerm(i) > 0 ) THEN 7040 m = m + 1 7041 DualNodePerm(i) = m 7042 END IF 7043 END DO 7044 ALLOCATE( DualProjector % InvPerm(m) ) 7045 DualProjector % InvPerm = 0 7046 7047 IF( DoEdges ) THEN 7048 CALL Fatal('LevelProjector','Dual projector cannot handle edges!') 7049 END IF 7050 END IF 7051 ELSE 7052 EdgeRow0 = 0 7053 END IF 7054 ProjectorRows = EdgeRow0 7055 7056 IF( DoEdges ) THEN 7057 ALLOCATE( EdgePerm( Mesh % NumberOfEdges ) ) 7058 EdgePerm = 0 7059 7060 ! Mark the edges for which the projector must be created for 7061 DO i=1, BMesh1 % NumberOfBulkElements 7062 7063 ! in parallel only consider face elements that truly are part of this partition 7064 IF( Parallel ) THEN 7065 IF( BMesh1 % Elements(i) % PartIndex /= ParEnv % MyPe ) CYCLE 7066 END IF 7067 7068 DO j=1, BMesh1 % Elements(i) % TYPE % NumberOfEdges 7069 EdgePerm( BMesh1 % Elements(i) % EdgeIndexes(j) ) = 1 7070 END DO 7071 END DO 7072 7073 EliminateUnneeded = ListGetLogical( BC,& 7074 'Level Projector Eliminate Redundant Edges',Found ) 7075 IF(.NOT. Found ) EliminateUnneeded = .TRUE. 7076 7077 IF( EliminateUnneeded ) THEN 7078 n = SUM( EdgePerm ) 7079 CALL Info('LevelProjector',& 7080 'Number of potential edges in projector: '//TRIM(I2S(n)),Level=10) 7081 ! Now eliminate the edges which also occur in the other mesh 7082 ! These must be redundant edges 7083 DO i=1, BMesh2 % NumberOfBulkElements 7084 DO j=1, BMesh2 % Elements(i) % TYPE % NumberOfEdges 7085 EdgePerm( BMesh2 % Elements(i) % EdgeIndexes(j) ) = 0 7086 END DO 7087 END DO 7088 7089 IF( DoNodes ) THEN 7090 IF( ListGetLogical( BC,'Level Projector Eliminate Edges Greedy',Found ) ) THEN 7091 DO i=1, BMesh1 % NumberOfBulkElements 7092 DO j=1, BMesh1 % Elements(i) % TYPE % NumberOfEdges 7093 k = BMesh1 % Elements(i) % EdgeIndexes(j) 7094 IF( ANY( NodePerm( Mesh % Edges(k) % NodeIndexes ) == 0 ) ) THEN 7095 EdgePerm( k ) = 0 7096 END IF 7097 END DO 7098 END DO 7099 END IF 7100 END IF 7101 END IF 7102 7103 m = 0 7104 DO i=1,Mesh % NumberOfEdges 7105 IF( EdgePerm(i) > 0 ) THEN 7106 m = m + 1 7107 EdgePerm(i) = m 7108 END IF 7109 END DO 7110 7111 IF( EliminateUnneeded ) THEN 7112 CALL Info('LevelProjector',& 7113 'Eliminating redundant edges from projector: '//TRIM(I2S(n-m)),Level=10) 7114 END IF 7115 CALL Info('LevelProjector',& 7116 'Number of active edges in projector: '//TRIM(I2S(m)),Level=8) 7117 IF (SecondOrder) THEN 7118 FaceRow0 = EdgeRow0 + 2*m 7119 ELSE 7120 FaceRow0 = EdgeRow0 + m 7121 END IF 7122 ProjectorRows = FaceRow0 7123 7124 IF( PiolaVersion ) THEN 7125 ! Note: this might not work in parallel with halo since some of the face elements 7126 ! do not then belong to the slave boundary. 7127 m = 0 7128 DO i=1,BMesh1 % NumberOfBulkElements 7129 m = m + BMesh1 % Elements(i) % BDOFs 7130 END DO 7131 CALL Info('LevelProjector',& 7132 'Number of active faces in projector: '//TRIM(I2S(BMesh1 % NumberOfBulkElements)),Level=8) 7133 CALL Info('LevelProjector',& 7134 'Number of active face DOFs in projector: '//TRIM(I2S(m)),Level=8) 7135 ProjectorRows = FaceRow0 + m 7136 END IF 7137 END IF 7138 7139 CALL Info('LevelProjector',& 7140 'Max number of rows in projector: '//TRIM(I2S(ProjectorRows)),Level=10) 7141 ALLOCATE( Projector % InvPerm(ProjectorRows) ) 7142 Projector % InvPerm = 0 7143 7144 ! If after strong projectors there are still something undone they must 7145 ! be dealt with the weak projectors. 7146 SomethingUndone = .FALSE. 7147 7148 ! If requested, create strong mapping for node dofs 7149 !------------------------------------------------------------------ 7150 IF( DoNodes ) THEN 7151 IF( StrongConformingNodes ) THEN 7152 CALL AddNodeProjectorStrongConforming() 7153 ELSE IF( StrongNodes ) THEN 7154 IF( GenericIntegrator ) THEN 7155 CALL AddNodalProjectorStrongGeneric() 7156 ELSE 7157 CALL AddNodalProjectorStrongStrides() 7158 END IF 7159 ELSE 7160 ! If strong projector is applied they can deal with all nodal dofs 7161 SomethingUndone = .TRUE. 7162 END IF 7163 END IF 7164 7165 ! If requested, create strong mapping for edge dofs 7166 !------------------------------------------------------------- 7167 EdgeBasis = .FALSE. 7168 IF( DoEdges ) THEN 7169 EdgeCol0 = Mesh % NumberOfNodes 7170 IF (SecondOrder) THEN 7171 FaceCol0 = Mesh % NumberOfNodes + 2 * Mesh % NumberOfEdges 7172 ELSE 7173 FaceCol0 = Mesh % NumberOfNodes + Mesh % NumberOfEdges 7174 END IF 7175 7176 IF( StrongLevelEdges .OR. StrongExtrudedEdges .OR. StrongConformingEdges ) THEN 7177 IF( StrongConformingEdges ) THEN 7178 CALL AddEdgeProjectorStrongConforming() 7179 ELSE 7180 CALL AddEdgeProjectorStrongStrides() 7181 END IF 7182 ! Compute the unset edge dofs. 7183 ! Some of the dofs may have been set by the strong projector. 7184 m = COUNT( EdgePerm > 0 ) 7185 IF( m > 0 ) THEN 7186 CALL Info('LevelProjector',& 7187 'Number of weak edges in projector: '//TRIM(I2S(m)),Level=10) 7188 END IF 7189 IF( m > 0 .OR. PiolaVersion) THEN 7190 SomethingUndone = .TRUE. 7191 EdgeBasis = .TRUE. 7192 END IF 7193 ELSE 7194 SomethingUndone = .TRUE. 7195 EdgeBasis = .TRUE. 7196 END IF 7197 END IF 7198 7199 ! And the the rest 7200 !------------------------------------------------------------- 7201 IF( SomethingUndone ) THEN 7202 IF( MeshDim == 2 ) THEN 7203 CALL Info('LevelProjector','Initial mesh is 2D, using 1D projectors!',Level=10) 7204 CALL AddProjectorWeak1D() 7205 ELSE IF( GenericIntegrator ) THEN 7206 CALL AddProjectorWeakGeneric() 7207 ELSE 7208 CALL AddProjectorWeakStrides() 7209 END IF 7210 END IF 7211 7212 ! Now change the matrix format to CRS from list matrix 7213 !-------------------------------------------------------------- 7214 CALL List_toCRSMatrix(Projector) 7215 CALL CRS_SortMatrix(Projector,.TRUE.) 7216 CALL Info('LevelProjector','Number of rows in projector: '& 7217 //TRIM(I2S(Projector % NumberOfRows)),Level=12) 7218 CALL Info('LevelProjector','Number of entries in projector: '& 7219 //TRIM(I2S(SIZE(Projector % Values))),Level=12) 7220 7221 7222 IF(ASSOCIATED(Projector % Child)) THEN 7223 CALL List_toCRSMatrix(Projector % Child) 7224 CALL CRS_SortMatrix(Projector % Child,.TRUE.) 7225 END IF 7226 7227 IF( CreateDual ) THEN 7228 CALL List_toCRSMatrix(DualProjector) 7229 CALL CRS_SortMatrix(DualProjector,.TRUE.) 7230 END IF 7231 7232 IF( DoNodes ) DEALLOCATE( NodePerm ) 7233 IF( CreateDual .AND. DoNodes ) DEALLOCATE( DualNodePerm ) 7234 IF( DoEdges ) DEALLOCATE( EdgePerm ) 7235 7236 m = COUNT( Projector % InvPerm == 0 ) 7237 IF( m > 0 ) THEN 7238 CALL Warn('LevelProjector','Projector % InvPerm not set in for dofs: '//TRIM(I2S(m))) 7239 END IF 7240 7241 CALL Info('LevelProjector','Projector created',Level=10) 7242 7243 CONTAINS 7244 7245 ! Currently the target mesh is assumed to be include only cartesian elements 7246 ! Check the angle in the elements. When we know the target mesh is cartesian 7247 ! we can reduce the error control in the other parts of the code. 7248 !---------------------------------------------------------------------------- 7249 FUNCTION CheckMeshSkew(BMesh, NotAllQuads) RESULT( MaxSkew ) 7250 7251 TYPE(Mesh_t),POINTER :: BMesh 7252 REAL(KIND=dp) :: MaxSkew 7253 LOGICAL :: NotAllQuads 7254 7255 INTEGER :: i,j,n,indM,k,knext,kprev 7256 TYPE(Element_t), POINTER :: ElementM 7257 TYPE(Nodes_t) :: NodesM 7258 REAL(KIND=dp) :: e1(2),e2(2),DotProdM, PhiM 7259 INTEGER, POINTER :: IndexesM(:) 7260 7261 CALL Info('CheckMeshSkew','Checking mesh skew') 7262 7263 n = 4 7264 ALLOCATE( NodesM % x(n), NodesM % y(n) ) 7265 MaxSkew = 0.0_dp 7266 NotAllQuads = .FALSE. 7267 7268 j = 0 7269 DO indM=1,BMesh % NumberOfBulkElements 7270 7271 ElementM => BMesh % Elements(indM) 7272 n = ElementM % TYPE % ElementCode / 100 7273 IF( n /= 4 ) THEN 7274 NotAllQuads = .TRUE. 7275 END IF 7276 IndexesM => ElementM % NodeIndexes 7277 NodesM % y(1:n) = BMesh % Nodes % y(IndexesM(1:n)) 7278 NodesM % x(1:n) = BMesh % Nodes % x(IndexesM(1:n)) 7279 7280 ! Transfer into real length units instead of angles 7281 ! This gives right balance between x and y -directions. 7282 NodesM % x(1:n) = ArcCoeff * NodesM % x(1:n) 7283 7284 ! Make unit vectors of the edge 7285 DO k = 1, n 7286 knext = MODULO(k,n)+1 7287 kprev = MODULO(n+k-2,n)+1 7288 7289 e1(1) = NodesM % x(knext) - NodesM % x(k) 7290 e1(2) = NodesM % y(knext) - NodesM % y(k) 7291 7292 e2(1) = NodesM % x(kprev) - NodesM % x(k) 7293 e2(2) = NodesM % y(kprev) - NodesM % y(k) 7294 7295 e1 = e1 / SQRT( SUM( e1**2) ) 7296 e2 = e2 / SQRT( SUM( e2**2) ) 7297 7298 ! dot product of the unit vectors 7299 DotProdM = SUM( e1 * e2 ) 7300 7301 ! Cosine angle in degrees 7302 PhiM = ACOS( DotProdM ) 7303 MaxSkew = MAX( MaxSkew, ABS ( ABS( PhiM ) - PI/2 ) ) 7304 END DO 7305 END DO 7306 7307 ! Move to degrees and give the tolerance in them 7308 MaxSkew = MaxSkew * 180.0_dp / PI 7309 7310100 DEALLOCATE( NodesM % x, NodesM % y ) 7311 7312 END FUNCTION CheckMeshSkew 7313 7314 7315 !------------------------------------------------------------------------------------- 7316 ! Create projector for nodes on the strides directly from a linear 7317 ! combination of two nodes. This approach minimizes the size of the projector 7318 ! and also minimizes the need for parallel communication. 7319 !------------------------------------------------------------------------------------- 7320 SUBROUTINE AddNodalProjectorStrongStrides() 7321 7322 TYPE(Element_t), POINTER :: ElementM 7323 INTEGER, POINTER :: IndexesM(:) 7324 INTEGER :: ncoeff, coeffi(2),sgn0, ind, indm, j1, j2, j3, Nundefined 7325 REAL(KIND=dp) :: x1, y1, x2, y2, xmin, xmax, xminm, xmaxm, Dist, MinDist 7326 REAL(KIND=dp) :: coeff(2), val, xm1, xm2, xm3 7327 INTEGER, POINTER :: EdgeMap(:,:) 7328 TYPE(Nodes_t) :: NodesM 7329 LOGICAL :: LeftCircle 7330 7331 CALL Info('AddNodalProjectorStrongStrides','Creating strong stride projector for nodal dofs',Level=10) 7332 7333 n = Mesh % MaxElementNodes 7334 ALLOCATE( NodesM % x(n), NodesM % y(n), NodesM % z(n) ) 7335 NodesM % z = 0.0_dp 7336 7337 ! By construction there is always two components in the projector for the nodes. 7338 ncoeff = 2 7339 coeffi = 0 7340 sgn0 = 1 7341 Nundefined = 0 7342 7343 ! This flag tells if we're working with a full circle and the problematic part of 7344 ! the circle with the discontinuity in the angle. 7345 LeftCircle = .FALSE. 7346 7347 DO ind=1,BMesh1 % NumberOfNodes 7348 7349 nrow = NodePerm( InvPerm1( ind ) ) 7350 IF( nrow == 0 ) CYCLE 7351 NodePerm( InvPerm1( ind ) ) = 0 7352 Projector % InvPerm(nrow) = InvPerm1(ind) 7353 7354 Found = .FALSE. 7355 x1 = BMesh1 % Nodes % x(ind) 7356 y1 = BMesh1 % Nodes % y(ind) 7357 sgn0 = 1 7358 coeff = 0.0_dp 7359 MinDist = HUGE( MinDist ) 7360 7361 IF( Repeating ) THEN 7362 Nrange = FLOOR( (x1-XMinAll) / XRange ) 7363 x1 = x1 - Nrange * XRange 7364 7365 IF( AntiRepeating ) THEN 7366 IF ( MODULO(Nrange,2) /= 0 ) sgn0 = -1 7367 END IF 7368 ELSE IF( FullCircle ) THEN 7369 LeftCircle = ABS( x1 ) > 90.0_dp 7370 IF( LeftCircle ) THEN 7371 IF( x1 < 0.0 ) x1 = x1 + 360.0_dp 7372 END IF 7373 END IF 7374 7375 ! If the projector is of style Px+Qx=0 then 7376 ! and the negative sign, otherwise let the initial sign be. 7377 IF( SelfProject ) sgn0 = -sgn0 7378 7379 ! Currently a cheap n^2 loop but it could be improved 7380 ! Looping over master elements. Look for constant-y strides only. 7381 !-------------------------------------------------------------------- 7382 DO indM = 1, BMesh2 % NumberOfBulkElements 7383 7384 ElementM => BMesh2 % Elements(indM) 7385 n = ElementM % TYPE % NumberOfNodes 7386 IndexesM => ElementM % NodeIndexes 7387 7388 ! Quick tests to save time 7389 ! Element must have nodes at the right level 7390 NodesM % y(1:n) = BMesh2 % Nodes % y(IndexesM(1:n)) 7391 IF( ALL( ABS( NodesM % y(1:n) - y1 ) > YTol ) ) CYCLE 7392 7393 ! The x nodes should be in the interval 7394 NodesM % x(1:n) = BMesh2 % Nodes % x(IndexesM(1:n)) 7395 7396 ! Transform the master element on-the-fly around the problematic angle 7397 IF( LeftCircle ) THEN 7398 ! The master nodes are all on right 7399 IF( ALL( ABS( NodesM % x(1:n) ) - 90.0_dp < Xtol ) ) CYCLE 7400 DO j=1,n 7401 IF( NodesM % x(j) < 0.0 ) NodesM % x(j) = NodesM % x(j) + 360.0_dp 7402 END DO 7403 END IF 7404 7405 xmaxm = MAXVAL( NodesM % x(1:n) ) 7406 xminm = MINVAL( NodesM % x(1:n) ) 7407 7408 ! Eliminate this special case since it could otherwise give a faulty hit 7409 IF( FullCircle .AND. .NOT. LeftCircle ) THEN 7410 IF( xmaxm - xminm > 180.0_Dp ) CYCLE 7411 END IF 7412 7413 Dist = MAX( x1-xmaxm, xminm-x1 ) 7414 7415 ! Mark the minimum distance if this would happen to be a problematic node 7416 MinDist = MIN( Dist, MinDist ) 7417 7418 IF( Dist > Xtol ) CYCLE 7419 7420 ! Ok, this may be a proper element, now just find the two nodes 7421 ! needed for the mapping on the same stride. Basically this means 7422 ! finding the correct edge but we don't need to use the data structure for that. 7423 ! For 1D edge element this is trivial, note however that only 1st degree projection is used! 7424 j1 = 0; j2 = 0; j3 = 0 7425 IF( n <= 3 ) THEN 7426 j1 = 1 7427 j2 = 2 7428 IF( n == 3 ) j3 = 3 7429 ELSE 7430 DO j=1,n 7431 IF( ABS( NodesM % y(j) - y1 ) > YTol ) CYCLE 7432 IF( j1 == 0 ) THEN 7433 j1 = j 7434 ELSE IF( j2 == 0 ) THEN 7435 j2 = j 7436 ELSE 7437 j3 = j 7438 ! This means that for higher order edges only three nodes are used 7439 EXIT 7440 END IF 7441 END DO 7442 IF( j2 == 0 ) CALL Warn('AddNodalProjectorStrongStrides','Could not locate an edge consistently!') 7443 END IF 7444 7445 ! The node to map must be in interval, x1 \in [xm1,xm2] 7446 IF( NodesM % x(j1) > NodesM % x(j2) ) THEN 7447 j = j2; j2 = j1; j1 = j 7448 END IF 7449 xm1 = NodesM % x(j1) 7450 xm2 = NodesM % x(j2) 7451 7452 ! We are at interval [xm1,xm2] now choose either [xm1,xm3] or [xm3,xm2] 7453 IF( j3 > 0 ) THEN 7454 xm3 = NodesM % x(j3) 7455 IF( x1 > xm3 ) THEN 7456 j1 = j3; xm1 = xm3 7457 ELSE 7458 j2 = j3; xm2 = xm3 7459 END IF 7460 END IF 7461 7462 ! Ok, the last check, this might fail if the element had skew even though the 7463 ! quick test is successful! Then the left and right edge may have different range. 7464 Dist = MAX( x1-xm2, xm1-x1 ) 7465 IF( Dist > Xtol ) CYCLE 7466 7467 ! When we have the correct edge, the mapping is trivial. 7468 ! The sum of weights of the projectors is set to one. 7469 IF( ABS(xm1-xm2) < TINY(xm1) ) THEN 7470 CALL Warn('AddNodalProjectorStrongStrides','Degenerated edge?') 7471 PRINT *,'ind',ind,x1,y1,xm1,xm2,j1,j2,j3 7472 PRINT *,'x:',NodesM % x(1:n) 7473 PRINT *,'y:',NodesM % y(1:n) 7474 coeff(1) = 0.5_dp 7475 ELSE 7476 coeff(1) = (xm2-x1)/(xm2-xm1) 7477 END IF 7478 coeff(2) = 1.0_dp - coeff(1) 7479 7480 coeffi(1) = IndexesM(j1) 7481 coeffi(2) = IndexesM(j2) 7482 7483 Found = .TRUE. 7484 7485 ! If we really exactly between [xm1,xm2] then we may finish the search for good 7486 IF( Dist < EPSILON( Dist ) ) EXIT 7487 END DO 7488 7489 IF(.NOT. Found ) THEN 7490 Nundefined = Nundefined + 1 7491 WRITE( Message,'(A,2I8,3ES12.3)') 'Problematic node: ',& 7492 ind,ParEnv % MyPe,x1,y1,MinDist 7493 CALL Warn('AddNodalProjectorStrongStrides',Message) 7494 CYCLE 7495 END IF 7496 7497 IF( SelfProject ) THEN 7498 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 7499 InvPerm1(ind), NodeCoeff ) 7500 END IF 7501 7502 ! The scaling of the projector entries is used, for example, 7503 ! to allow antiperiodic projectors. 7504 Coeff(1:ncoeff) = sgn0 * Coeff(1:ncoeff) 7505 7506 ! The projection weights 7507 DO j=1,ncoeff 7508 7509 val = Coeff(j) 7510 ! Skip too small projector entries 7511 IF( ABS( val ) < 1.0d-12 ) CYCLE 7512 7513 ! Use the permutation to revert to original dofs 7514 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 7515 InvPerm2(coeffi(j)), NodeScale * NodeCoeff * val ) 7516 END DO 7517 7518 END DO 7519 7520 IF( Nundefined > 0 ) THEN 7521 CALL Warn('AddNodalProjectorStrongStrides',& 7522 'Nodes could not be determined by any edge: '//TRIM(I2S(Nundefined))) 7523 END IF 7524 7525 DEALLOCATE( NodesM % x, NodesM % y, NodesM % z ) 7526 7527 7528 END SUBROUTINE AddNodalProjectorStrongStrides 7529 !--------------------------------------------------------------------------------- 7530 7531 7532 !--------------------------------------------------------------------------------- 7533 ! Adds a nodal projector assuming generic 2D mesh. 7534 ! Otherwise should give same results as the one before. 7535 !--------------------------------------------------------------------------------- 7536 SUBROUTINE AddNodalProjectorStrongGeneric() 7537 7538 TYPE(Element_t), POINTER :: ElementM 7539 INTEGER, POINTER :: IndexesM(:), coeffi(:) 7540 REAL(KIND=dp), POINTER :: Basis(:),coeff(:) 7541 INTEGER :: n, nM, ncoeff, sgn0, ind, indm, j1, j2, j3, Nundefined 7542 REAL(KIND=dp) :: x1, y1, z1, xmin, xmax, xminm, xmaxm, ymaxm, yminm, & 7543 Dist, MaxMinBasis, detJ, ArcTol, ArcRange 7544 REAL(KIND=dp) :: val, u, v, w 7545 TYPE(Nodes_t) :: NodesM 7546 LOGICAL :: LeftCircle, Found, Stat 7547 7548 CALL Info('AddNodalProjectorStrongGeneric','Creating strong generic projector for nodal dofs',Level=10) 7549 7550 n = Mesh % MaxElementNodes 7551 ALLOCATE( NodesM % x(n), NodesM % y(n), NodesM % z(n), Basis(n), coeff(n), coeffi(n) ) 7552 NodesM % z = 0.0_dp 7553 7554 ncoeff = 0 7555 coeffi = 0 7556 sgn0 = 1 7557 Nundefined = 0 7558 z1 = 0.0_dp 7559 7560 ArcTol = ArcCoeff * Xtol 7561 ArcRange = ArcCoeff * Xrange 7562 7563 ! This flag tells if we're working with a full circle and the problematic part of 7564 ! the circle with the discontinuity in the angle. 7565 LeftCircle = .FALSE. 7566 7567 DO ind=1,BMesh1 % NumberOfNodes 7568 7569 nrow = NodePerm( InvPerm1( ind ) ) 7570 IF( nrow == 0 ) CYCLE 7571 NodePerm( InvPerm1( ind ) ) = 0 7572 Projector % InvPerm(nrow) = InvPerm1(ind) 7573 7574 Found = .FALSE. 7575 x1 = ArcCoeff * BMesh1 % Nodes % x(ind) 7576 y1 = BMesh1 % Nodes % y(ind) 7577 IF( HaveMaxDistance ) THEN 7578 z1 = BMesh1 % Nodes % z(ind) 7579 END IF 7580 7581 sgn0 = 1 7582 coeff = 0.0_dp 7583 MaxMinBasis = -HUGE(MaxMinBasis) 7584 7585 IF( FullCircle ) THEN 7586 LeftCircle = ABS( x1 ) > ArcCoeff * 90.0_dp 7587 IF( LeftCircle ) THEN 7588 IF( x1 < 0.0 ) x1 = x1 + ArcCoeff * 360.0_dp 7589 END IF 7590 END IF 7591 7592 ! If the projector is of style Px+Qx=0 then 7593 ! and the negative sign, otherwise let the initial sign be. 7594 IF( SelfProject ) sgn0 = -sgn0 7595 7596 ! Currently a cheap n^2 loop but it could be improved 7597 ! Looping over master elements. Look for constant-y strides only. 7598 !-------------------------------------------------------------------- 7599 DO indM = 1, BMesh2 % NumberOfBulkElements 7600 7601 ElementM => BMesh2 % Elements(indM) 7602 nM = ElementM % TYPE % NumberOfNodes 7603 IndexesM => ElementM % NodeIndexes 7604 7605 IF( HaveMaxDistance ) THEN 7606 IF( MINVAL( ABS( BMesh2 % Nodes % z(IndexesM(1:nM)) - z1 ) ) > MaxDistance ) CYCLE 7607 END IF 7608 7609 ! Quick tests to save time 7610 NodesM % y(1:nM) = BMesh2 % Nodes % y(IndexesM(1:nM)) 7611 ymaxm = MAXVAL( NodesM % y(1:nM) ) 7612 yminm = MINVAL( NodesM % y(1:nM) ) 7613 7614 Dist = MAX( y1-ymaxm, yminm-y1 ) 7615 IF( Dist > Ytol ) CYCLE 7616 7617 ! The x nodes should be in the interval 7618 NodesM % x(1:nM) = BMesh2 % Nodes % x(IndexesM(1:nM)) 7619 7620 ! Transform the master element on-the-fly around the problematic angle 7621 ! Full 2D circle is never repeating 7622 IF( LeftCircle ) THEN 7623 ! The master nodes are all on right 7624 IF( ALL( ABS( NodesM % x(1:nM) ) - ArcCoeff * 90.0_dp < ArcTol ) ) CYCLE 7625 DO j=1,nM 7626 IF( NodesM % x(j) < 0.0 ) NodesM % x(j) = NodesM % x(j) + ArcCoeff * 360.0_dp 7627 END DO 7628 END IF 7629 7630 xmaxm = MAXVAL( NodesM % x(1:nM) ) 7631 xminm = MINVAL( NodesM % x(1:nM) ) 7632 7633 ! Eliminate this special case since it could otherwise give a faulty hit 7634 IF( FullCircle .AND. .NOT. LeftCircle ) THEN 7635 IF( xmaxm - xminm > ArcCoeff * 180.0_dp ) CYCLE 7636 END IF 7637 7638 IF( Repeating ) THEN 7639 Nrange = FLOOR( (xmaxm-x1) / XRange ) 7640 IF( Nrange /= 0 ) THEN 7641 xminm = xminm - Nrange * ArcRange 7642 xmaxm = xmaxm - Nrange * ArcRange 7643 NodesM % x(1:nM) = NodesM % x(1:nM) - NRange * ArcRange 7644 END IF 7645 7646 ! Check whether there could be a intersection in an other interval as well 7647 IF( xminm + ArcRange < x1 + ArcTol ) THEN 7648 Nrange2 = 1 7649 ELSE 7650 Nrange2 = 0 7651 END IF 7652 END IF 7653 7654100 Dist = MAX( x1-xmaxm, xminm-x1 ) 7655 7656 IF( Dist < Xtol ) THEN 7657 ! Integration point at the slave element 7658 CALL GlobalToLocal( u, v, w, x1, y1, z1, ElementM, NodesM ) 7659 stat = ElementInfo( ElementM, NodesM, u, v, w, detJ, Basis ) 7660 7661 IF( MINVAL( Basis(1:nM) ) > MaxMinBasis ) THEN 7662 MaxMinBasis = MINVAL( Basis(1:nM) ) 7663 ncoeff = nM 7664 coeff(1:nM) = Basis(1:nM) 7665 coeffi(1:nM) = IndexesM(1:nM) 7666 Found = ( MaxMinBasis >= -1.0d-12 ) 7667 END IF 7668 7669 IF( Found ) EXIT 7670 END IF 7671 7672 IF( Repeating ) THEN 7673 IF( NRange2 /= 0 ) THEN 7674 xminm = xminm + ArcCoeff * Nrange2 * ArcRange 7675 xmaxm = xmaxm + ArcCoeff * Nrange2 * ArcRange 7676 NodesM % x(1:n) = NodesM % x(1:n) + NRange2 * ArcRange 7677 NRange = NRange + NRange2 7678 NRange2 = 0 7679 GOTO 100 7680 END IF 7681 END IF 7682 7683 END DO 7684 7685 IF(.NOT. Found ) THEN 7686 IF( MaxMinBasis > -1.0d-6 ) THEN 7687 CALL Info('AddNodalProjectorStrongGeneric',Message,Level=8) 7688 Found = .TRUE. 7689 ELSE 7690 Nundefined = Nundefined + 1 7691 IF( .NOT. HaveMaxDistance ) THEN 7692 WRITE( Message,'(A,2I8,3ES12.3)') 'Problematic node: ',& 7693 ind,ParEnv % MyPe,x1,y1,MaxMinBasis 7694 CALL Warn('AddNodalProjectorStrongGeneric',Message ) 7695 END IF 7696 END IF 7697 END IF 7698 7699 IF( Found ) THEN 7700 IF( SelfProject ) THEN 7701 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 7702 InvPerm1(ind), NodeCoeff ) 7703 END IF 7704 7705 ! The scaling of the projector entries is used, for example, 7706 ! to allow antiperiodic projectors. 7707 Coeff(1:ncoeff) = sgn0 * Coeff(1:ncoeff) 7708 7709 ! Add the projection weights to the matrix 7710 DO j=1,ncoeff 7711 7712 val = Coeff(j) 7713 ! Skip too small projector entries 7714 ! These really should sum to one we now the limit quite well 7715 IF( ABS( val ) < 1.0d-8 ) CYCLE 7716 7717 ! Use the permutation to revert to original dofs 7718 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 7719 InvPerm2(coeffi(j)), NodeScale * NodeCoeff * val ) 7720 END DO 7721 END IF 7722 7723 END DO 7724 7725 IF( Nundefined > 0 ) THEN 7726 IF( HaveMaxDistance ) THEN 7727 CALL Info('AddNodalProjectorStrongGeneric',& 7728 'Nodes could not be found in any element: '//TRIM(I2S(Nundefined))) 7729 ELSE 7730 CALL Warn('AddNodalProjectorStrongGeneric',& 7731 'Nodes could not be found in any element: '//TRIM(I2S(Nundefined))) 7732 END IF 7733 END IF 7734 7735 DEALLOCATE( NodesM % x, NodesM % y, NodesM % z, Basis, coeffi, coeff ) 7736 7737 7738 END SUBROUTINE AddNodalProjectorStrongGeneric 7739 !--------------------------------------------------------------------------------- 7740 7741 7742 !--------------------------------------------------------------------------------- 7743 ! Create a projector for edges directly. This minmizes the size of the projector 7744 ! but may result to numerically inferior projector compared to the weak projector. 7745 ! It seems to be ok for unskewed geometries where the simplest edge elements work 7746 ! well. For skewed geometries the solution does not easily seem to be compatible 7747 ! with the strong projector. 7748 !--------------------------------------------------------------------------------- 7749 SUBROUTINE AddEdgeProjectorStrongStrides() 7750 7751 INTEGER :: ind, indm, eind, eindm, k1, k2, km1, km2, sgn0, coeffi(100), & 7752 ncoeff, dncoeff, ncoeff0, i1, i2, j1, j2, Nundefined, NoSkewed, SkewPart 7753 TYPE(Element_t), POINTER :: Element, ElementM 7754 INTEGER, POINTER :: Indexes(:), IndexesM(:) 7755 TYPE(Nodes_t) :: NodesM, Nodes 7756 INTEGER, POINTER :: EdgeMap(:,:),EdgeMapM(:,:) 7757 REAL(KIND=dp) :: xm1, xm2, ym1, ym2, coeff(100), signs(100), wsum, minwsum, maxwsum, val, & 7758 x1o, y1o, x2o, y2o, cskew, sedge 7759 REAL(KIND=dp) :: x1, y1, x2, y2, xmin, xmax, xminm, xmaxm, ymin, ymax, yminm, ymaxm, xmean, & 7760 dx,dy,Xeps 7761 LOGICAL :: YConst, YConstM, XConst, XConstM, EdgeReady, Repeated, LeftCircle, & 7762 SkewEdge, AtRangeLimit 7763 7764 7765 CALL Info('AddEdgeProjectorStrongStrides','Creating strong stride projector for edges assuming strides',Level=10) 7766 7767 n = Mesh % NumberOfEdges 7768 IF( n == 0 ) RETURN 7769 7770 n = Mesh % MaxElementNodes 7771 ALLOCATE( Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 7772 ALLOCATE( NodesM % x(n), NodesM % y(n), NodesM % z(n) ) 7773 Nodes % z = 0.0_dp 7774 NodesM % z = 0.0_dp 7775 7776 minwsum = HUGE( minwsum ) 7777 maxwsum = 0.0_dp 7778 NoSkewed = 0 7779 Nundefined = 0 7780 LeftCircle = .FALSE. 7781 Xeps = EPSILON( Xeps ) 7782 AtRangeLimit = .FALSE. 7783 7784 DO ind=1,BMesh1 % NumberOfBulkElements 7785 7786 Element => BMesh1 % Elements(ind) 7787 EdgeMap => GetEdgeMap( Element % TYPE % ElementCode / 100) 7788 7789 Indexes => Element % NodeIndexes 7790 7791 n = Element % TYPE % NumberOfNodes 7792 Nodes % x(1:n) = BMesh1 % Nodes % x(Indexes(1:n)) 7793 Nodes % y(1:n) = BMesh1 % Nodes % y(Indexes(1:n)) 7794 7795 dx = MAXVAL( Nodes % x(1:n)) - MINVAL(Nodes % x(1:n)) 7796 dy = MAXVAL( Nodes % y(1:n)) - MINVAL(Nodes % y(1:n)) 7797 7798 ! Go through combinations of edges and find the edges for which the 7799 ! indexes are the same. 7800 DO i = 1,Element % TYPE % NumberOfEdges 7801 7802 eind = Element % EdgeIndexes(i) 7803 IF( EdgePerm(eind) == 0 ) CYCLE 7804 7805 nrow = EdgeRow0 + EdgePerm(eind) 7806 7807 ! Get the nodes of the edge 7808 i1 = EdgeMap(i,1) 7809 i2 = EdgeMap(i,2) 7810 7811 k1 = Indexes( i1 ) 7812 k2 = Indexes( i2 ) 7813 7814 ! The coordinates of the edge 7815 x1 = Nodes % x(i1) 7816 y1 = Nodes % y(i1) 7817 7818 x2 = Nodes % x(i2) 7819 y2 = Nodes % y(i2) 7820 7821 YConst = ( ABS(y2-y1) < RadTol * dy ) 7822 XConst = ( ABS(x2-x1) < RadTol * dx ) 7823 7824 SkewEdge = .FALSE. 7825 cskew = 1.0_dp 7826 7827 IF( YConst ) THEN 7828 IF( .NOT. StrongLevelEdges ) CYCLE 7829 ELSE IF( XConst ) THEN 7830 IF( .NOT. StrongExtrudedEdges ) CYCLE 7831 ELSE 7832 !print *,'skewed edge: ',ParEnv % MyPe,x1,x2,y1,y2,dx,dy 7833 !print *,'tol:',ABS(y2-y1)/dy,ABS(x2-x1)/dx,RadTol 7834 7835 NoSkewed = NoSkewed + 1 7836 SkewEdge = .TRUE. 7837 IF(.NOT. StrongSkewEdges) CYCLE 7838 END IF 7839 7840 7841 ! Numbering of global indexes is needed to ensure correct direction 7842 ! of the edge dofs. Basically the InvPerm could be used also in serial 7843 ! but the order of numbering is maintained when the reduced mesh is created. 7844 IF(Parallel) THEN 7845 k1 = CurrentModel % Mesh % ParallelInfo % GlobalDOFs(InvPerm1(k1)) 7846 k2 = CurrentModel % Mesh % ParallelInfo % GlobalDOFs(InvPerm1(k2)) 7847 END IF 7848 ncoeff = 0 7849 7850 IF( SkewEdge ) THEN 7851 SkewPart = 0 7852 sedge = SQRT(ArcCoeff**2*(x1-x2)**2 + (y1-y2)**2) 7853 x1o = x1 7854 y1o = y1 7855 x2o = x2 7856 y2o = y2 7857 END IF 7858 7859 ! This is mainly a test branch for skewed quadrilaters. 7860 ! It is based on the composition of a skewed edge into 7861 ! four cartesian vectors oriented along x or y -axis. 7862 ! Unfortunately the resulting projector does not seem to be 7863 ! numerically favourable. 786450 IF( SkewEdge ) THEN 7865 IF( SkewPart < 2 ) THEN 7866 XConst = .TRUE. 7867 YConst = .FALSE. 7868 IF( SkewPart == 1 ) THEN 7869 x1 = (3.0_dp*x1o + x2o) / 4.0_dp 7870 ELSE 7871 x1 = (x1o + 3.0_dp*x2o) / 4.0_dp 7872 END IF 7873 x2 = x1 7874 y1 = y1o 7875 y2 = y2o 7876 cskew = 0.5_dp * ABS(y1-y2) / sedge 7877 ELSE 7878 XConst = .FALSE. 7879 YConst = .TRUE. 7880 IF( SkewPart == 2 ) THEN 7881 x1 = x1o 7882 x2 = (x1o + x2o) / 2.0_dp 7883 y1 = y1o 7884 y2 = y1o 7885 ELSE 7886 x1 = (x1o + x2o) / 2.0_dp 7887 x2 = x2o 7888 y1 = y2o 7889 y2 = y2o 7890 END IF 7891 cskew = ArcCoeff * ABS(x1-x2) / sedge 7892 END IF 7893 END IF 7894 7895 ncoeff0 = ncoeff 7896 dncoeff = 0 7897 Repeated = .FALSE. 7898 7899 ! If the edge might be treated in two periodic parts 7900 ! then here study whether this is the case (Nrange2 /= 0). 7901 IF( Repeating ) THEN 7902 Nrange = FLOOR( (x1-XMinAll) / XRange ) 7903 x1 = x1 - Nrange * XRange 7904 x2 = x2 - Nrange * XRange 7905 7906 IF( x2 > XMaxAll ) THEN 7907 Nrange2 = 1 7908 ELSE IF( x2 < XMinAll ) THEN 7909 Nrange2 = -1 7910 ELSE 7911 Nrange2 = 0 7912 END IF 7913 ELSE IF( FullCircle ) THEN 7914 ! If we have a full circle then treat the left-hand-side 7915 ! differently in order to circumvent the discontinuity of the 7916 ! angle at 180 degrees. 7917 LeftCircle = ( ABS(x1) > 90.0_dp .AND. ABS(x2) > 90.0_dp ) 7918 IF( LeftCircle ) THEN 7919 IF( x1 < 0.0_dp ) x1 = x1 + 360.0_dp 7920 IF( x2 < 0.0_dp ) x2 = x2 + 360.0_dp 7921 END IF 7922 END IF 7923 7924 EdgeReady = .FALSE. 7925100 sgn0 = 1 7926 IF( AntiRepeating ) THEN 7927 IF ( MODULO(Nrange,2) /= 0 ) sgn0 = -1 7928 END IF 7929 7930 IF( SelfProject ) sgn0 = -sgn0 7931 7932 xmin = MIN(x1,x2) 7933 xmax = MAX(x1,x2) 7934 ymin = MIN(y1,y2) 7935 ymax = MAX(y1,y2) 7936 xmean = (x1+x2) / 2.0_dp 7937 7938 7939 ! If the mesh is not repeating there is a risk that we don't exactly hit the start 7940 ! or end of the range. Therefore grow the tolerance close to the ends. 7941 IF(.NOT. ( Repeating .OR. FullCircle ) ) THEN 7942 IF ( xmax < XminAll + Xtol .OR. xmin > XmaxAll - Xtol ) THEN 7943 Xeps = Xtol 7944 ELSE 7945 Xeps = EPSILON( Xeps ) 7946 END IF 7947 END IF 7948 7949 7950 ! Currently a n^2 loop but it could be improved 7951 !-------------------------------------------------------------------- 7952 DO indm=1,BMesh2 % NumberOfBulkElements 7953 7954 ElementM => BMesh2 % Elements(indm) 7955 n = ElementM % TYPE % NumberOfNodes 7956 IndexesM => ElementM % NodeIndexes(1:n) 7957 7958 ! Make first some coarse tests to eliminate most of the candidate elements 7959 ! The y nodes should always have an exact fit 7960 NodesM % y(1:n) = BMesh2 % Nodes % y(IndexesM(1:n)) 7961 IF( MINVAL( ABS( ymin - NodesM % y(1:n) ) ) > YTol ) CYCLE 7962 IF(.NOT. YConst ) THEN 7963 IF( MINVAL( ABS( ymax - NodesM % y(1:n) ) ) > YTol ) CYCLE 7964 END IF 7965 7966 NodesM % x(1:n) = BMesh2 % Nodes % x(IndexesM(1:n)) 7967 7968 ! If we have a full circle then treat the left part differently 7969 IF( LeftCircle ) THEN 7970 IF( ALL( ABS( NodesM % x(1:n) ) - 90.0_dp < Xtol ) ) CYCLE 7971 DO j=1,n 7972 IF( NodesM % x(j) < 0.0_dp ) NodesM % x(j) = NodesM % x(j) + 360.0_dp 7973 END DO 7974 END IF 7975 7976 ! The x nodes should be in the interval 7977 xminm = MINVAL( NodesM % x(1:n) ) 7978 xmaxm = MAXVAL( NodesM % x(1:n) ) 7979 7980 IF( xminm > xmax + Xeps ) CYCLE 7981 IF( xmaxm < xmin - Xeps ) CYCLE 7982 7983 ! Eliminate this special case since it could otherwise give a faulty hit 7984 IF( FullCircle .AND. .NOT. LeftCircle ) THEN 7985 IF( xmaxm - xminm > 180.0_dp ) CYCLE 7986 END IF 7987 7988 yminm = MINVAL( NodesM % y(1:n) ) 7989 ymaxm = MAXVAL( NodesM % y(1:n) ) 7990 7991 ! Ok, we have found a candicate face that will probably have some hits 7992 EdgeMapM => GetEdgeMap( ElementM % TYPE % ElementCode / 100) 7993 7994 ! Go through combinations of edges and find the edges for which the 7995 ! indexes are the same. 7996 DO j = 1,ElementM % TYPE % NumberOfEdges 7997 7998 eindm = ElementM % EdgeIndexes(j) 7999 8000 ! Eliminate the possibilitity that the same edge is accounted for twice 8001 ! in two different boundary elements. 8002 IF( ANY( coeffi(ncoeff0+1:ncoeff) == eindm ) ) CYCLE 8003 8004 j1 = EdgeMap(j,1) 8005 j2 = EdgeMap(j,2) 8006 8007 km1 = IndexesM( j1 ) 8008 km2 = IndexesM( j2 ) 8009 8010 ym1 = NodesM % y(j1) 8011 ym2 = NodesM % y(j2) 8012 8013 xm1 = NodesM % x(j1) 8014 xm2 = NodesM % x(j2) 8015 8016 ! The target mesh has already been checked that the elements are rectangular so 8017 ! the edges must be have either constant y or x. 8018 YConstM = ( ABS(ym2-ym1) / (ymaxm-yminm) < ABS(xm2-xm1) / (xmaxm-xminm) ) 8019 XConstM = .NOT. YConstM 8020 8021 ! Either both are lateral edges, or both are vertical 8022 IF( .NOT. ( ( YConst .AND. YConstM ) .OR. ( XConst .AND. XConstM ) ) ) THEN 8023 CYCLE 8024 END IF 8025 8026 ! sign depends on the direction and order of global numbering 8027 IF(Parallel) THEN 8028 km1 = CurrentModel % Mesh % ParallelInfo % GlobalDOFs(InvPerm2(km1)) 8029 km2 = CurrentModel % Mesh % ParallelInfo % GlobalDOFs(InvPerm2(km2)) 8030 END IF 8031 8032 IF( YConst ) THEN 8033 IF( ABS( y1 - ym1 ) > YTol ) CYCLE 8034 8035 ! Check whether the range of master x has a union with the slave x 8036 xmaxm = MAX( xm1, xm2 ) 8037 IF( xmaxm < xmin ) CYCLE 8038 8039 xminm = MIN( xm1, xm2 ) 8040 IF( xminm > xmax ) CYCLE 8041 8042 ! Ok, we have a hit register it 8043 ncoeff = ncoeff + 1 8044 coeffi(ncoeff) = eindm 8045 8046 ! weight depends on the relative fraction of overlapping 8047 IF( ABS( xmax-xmin) < TINY( xmax ) ) THEN 8048 CALL Warn('AddEdgeProjectorStrongStrides','Degenerated edge 2?') 8049 coeff(ncoeff) = cskew * 1.0_dp 8050 ELSE 8051 coeff(ncoeff) = cskew * (MIN(xmaxm,xmax)-MAX(xminm,xmin))/(xmax-xmin) 8052 END IF 8053 8054 ! this sets the sign which should be consistent 8055 IF( (x1-x2)*(xm1-xm2)*(k1-k2)*(km1-km2) > 0.0_dp ) THEN 8056 signs(ncoeff) = sgn0 8057 ELSE 8058 signs(ncoeff) = -sgn0 8059 END IF 8060 8061 ! There can be only one lateral edge hit for each element 8062 EXIT 8063 ELSE 8064 dncoeff = dncoeff + 1 8065 ncoeff = ncoeff + 1 8066 8067 IF( (y1-y2)*(ym1-ym2)*(k1-k2)*(km1-km2) > 0.0_dp ) THEN 8068 signs(ncoeff) = sgn0 8069 ELSE 8070 signs(ncoeff) = -sgn0 8071 END IF 8072 8073 coeffi(ncoeff) = eindm 8074 ! note: temporarily save the coordinate to the coefficient! 8075 coeff(ncoeff) = ( xm1 + xm2 ) / 2.0_dp 8076 END IF 8077 END DO 8078 8079 IF( .NOT. SkewEdge ) THEN 8080 IF( YConst ) THEN 8081 ! Test whether the sum of coefficients has already reached unity 8082 wsum = SUM( coeff(1:ncoeff) ) 8083 EdgeReady = ( 1.0_dp - wsum < 1.0d-12 ) 8084 ELSE IF( XConst ) THEN 8085 ! If edge was found both on left and right there is no need to continue search 8086 EdgeReady = ( dncoeff == 2 ) 8087 END IF 8088 IF( EdgeReady ) EXIT 8089 END IF 8090 END DO 8091 8092 IF( YConst ) THEN 8093 ! For constant y check the 2nd part 8094 ! and redo the search if it is active. 8095 IF( Repeating ) THEN 8096 IF( NRange2 /= 0 ) THEN 8097 x1 = x1 - NRange2 * XRange 8098 x2 = x2 - NRange2 * XRange 8099 NRange = NRange + NRange2 8100 NRange2 = 0 8101 Repeated = .TRUE. 8102 GOTO 100 8103 END IF 8104 END IF 8105 ELSE 8106 ! Here there can be a second part if a proper hit was not found 8107 ! due to some epsilon rules. 8108 IF( SkewEdge ) THEN 8109 IF( dncoeff == 1 ) THEN 8110 coeff(ncoeff) = cskew * 1.0_dp 8111 ELSE IF( dncoeff == 2 ) THEN 8112 xm1 = coeff(ncoeff-1) 8113 xm2 = coeff(ncoeff) 8114 8115 IF( ABS( xm2-xm1) < TINY( xm2 ) ) THEN 8116 CALL Warn('AddEdgeProjectorStrongStrides','Degenerated edge 3?') 8117 coeff(ncoeff-1) = cskew * 0.5_dp 8118 ELSE 8119 coeff(ncoeff-1) = cskew * ABS((xm2-xmean)/(xm2-xm1)) 8120 END IF 8121 coeff(ncoeff) = cskew * 1.0_dp - coeff(1) 8122 END IF 8123 ELSE 8124 IF( ncoeff == 1 ) THEN 8125 coeff(1) = 1.0_dp 8126 ELSE IF( ncoeff >= 2 ) THEN 8127 IF( ncoeff > 2 ) THEN 8128 CALL Warn('AddEdgeProjectorStrongStrides',& 8129 'There should not be more than two target edges: '//TRIM(I2S(ncoeff))) 8130 END IF 8131 xm1 = coeff(1) 8132 xm2 = coeff(2) 8133 IF( ABS( xm2-xm1) < TINY( xm2 ) ) THEN 8134 CALL Warn('AddEdgeProjectorStrongStrides','Degenerated edge 3?') 8135 coeff(1) = 0.5_dp 8136 ELSE 8137 coeff(1) = ABS((xm2-xmean)/(xm2-xm1)) 8138 END IF 8139 coeff(2) = 1.0_dp - coeff(1) 8140 END IF 8141 END IF 8142 8143 wsum = SUM( coeff(1:ncoeff) ) 8144 END IF 8145 8146 ! Skewed edge is treated in four different parts (0,1,2,3) 8147 ! Go for the next part, if not finished. 8148 IF( SkewEdge ) THEN 8149 IF( SkewPart < 3 ) THEN 8150 SkewPart = SkewPart + 1 8151 GOTO 50 8152 END IF 8153 END IF 8154 8155 IF( ncoeff == 0 ) THEN 8156 Nundefined = Nundefined + 1 8157 WRITE( Message,'(A,2I8,4ES12.3)') 'Problematic edge: ',& 8158 eind,ParEnv % MyPe,x1,x2,y1,y2 8159 CALL Warn('AddEdgeProjectorStrongStrides', Message ) 8160 WRITE( Message,'(A,I8,3L4,4ES12.3)') 'Bounding box: ',& 8161 eind,XConst,YConst,Repeating,XminAll,XmaxAll,YminAll,YmaxAll 8162 CALL Warn('AddEdgeProjectorStrongStrides', Message ) 8163 CYCLE 8164 END IF 8165 8166 wsum = SUM( ABS( coeff(1:ncoeff) ) ) 8167 minwsum = MIN( minwsum, wsum ) 8168 maxwsum = MAX( maxwsum, wsum ) 8169 8170 ! In skewed edges the sum of weights may be different from 1 but otherwise 8171 ! it should be very close to one. 8172! IF( ABS(wsum) < 0.999 .OR. ( ABS(wsum) > 1.001 .AND. .NOT. SkewEdge ) ) THEN 8173 IF(.FALSE.) THEN 8174 PRINT *,'*********************' 8175 PRINT *,'wsum',eind,ncoeff,wsum,Repeated 8176 PRINT *,'x coords:',x1,x2 8177 PRINT *,'y coords:',y1,y2 8178 PRINT *,'xm:',xm1,xm2 8179 PRINT *,'ym:',ym1,ym2 8180 PRINT *,'xm coords:',NodesM % x(1:4) 8181 PRINT *,'ym coords:',NodesM % y(1:4) 8182 PRINT *,'Const:',XConst,YConst,XConstM,YConstM 8183 PRINT *,'coeff:',ncoeff,coeff(1:ncoeff),coeffi(1:ncoeff) 8184 END IF 8185 8186 ! Mark that this is set so it don't need to be set again 8187 EdgePerm(eind) = 0 8188 8189 ! Ok, we found a true projector entry 8190 Projector % InvPerm(nrow) = EdgeCol0 + eind 8191 8192 ! The reference to the edge to be projected 8193 IF( SelfProject ) THEN 8194 val = 1.0_dp 8195 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8196 EdgeCol0 + eind, EdgeCoeff * val ) 8197 END IF 8198 8199 ! The scaling can be used to create antiperiodic projectors, for example. 8200 Coeff(1:ncoeff) = signs(1:ncoeff) * Coeff(1:ncoeff) 8201 8202 ! And finally add the projection weights to the projection matrix 8203 DO j=1,ncoeff 8204 val = Coeff(j) 8205 8206 IF( ABS( val ) < 1.0d-12 ) CYCLE 8207 8208 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8209 EdgeCol0 + coeffi(j), EdgeScale * EdgeCoeff * val ) 8210 END DO 8211 END DO 8212 END DO 8213 8214 IF( Nundefined > 0 ) THEN 8215 CALL Error('AddEdgeProjectorStrongStrides',& 8216 'Number of edges could not be mapped: '//TRIM(I2S(Nundefined))) 8217 END IF 8218 8219 WRITE( Message,'(A,ES12.5)') 'Minimum absolute sum of edge weights: ',minwsum 8220 CALL Info('AddEdgeProjectorStrongStrides',Message,Level=10) 8221 8222 WRITE( Message,'(A,ES12.5)') 'Maximum absolute sum of edge weights: ',maxwsum 8223 CALL Info('AddEdgeProjectorStrongStrides',Message,Level=10) 8224 8225 IF( NoSkewed > 0 ) THEN 8226 CALL Info('AddEdgeProjectorStrongStrides','Number of skewed edge mappings: '//TRIM(I2S(NoSkewed)),Level=8) 8227 END IF 8228 CALL Info('AddEdgeProjectorStrongStrides','Created strong constraints for edge dofs',Level=8) 8229 8230 DEALLOCATE( Nodes % x, Nodes % y, Nodes % z, & 8231 NodesM % x, NodesM % y, NodesM % z ) 8232 8233 END SUBROUTINE AddEdgeProjectorStrongStrides 8234 !---------------------------------------------------------------------- 8235 8236 8237 !--------------------------------------------------------------------------------- 8238 ! Create a strong projector for edges in a conforming case. 8239 ! We create a periodic permutation first instead of creating a matrix directly. 8240 ! This enables that we can recycle some code. 8241 !--------------------------------------------------------------------------------- 8242 SUBROUTINE AddEdgeProjectorStrongConforming() 8243 8244 INTEGER :: ne, nn, i, nrow, eind, eindm, sgn 8245 INTEGER, POINTER :: PerPerm(:) 8246 LOGICAL, POINTER :: PerFlip(:) 8247 8248 CALL Info('AddEdgeProjectorStrongConforming','Creating strong projector for conforming edges',Level=8) 8249 8250 ne = Mesh % NumberOfEdges 8251 IF( ne == 0 ) RETURN 8252 8253 nn = Mesh % NumberOfNodes 8254 8255 ALLOCATE( PerPerm(nn+ne), PerFlip(nn+ne) ) 8256 PerPerm = 0; PerFlip = .FALSE. 8257 8258 ! Permutation that tells which slave edge depends on which master edge (1-to-1 map) 8259 CALL ConformingEdgePerm(Mesh, BMesh1, BMesh2, PerPerm, PerFlip ) 8260 8261 DO i=nn+1,nn+ne 8262 IF( PerPerm(i) == 0 ) CYCLE 8263 eind = i - nn 8264 eindm = PerPerm(i) - nn 8265 8266 sgn = -1 8267 IF( PerFlip(i) ) sgn = 1 8268 8269 nrow = EdgeRow0 + EdgePerm(eind) 8270 Projector % InvPerm(nrow) = EdgeCol0 + eind 8271 8272 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8273 EdgeCol0 + eind, EdgeCoeff ) 8274 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8275 EdgeCol0 + eindm, sgn * EdgeScale * EdgeCoeff ) 8276 8277 ! Mark that this is now set 8278 EdgePerm(eind) = 0 8279 END DO 8280 8281 DEALLOCATE( PerPerm, PerFlip ) 8282 8283 CALL Info('AddEdgeProjectorStrongConforming','Created strong constraints for conforming edge dofs',Level=10) 8284 8285 END SUBROUTINE AddEdgeProjectorStrongConforming 8286 8287 !--------------------------------------------------------------------------------- 8288 ! Create a strong projector for edges in a conforming case. 8289 ! We create a periodic permutation first instead of creating a matrix directly. 8290 ! This enables that we can recycle some code. 8291 !--------------------------------------------------------------------------------- 8292 SUBROUTINE AddNodeProjectorStrongConforming() 8293 8294 INTEGER :: nn, i, nrow, ind, indm, sgn 8295 INTEGER, POINTER :: PerPerm(:) 8296 8297 CALL Info('AddNodeProjectorStrongConforming','Creating strong projector for conforming edges',Level=8) 8298 8299 8300 nn = Mesh % NumberOfNodes 8301 8302 ALLOCATE( PerPerm(nn) ) 8303 PerPerm = 0 8304 8305 ! Permutation that tells which slave edge depends on which master node (1-to-1 map) 8306 CALL ConformingNodePerm(Mesh, BMesh1, BMesh2, PerPerm ) 8307 8308 DO i=1, nn 8309 IF( PerPerm(i) == 0 ) CYCLE 8310 ind = i 8311 indm = PerPerm(i) 8312 8313 sgn = -1 8314 8315 nrow = NodePerm(ind) 8316 Projector % InvPerm(nrow) = ind 8317 8318 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8319 ind, EdgeCoeff ) 8320 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8321 indm, sgn * EdgeScale * EdgeCoeff ) 8322 8323 ! Mark that this is now set 8324 NodePerm(ind) = 0 8325 END DO 8326 8327 DEALLOCATE( PerPerm ) 8328 8329 CALL Info('AddNodeProjectorStrongConforming','Created strong constraints for conforming node dofs',Level=10) 8330 8331 END SUBROUTINE AddNodeProjectorStrongConforming 8332 8333 8334 !---------------------------------------------------------------------- 8335 ! Create weak projector for the remaining nodes and edges. 8336 ! This uses the generic way to introduce the weights. The resulting 8337 ! matrix is more dense but should be numerically favourable. 8338 ! The integration is done by making an on-the-fly triangularization 8339 ! into several triangles. This is not generic - it assumes constant 8340 ! y levels, and cartesian mesh where the search is done. 8341 !---------------------------------------------------------------------- 8342 SUBROUTINE AddProjectorWeakStrides() 8343 8344 INTEGER, TARGET :: IndexesT(3) 8345 INTEGER, POINTER :: Indexes(:), IndexesM(:) 8346 INTEGER :: j1,j2,j3,j4,jj,ii,sgn0,k,kmax,ind,indM,nip,nn,ne,nf,inds(10),Ninteg,NintegGen 8347 TYPE(Element_t), POINTER :: Element, ElementM 8348 TYPE(Element_t) :: ElementT 8349 TYPE(GaussIntegrationPoints_t) :: IP 8350 LOGICAL :: RightSplit, LeftSplit, LeftSplit2, RightSplit2, TopEdge, BottomEdge 8351 TYPE(Nodes_t) :: Nodes, NodesM, NodesT 8352 REAL(KIND=dp) :: x(10),y(10),xt,yt,zt,xmax,ymax,xmin,ymin,xmaxm,ymaxm,& 8353 xminm,yminm,DetJ,Wtemp,q,ArcTol,u,v,w,um,vm,wm,val,Overlap,RefArea,dArea,& 8354 SumOverlap,SumArea,qleft, qright, qleft2, qright2, MaxErr,Err,phi(10) 8355 REAL(KIND=dp), ALLOCATABLE :: Basis(:), BasisM(:) 8356 REAL(KIND=dp), ALLOCATABLE :: WBasis(:,:),WBasisM(:,:),RotWbasis(:,:),dBasisdx(:,:) 8357 LOGICAL :: LeftCircle, Stat 8358 TYPE(Mesh_t), POINTER :: Mesh 8359 8360 CALL Info('AddProjectorWeakStrides','Creating weak projector for stride mesh',Level=8) 8361 8362 Mesh => CurrentModel % Solver % Mesh 8363 8364 n = Mesh % MaxElementNodes 8365 ALLOCATE( Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 8366 ALLOCATE( NodesM % x(n), NodesM % y(n), NodesM % z(n) ) 8367 ALLOCATE( NodesT % x(n), NodesT % y(n), NodesT % z(n) ) 8368 ALLOCATE( Basis(n), BasisM(n) ) 8369 ALLOCATE( dBasisdx(n,3), WBasis(n,3), WBasisM(n,3), RotWBasis(n,3) ) 8370 8371 Nodes % z = 0.0_dp 8372 NodesM % z = 0.0_dp 8373 NodesT % z = 0.0_dp 8374 8375 MaxErr = 0.0_dp 8376 zt = 0.0_dp 8377 n = 4 8378 LeftCircle = .FALSE. 8379 8380 ArcTol = ArcCoeff * Xtol 8381 Ninteg = 0 8382 NintegGen = 0 8383 8384 ! The temporal triangle used in the numerical integration 8385 ElementT % TYPE => GetElementType( 303, .FALSE. ) 8386 ElementT % NodeIndexes => IndexesT 8387 8388 DO ind=1,BMesh1 % NumberOfBulkElements 8389 8390 Element => BMesh1 % Elements(ind) 8391 Indexes => Element % NodeIndexes 8392 8393 n = Element % TYPE % NumberOfNodes 8394 ne = Element % TYPE % NumberOfEdges 8395 IF( PiolaVersion ) THEN 8396 nf = 2 8397 ELSE 8398 nf = 0 8399 END IF 8400 8401 Nodes % x(1:n) = BMesh1 % Nodes % x(Indexes(1:n)) 8402 Nodes % y(1:n) = BMesh1 % Nodes % y(Indexes(1:n)) 8403 8404 xmin = MINVAL(Nodes % x(1:n)) 8405 xmax = MAXVAL(Nodes % x(1:n)) 8406 ymin = MINVAL(Nodes % y(1:n)) 8407 ymax = MAXVAL(Nodes % y(1:n)) 8408 8409 IF( Repeating ) THEN 8410 Nrange = FLOOR( (xmin-XMinAll) / XRange ) 8411 xmin = xmin - Nrange * XRange 8412 xmax = xmax - Nrange * XRange 8413 Nodes % x(1:n) = Nodes % x(1:n) - NRange * XRange 8414 IF( xmax > XMaxAll ) THEN 8415 Nrange2 = 1 8416 ELSE IF( xmax < XMinAll ) THEN 8417 Nrange2 = -1 8418 ELSE 8419 Nrange2 = 0 8420 END IF 8421 ELSE IF( FullCircle ) THEN 8422 LeftCircle = ( ALL( ABS( Nodes % x(1:n) ) > 90.0_dp ) ) 8423 IF( LeftCircle ) THEN 8424 DO j=1,n 8425 IF( Nodes % x(j) < 0.0 ) Nodes % x(j) = Nodes % x(j) + 360.0_dp 8426 END DO 8427 END IF 8428 END IF 8429 8430 ! Transform the angle to archlength in order to have correct mapping 8431 ! of skewed edges. 8432 Nodes % x(1:n) = ArcCoeff * Nodes % x(1:n) 8433 xmin = MINVAL(Nodes % x(1:n)) 8434 xmax = MAXVAL(Nodes % x(1:n)) 8435 8436 ! Compute the reference area 8437 u = 0.0_dp; v = 0.0_dp; w = 0.0_dp; 8438 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 8439 IP = GaussPoints( Element ) 8440 RefArea = detJ * SUM( IP % s(1:IP % n) ) 8441 8442 SumArea = 0.0_dp 8443 SumOverlap = 0.0_dp 8444 8445200 sgn0 = 1 8446 IF( AntiRepeating ) THEN 8447 IF ( MODULO(Nrange,2) /= 0 ) sgn0 = -1 8448 END IF 8449 8450 ! find an index offset such that [j1,j2,j3,j4] is ordered the as the standard 8451 ! nodes in bilinear elements. This could be made generic as well, but it was 8452 ! easier for me to fix these indexes in this way and I was feeling lazy. 8453 j1 = 1; j2 = 1; j3 = 1; j4 = 1 8454 DO j=2,4 8455 ! Lower left 8456 IF( Nodes % x(j) + Nodes % y(j) < Nodes % x(j1) + Nodes % y(j1) ) j1 = j 8457 ! Lower right 8458 IF( Nodes % x(j) - Nodes % y(j) > Nodes % x(j2) - Nodes % y(j2) ) j2 = j 8459 ! Upper right 8460 IF( Nodes % x(j) + Nodes % y(j) > Nodes % x(j3) + Nodes % y(j3) ) j3 = j 8461 ! Upper left 8462 IF( Nodes % x(j) - Nodes % y(j) < Nodes % x(j4) - Nodes % y(j4) ) j4 = j 8463 END DO 8464 8465 ! Currently a n^2 loop but it could be improved 8466 !-------------------------------------------------------------------- 8467 DO indM=1,BMesh2 % NumberOfBulkElements 8468 8469 ElementM => BMesh2 % Elements(indM) 8470 IndexesM => ElementM % NodeIndexes 8471 8472 NodesM % y(1:n) = BMesh2 % Nodes % y(IndexesM(1:n)) 8473 8474 ! Make the quick and dirty search first 8475 yminm = MINVAL( NodesM % y(1:n)) 8476 IF( ABS( ymin - yminm ) > YTol ) CYCLE 8477 8478 ymaxm = MAXVAL( NodesM % y(1:n)) 8479 IF( ABS( ymax - ymaxm ) > YTol ) CYCLE 8480 8481 NodesM % x(1:n) = BMesh2 % Nodes % x(IndexesM(1:n)) 8482 8483 ! Treat the left circle differently. 8484 IF( LeftCircle ) THEN 8485 ! Omit the element if it is definitely on the right circle 8486 IF( ALL( ABS( NodesM % x(1:n) ) - 90.0_dp < Xtol ) ) CYCLE 8487 DO j=1,n 8488 IF( NodesM % x(j) < 0.0_dp ) NodesM % x(j) = NodesM % x(j) + 360.0_dp 8489 END DO 8490 END IF 8491 8492 ! Transfer into real length units instead of angles 8493 ! This gives right balance between x and y -directions. 8494 NodesM % x(1:n) = ArcCoeff * NodesM % x(1:n) 8495 8496 xminm = MINVAL( NodesM % x(1:n)) 8497 xmaxm = MAXVAL( NodesM % x(1:n)) 8498 8499 IF( FullCircle .AND. .NOT. LeftCircle ) THEN 8500 IF( xmaxm - xminm > ArcCoeff * 180.0_dp ) CYCLE 8501 END IF 8502 8503 Overlap = (MIN(xmax, xmaxm)- MAX(xmin,xminm))/(xmax-xmin) 8504 IF( Overlap < RelTolX ) CYCLE 8505 8506 SumOverlap = SumOverlap + Overlap 8507 Ninteg = Ninteg + 1 8508 8509 ! Then if this is a possible element create a list of the corner nodes 8510 ! for a temporal mesh. There will be 3 to 6 corner nodes. 8511 ! Check the crossings between the edges of the quadrilaters. These will 8512 ! be used as new points when creating the virtual triangle mesh. 8513 LeftSplit = ( ( Nodes % x(j1) - xminm ) * ( xminm - Nodes % x(j4) ) > 0.0_dp ) 8514 IF(LeftSplit) qleft = ( Nodes % x(j1) - xminm ) / ( Nodes % x(j1) - Nodes % x(j4) ) 8515 8516 RightSplit = ( ( Nodes % x(j2) - xmaxm ) * ( xmaxm - Nodes % x(j3) ) > 0.0_dp ) 8517 IF(RightSplit) qright = ( Nodes % x(j2) - xmaxm ) / ( Nodes % x(j2) - Nodes % x(j3) ) 8518 8519 LeftSplit2 = ( ( Nodes % x(j2) - xminm ) * ( xminm - Nodes % x(j3) ) > 0.0_dp ) 8520 IF(LeftSplit2) qleft2 = ( Nodes % x(j2) - xminm ) / ( Nodes % x(j2) - Nodes % x(j3) ) 8521 8522 RightSplit2 = ( ( Nodes % x(j1) - xmaxm ) * ( xmaxm - Nodes % x(j4) ) > 0.0_dp ) 8523 IF(RightSplit2) qright2 = ( Nodes % x(j1) - xmaxm ) / ( Nodes % x(j1) - Nodes % x(j4) ) 8524 8525 ! Mark the splits on the vertical edges aligned with the y-axis 8526 k = 0 8527 IF( LeftSplit ) THEN 8528 k = k + 1 8529 x(k) = xminm 8530 qleft = MAX( 0.0, MIN( 1.0, qleft ) ) 8531 y(k) = Nodes % y(j1) + qleft * ( Nodes % y(j4) - Nodes % y(j1)) 8532 END IF 8533 IF( RightSplit2 ) THEN 8534 k = k + 1 8535 x(k) = xmaxm 8536 qright2 = MAX( 0.0, MIN( 1.0, qright2 ) ) 8537 y(k) = Nodes % y(j1) + qright2 * ( Nodes % y(j4) - Nodes % y(j1)) 8538 END IF 8539 IF( RightSplit ) THEN 8540 k = k + 1 8541 x(k) = xmaxm 8542 qright = MAX( 0.0, MIN( 1.0, qright ) ) 8543 y(k) = Nodes % y(j2) + qright * ( Nodes % y(j3) - Nodes % y(j2)) 8544 END IF 8545 IF( LeftSplit2 ) THEN 8546 k = k + 1 8547 x(k) = xminm 8548 qleft2 = MAX( 0.0, MIN( 1.0, qleft2 ) ) 8549 y(k) = Nodes % y(j2) + qleft2 * ( Nodes % y(j3) - Nodes % y(j2)) 8550 END IF 8551 8552 ! Mark the splits on the horizontal axis 8553 BottomEdge = .NOT. ( ( Nodes % x(j2) < xminm ) .OR. ( Nodes % x(j1) > xmaxm ) ) 8554 TopEdge = .NOT. ( ( Nodes % x(j3) < xminm ) .OR. ( Nodes % x(j4) > xmaxm ) ) 8555 8556 IF( BottomEdge ) THEN 8557 k = k + 1 8558 x(k) = MAX( xminm, Nodes % x(j1) ) 8559 y(k) = yminm 8560 k = k + 1 8561 x(k) = MIN( xmaxm, Nodes % x(j2) ) 8562 y(k) = yminm 8563 END IF 8564 IF( TopEdge ) THEN 8565 k = k + 1 8566 x(k) = MIN( xmaxm, Nodes % x(j3) ) 8567 y(k) = ymaxm 8568 k = k + 1 8569 x(k) = MAX( xminm, Nodes % x(j4) ) 8570 y(k) = ymaxm 8571 END IF 8572 kmax = k 8573 8574 IF( kmax < 3 ) THEN 8575 CALL Warn('AddProjectorWeakStrides','Cannot integrate over '//TRIM(I2S(kmax))//' nodes') 8576 CYCLE 8577 END IF 8578 8579 ! The polygon is convex and hence its center lies inside the polygon 8580 xt = SUM(x(1:kmax)) / kmax 8581 yt = SUM(y(1:kmax)) / kmax 8582 8583 ! Set the angle from the center and order the nodes so that they 8584 ! can be easily triangulated. 8585 DO k=1,kmax 8586 phi(k) = ATAN2( y(k)-yt, x(k)-xt ) 8587 inds(k) = k 8588 END DO 8589 8590 CALL SortR(kmax,inds,phi) 8591 x(1:kmax) = x(inds(1:kmax)) 8592 y(1:kmax) = y(inds(1:kmax)) 8593 !PRINT *,'Polygon: ',ind,indm,LeftSplit, RightSplit, LeftSplit2, RightSplit2, TopEdge, BottomEdge, kmax 8594 8595 ! Deal the case with multiple corners by making 8596 ! triangulariation using one corner point. 8597 ! This should be ok as the polygon is always convex. 8598 NodesT % x(1) = x(1) 8599 NodesT % y(1) = y(1) 8600 8601 ! Use somewhat higher integration rules than the default 8602 IP = GaussPoints( ElementT, ElementT % TYPE % GaussPoints2 ) 8603 8604 DO k=1,kmax-2 8605 8606 ! This check over area also automatically elimiates redundant nodes 8607 ! that were detected twice. 8608 dArea = 0.5_dp*ABS( (x(k+1)-x(1))*(y(k+2)-y(1)) -(x(k+2)-x(1))*(y(k+1)-y(1))) 8609 IF( dArea < RelTolY**2 * RefArea ) CYCLE 8610 8611 NodesT % x(2) = x(k+1) 8612 NodesT % y(2) = y(k+1) 8613 NodesT % x(3) = x(k+2) 8614 NodesT % y(3) = y(k+2) 8615 8616 ! Integration over the temporal element 8617 DO nip=1, IP % n 8618 stat = ElementInfo( ElementT,NodesT,IP % u(nip),IP % v(nip),IP % w(nip),detJ,Basis) 8619 8620 ! We will actually only use the global coordinates and the integration weight 8621 ! from the temporal mesh. 8622 8623 ! Global coordinates of the integration point 8624 xt = SUM( Basis(1:3) * NodesT % x(1:3) ) 8625 yt = SUM( Basis(1:3) * NodesT % y(1:3) ) 8626 zt = 0.0_dp 8627 8628 ! Integration weight for current integration point 8629 Wtemp = DetJ * IP % s(nip) 8630 sumarea = sumarea + Wtemp 8631 8632 ! Integration point at the slave element 8633 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 8634 IF( EdgeBasis ) THEN 8635 IF (PiolaVersion) THEN 8636 stat = ElementInfo( Element, Nodes, u, v, w, & 8637 detJ, Basis, dBasisdx,EdgeBasis=WBasis) 8638 ELSE 8639 stat = ElementInfo( Element, Nodes, u, v, w, & 8640 detJ, Basis, dBasisdx ) 8641 CALL GetEdgeBasis(Element,WBasis,RotWBasis,Basis,dBasisdx) 8642 END IF 8643 ELSE 8644 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 8645 END IF 8646 8647 ! Integration point at the master element 8648 CALL GlobalToLocal( um, vm, wm, xt, yt, zt, ElementM, NodesM ) 8649 IF( EdgeBasis ) THEN 8650 IF (PiolaVersion) THEN 8651 stat = ElementInfo( ElementM, NodesM, um, vm, wm, & 8652 detJ, Basis, dBasisdx, EdgeBasis=WBasisM) 8653 ELSE 8654 stat = ElementInfo( ElementM, NodesM, um, vm, wm, & 8655 detJ, BasisM, dBasisdx ) 8656 CALL GetEdgeBasis(ElementM,WBasisM,RotWBasis,BasisM,dBasisdx) 8657 END IF 8658 ELSE 8659 stat = ElementInfo( ElementM, NodesM, um, vm, wm, detJ, BasisM ) 8660 END IF 8661 8662 ! Add the nodal dofs 8663 IF( DoNodes .AND. .NOT. StrongNodes ) THEN 8664 DO j=1,n 8665 jj = Indexes(j) 8666 nrow = NodePerm( InvPerm1(jj) ) 8667 IF( nrow == 0 ) CYCLE 8668 8669 Projector % InvPerm(nrow) = InvPerm1(jj) 8670 val = Basis(j) * Wtemp 8671 DO i=1,n 8672 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8673 InvPerm1(Indexes(i)), NodeCoeff * Basis(i) * val ) 8674 8675 IF( ABS( val * BasisM(i) ) < 1.0d-10 ) CYCLE 8676 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8677 InvPerm2(IndexesM(i)), -NodeScale * NodeCoeff * BasisM(i) * val ) 8678 END DO 8679 END DO 8680 END IF 8681 8682 IF( DoEdges ) THEN 8683 ! Dofs are numbered as follows: 8684 ! 1....number of nodes 8685 ! + ( 1 ... number of edges ) 8686 ! + ( 1 ... 2 x number of faces ) 8687 !------------------------------------------- 8688 DO j=1,ne+nf 8689 8690 IF( j <= ne ) THEN 8691 jj = Element % EdgeIndexes(j) 8692 IF( EdgePerm(jj) == 0 ) CYCLE 8693 nrow = EdgeRow0 + EdgePerm(jj) 8694 jj = jj + EdgeCol0 8695 Projector % InvPerm( nrow ) = jj 8696 ELSE 8697 jj = 2 * ( ind - 1 ) + ( j - 4 ) 8698 nrow = FaceRow0 + jj 8699 jj = 2 * ( Element % ElementIndex - 1) + ( j - 4 ) 8700 Projector % InvPerm( nrow ) = FaceCol0 + jj 8701 END IF 8702 8703 DO i=1,ne+nf 8704 IF( i <= ne ) THEN 8705 ii = Element % EdgeIndexes(i) + EdgeCol0 8706 ELSE 8707 ii = 2 * ( Element % ElementIndex - 1 ) + ( i - 4 ) + FaceCol0 8708 END IF 8709 val = Wtemp * SUM( WBasis(j,:) * Wbasis(i,:) ) 8710 IF( ABS( val ) > 1.0d-12 ) THEN 8711 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8712 ii, EdgeCoeff * val ) 8713 END IF 8714 8715 IF( i <= ne ) THEN 8716 ii = ElementM % EdgeIndexes(i) + EdgeCol0 8717 ELSE 8718 ii = 2 * ( ElementM % ElementIndex - 1 ) + ( i - 4 ) + FaceCol0 8719 END IF 8720 val = -Wtemp * SUM( WBasis(j,:) * WBasisM(i,:) ) 8721 IF( ABS( val ) > 1.0d-12 ) THEN 8722 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 8723 ii, EdgeScale * EdgeCoeff * val ) 8724 END IF 8725 END DO 8726 END DO 8727 END IF 8728 END DO 8729 END DO 8730 END DO 8731 8732 IF( Repeating ) THEN 8733 IF( NRange2 /= 0 ) THEN 8734 xmin = xmin - ArcCoeff * Nrange2 * XRange 8735 xmax = xmax - ArcCoeff * Nrange2 * XRange 8736 Nodes % x(1:n) = Nodes % x(1:n) - ArcCoeff * NRange2 * XRange 8737 NRange = NRange + NRange2 8738 NRange2 = 0 8739 GOTO 200 8740 END IF 8741 END IF 8742 8743 Err = SumArea/RefArea-1.0_dp 8744 MaxErr = MAX( MaxErr,ABS(Err)) 8745 END DO 8746 8747 DEALLOCATE( Nodes % x, Nodes % y, Nodes % z ) 8748 DEALLOCATE( NodesM % x, NodesM % y, NodesM % z ) 8749 DEALLOCATE( NodesT % x, NodesT % y, NodesT % z ) 8750 DEALLOCATE( Basis, BasisM ) 8751 DEALLOCATE( dBasisdx, WBasis, WBasisM, RotWBasis ) 8752 8753 CALL Info('AddProjectorWeakStrides','Number of integration pairs: '& 8754 //TRIM(I2S(Ninteg)),Level=10) 8755 8756 WRITE( Message,'(A,ES12.3)') 'Maximum error in area integration:',MaxErr 8757 CALL Info('AddProjectorWeakStrides',Message,Level=8) 8758 8759 8760 END SUBROUTINE AddProjectorWeakStrides 8761 8762 8763 SUBROUTINE LocalEdgeSolutionCoeffs( BC, Element, Nodes, ne, nf, PiolaVersion, SecondOrder, & 8764 dim, cFact ) 8765 TYPE(ValueList_t), POINTER :: BC 8766 TYPE(Element_t), POINTER :: Element 8767 TYPE(Nodes_t) :: Nodes 8768 INTEGER :: ne, nf, dim 8769 LOGICAL :: PiolaVersion, SecondOrder 8770 REAL(KIND=dp) :: cFact(:) 8771 8772 TYPE(GaussIntegrationPoints_t) :: IP 8773 INTEGER :: i,j,m,nip,AllocStat 8774 REAL(KIND=dp) :: u,v,w,uq,vq,CMass(6,6),CForce(6),detJ,wtemp 8775 REAL(KIND=dp), POINTER, SAVE :: Basis(:),WBasis(:,:),RotWBasis(:,:), & 8776 dBasisdx(:,:) 8777 LOGICAL :: stat, Visited = .FALSE. 8778 REAL(KIND=dp) :: cvec(2) 8779 REAL(KIND=dp), POINTER :: pCvec(:,:) 8780 8781 SAVE Visited, cVec 8782 8783 8784 IF( .NOT. Visited ) THEN 8785 m = 12 8786 ALLOCATE( Basis(m), WBasis(m,3), RotWBasis(m,3), dBasisdx(m,3), STAT=AllocStat ) 8787 IF( AllocStat /= 0 ) CALL Fatal('LocalEdgeSolutionCoeffs','Allocation error 3') 8788 8789 pCvec => ListGetConstRealArray( BC,'Level Projector Debug Vector',Found) 8790 IF( Found ) THEN 8791 Cvec(1:2) = pCvec(1:2,1) 8792 ELSE 8793 Cvec = 1.0_dp 8794 END IF 8795 Visited = .TRUE. 8796 END IF 8797 8798 8799 IP = GaussPoints( Element ) 8800 CMass = 0.0_dp 8801 cForce = 0.0_dp 8802 m = ne + nf 8803 8804 DO nip=1, IP % n 8805 u = IP % u(nip) 8806 v = IP % v(nip) 8807 w = 0.0_dp 8808 8809 IF (PiolaVersion) THEN 8810 ! Take into account that the reference elements are different: 8811 IF ( ne == 3) THEN 8812 uq = u 8813 vq = v 8814 u = -1.0d0 + 2.0d0*uq + vq 8815 v = SQRT(3.0d0)*vq 8816 END IF 8817 IF (SecondOrder) THEN 8818 stat = EdgeElementInfo( Element, Nodes, u, v, w, & 8819 DetF = DetJ, Basis = Basis, EdgeBasis = WBasis, & 8820 BasisDegree = 2, ApplyPiolaTransform = .TRUE.) 8821 ELSE 8822 stat = ElementInfo( Element, Nodes, u, v, w, & 8823 detJ, Basis, dBasisdx, EdgeBasis=WBasis) 8824 END IF 8825 ELSE 8826 stat = ElementInfo( Element, Nodes, u, v, w, & 8827 detJ, Basis, dBasisdx ) 8828 CALL GetEdgeBasis(Element,WBasis,RotWBasis,Basis,dBasisdx) 8829 END IF 8830 8831 wtemp = detJ * IP % s(nip) 8832 DO i=1,m 8833 DO j=1,m 8834 CMASS(i,j) = CMASS(i,j) + wtemp * SUM( WBasis(i,1:dim) * WBasis(j,1:dim) ) 8835 END DO 8836 CFORCE(i) = CFORCE(i) + wtemp * SUM( WBasis(i,1:dim) * cVec(1:dim) ) 8837 END DO 8838 END DO 8839 CALL LUSolve(m, CMass(1:m,1:m), cForce(1:m) ) 8840 cFact(1:m) = cForce(1:m) 8841 8842 END SUBROUTINE LocalEdgeSolutionCoeffs 8843 8844 8845 8846 !---------------------------------------------------------------------- 8847 ! Create weak projector for the remaining nodes and edges 8848 ! using generic algo that can deal with triangles and quadrilaterals. 8849 !---------------------------------------------------------------------- 8850 SUBROUTINE AddProjectorWeakGeneric() 8851 8852 INTEGER, TARGET :: IndexesT(3) 8853 INTEGER, POINTER :: Indexes(:), IndexesM(:) 8854 INTEGER :: jj,ii,sgn0,k,kmax,ind,indM,nip,nn,ne,nf,inds(10),nM,neM,nfM,iM,i2,i2M 8855 INTEGER :: edge, edof, fdof 8856 INTEGER :: ElemCands, TotCands, ElemHits, TotHits, EdgeHits, CornerHits, & 8857 MaxErrInd, MinErrInd, InitialHits, ActiveHits, TimeStep, Nrange1, NoGaussPoints, & 8858 Centeri, CenteriM, CenterJ, CenterJM, AllocStat, NrangeAve 8859 TYPE(Element_t), POINTER :: Element, ElementM, ElementP 8860 INTEGER :: ElemCode, LinCode, ElemCodeM, LinCodeM 8861 TYPE(Element_t) :: ElementT 8862 TYPE(Element_t), TARGET :: ElementLin 8863 TYPE(GaussIntegrationPoints_t) :: IP 8864 LOGICAL :: RightSplit, LeftSplit, LeftSplit2, RightSplit2, TopEdge, BottomEdge 8865 TYPE(Nodes_t) :: Nodes, NodesM, NodesT 8866 REAL(KIND=dp) :: x(10),y(10),xt,yt,zt,xmax,ymax,xmin,ymin,xmaxm,ymaxm,& 8867 xminm,yminm,DetJ,Wtemp,q,ArcTol,u,v,w,um,vm,wm,val,RefArea,dArea,& 8868 SumArea,MaxErr,MinErr,Err,phi(10),Point(3),uvw(3),ArcRange , & 8869 val_dual, zmin, zmax, zminm, zmaxm, dAlpha, uq, vq 8870 REAL(KIND=dp) :: A(2,2), B(2), C(2), absA, detA, rlen, & 8871 x1, x2, y1, y2, x1M, x2M, y1M, y2M, x0, y0, dist, DistTol, & 8872 amin, amax, aminM, amaxM, rmin2, rmax2, rmin2M, rmax2M 8873 REAL(KIND=dp) :: TotRefArea, TotSumArea, Area 8874 REAL(KIND=dp), ALLOCATABLE :: Basis(:), BasisM(:) 8875 REAL(KIND=dp), POINTER :: Alpha(:), AlphaM(:) 8876 REAL(KIND=dp), ALLOCATABLE :: WBasis(:,:),WBasisM(:,:),RotWbasis(:,:),dBasisdx(:,:) 8877 LOGICAL :: LeftCircle, Stat, CornerFound(4), CornerFoundM(4), PosAngle 8878 TYPE(Mesh_t), POINTER :: Mesh 8879 TYPE(Variable_t), POINTER :: TimestepVar 8880 8881 ! These are used temporarily for debugging purposes 8882 INTEGER :: SaveInd, MaxSubElem, MaxSubTriangles, DebugInd, Nslave, Nmaster 8883 LOGICAL :: SaveElem, DebugElem, SaveErr, DebugEdge 8884 REAL(KIND=dp) :: sums, summ, summ2, summabs, EdgeProj(2), EdgeProjM(2), ci, & 8885 EdgeErr, MaxEdgeErr, cFact(6),cFactM(6) 8886 CHARACTER(LEN=20) :: FileName 8887 REAL(KIND=dp), ALLOCATABLE :: CoeffBasis(:), MASS(:,:) 8888 8889 8890 CALL Info('AddProjectorWeakGeneric','Creating weak constraints using a generic integrator',Level=8) 8891 8892 Mesh => CurrentModel % Solver % Mesh 8893 8894 SaveInd = ListGetInteger( BC,'Level Projector Save Element Index',Found ) 8895 DebugInd = ListGetInteger( BC,'Level Projector Debug Element Index',Found ) 8896 SaveErr = ListGetLogical( BC,'Level Projector Save Fraction',Found) 8897 DebugEdge = ListGetLogical( BC,'Level Projector Debug Edge',Found ) 8898 8899 TimestepVar => VariableGet( Mesh % Variables,'Timestep',ThisOnly=.TRUE. ) 8900 Timestep = NINT( TimestepVar % Values(1) ) 8901 8902 IF( SaveErr ) THEN 8903 FileName = 'frac_'//TRIM(I2S(TimeStep))//'.dat' 8904 OPEN( 11,FILE=Filename) 8905 END IF 8906 8907 n = Mesh % MaxElementNodes 8908 ALLOCATE( Nodes % x(n), Nodes % y(n), Nodes % z(n), & 8909 NodesM % x(n), NodesM % y(n), NodesM % z(n), & 8910 NodesT % x(n), NodesT % y(n), NodesT % z(n), & 8911 Basis(n), BasisM(n), dBasisdx(n,3), STAT = AllocStat ) 8912 IF( AllocStat /= 0 ) CALL Fatal('AddProjectorWeakGeneric','Allocation error 1') 8913 8914 IF( Naxial > 1 ) THEN 8915 ALLOCATE( Alpha(n), AlphaM(n) ) 8916 ELSE 8917 Alpha => Nodes % x 8918 AlphaM => NodesM % x 8919 END IF 8920 8921 IF(BiOrthogonalBasis) THEN 8922 ALLOCATE(CoeffBasis(n), MASS(n,n), STAT=AllocStat) 8923 IF( AllocStat /= 0 ) CALL Fatal('AddProjectorWeakGeneric','Allocation error 2') 8924 END IF 8925 8926 IF( EdgeBasis ) THEN 8927 n = 12 ! Hard-coded size sufficient for second-order edge elements 8928 ALLOCATE( WBasis(n,3), WBasisM(n,3), RotWBasis(n,3), STAT=AllocStat ) 8929 IF( AllocStat /= 0 ) CALL Fatal('AddProjectorWeakGeneric','Allocation error 3') 8930 END IF 8931 8932 Nodes % z = 0.0_dp 8933 NodesM % z = 0.0_dp 8934 NodesT % z = 0.0_dp 8935 8936 MaxErr = 0.0_dp 8937 MinErr = HUGE( MinErr ) 8938 MaxErrInd = 0 8939 MinErrInd = 0 8940 zt = 0.0_dp 8941 LeftCircle = .FALSE. 8942 8943 ArcTol = ArcCoeff * Xtol 8944 ArcRange = ArcCoeff * Xrange 8945 8946 DistTol = ArcTol**2 + YTol**2 8947 8948 ! The temporal triangle used in the numerical integration 8949 ElementT % TYPE => GetElementType( 303, .FALSE. ) 8950 ElementT % NodeIndexes => IndexesT 8951 TotCands = 0 8952 TotHits = 0 8953 EdgeHits = 0 8954 CornerHits = 0 8955 InitialHits = 0 8956 ActiveHits = 0 8957 TotRefArea = 0.0_dp 8958 TotSumArea = 0.0_dp 8959 Point = 0.0_dp 8960 MaxSubTriangles = 0 8961 Nslave = 0 8962 Nmaster = 0 8963 8964 IF( DebugEdge ) THEN 8965 sums = 0.0_dp; summ = 0.0_dp; summ2 = 0.0_dp; summabs = 0.0_dp 8966 MaxEdgeErr = 0.0_dp 8967 END IF 8968 8969 ! Identify center nodes for axial projectors since at the origin the angle 8970 ! is impossible to determine. Instead for the origin the angle is the average 8971 ! of the other angles in the element. 8972 CenterI = 0 8973 CenterIM = 0 8974 CenterJ = 0 8975 CenterJM = 0 8976 IF( Naxial > 1 ) THEN 8977 DO i=1,BMesh1 % NumberOfNodes 8978 IF( BMesh1 % Nodes % x(i)**2 + BMesh1 % Nodes % y(i)**2 < 1.0d-20 ) THEN 8979 CenterI = i 8980 CALL Info('AddProjectorWeakGeneric','Found center node in slave: '& 8981 //TRIM(I2S(CenterI)),Level=10) 8982 EXIT 8983 END IF 8984 END DO 8985 DO i=1,BMesh2 % NumberOfNodes 8986 IF( BMesh2 % Nodes % x(i)**2 + BMesh2 % Nodes % y(i)**2 < 1.0d-20 ) THEN 8987 CenterIM = i 8988 CALL Info('AddProjectorWeakGeneric','Found center node in master: '& 8989 //TRIM(I2S(CenterI)),Level=10) 8990 EXIT 8991 END IF 8992 END DO 8993 END IF 8994 8995 8996 DO ind=1,BMesh1 % NumberOfBulkElements 8997 8998 ! Optionally save the submesh for specified element, for vizualization and debugging 8999 SaveElem = ( SaveInd == ind ) 9000 DebugElem = ( DebugInd == ind ) 9001 9002 IF( DebugElem ) THEN 9003 PRINT *,'Debug element turned on:',ind 9004 END IF 9005 9006 Element => BMesh1 % Elements(ind) 9007 Indexes => Element % NodeIndexes 9008 9009 n = Element % TYPE % NumberOfNodes 9010 ! We use 'ne' also to indicate number of corners since for triangles and quads these are the same 9011 ne = Element % TYPE % NumberOfEdges ! #(SLAVE EDGES) 9012 nf = Element % BDOFs ! #(SLAVE FACE DOFS) 9013 9014 ElemCode = Element % TYPE % ElementCode 9015 LinCode = 101 * ne 9016 9017 ! Transform the angle to archlength in order to have correct balance between x and y 9018 Nodes % x(1:n) = ArcCoeff * BMesh1 % Nodes % x(Indexes(1:n)) 9019 Nodes % y(1:n) = BMesh1 % Nodes % y(Indexes(1:n)) 9020 9021 ! For axial projector the angle is neither of the coordinates 9022 IF( Naxial > 1 ) THEN 9023 ! Calculate the [min,max] range of radius squared for slave element. 9024 ! We are working with squares because squareroot is a relatively expensive operation. 9025 rmax2 = 0.0_dp 9026 DO j=1,ne 9027 val = Nodes % x(j)**2 + Nodes % y(j)**2 9028 rmax2 = MAX( rmax2, val ) 9029 END DO 9030 9031 ! The minimum distance in (r,phi) system is not simply minimum of r 9032 ! We have to find minimum between (0,0) and the line passing (x1,y1) and (x2,y2) 9033 rmin2 = HUGE( rmin2 ) 9034 DO j=1,ne 9035 k = j+1 9036 IF( k > ne ) k = 1 9037 val = SegmentOriginDistance2( Nodes % x(j), Nodes % y(j), & 9038 Nodes % x(k), Nodes % y(k) ) 9039 rmin2 = MIN( rmin2, val ) 9040 END DO 9041 9042 ! Calculate the angle, and its [-180,180] range 9043 DO j=1,ne 9044 alpha(j) = ( 180.0_dp / PI ) * ATAN2( Nodes % y(j), Nodes % x(j) ) 9045 END DO 9046 9047 ! If we have origin replace it with the average 9048 IF( CenterI > 0 ) THEN 9049 CenterJ = 0 9050 DO j=1,ne 9051 IF( Indexes(j) == CenterI ) THEN 9052 alpha(j) = 0.0_dp 9053 alpha(j) = SUM( Alpha(1:ne) ) / ( ne - 1 ) 9054 CenterJ = j 9055 EXIT 9056 END IF 9057 END DO 9058 END IF 9059 9060 amin = MINVAL( Alpha(1:ne) ) 9061 amax = MAXVAL( Alpha(1:ne) ) 9062 IF( amax - amin < 180.0_dp ) THEN 9063 PosAngle = .FALSE. 9064 ELSE 9065 PosAngle = .TRUE. 9066 ! Map the angle to [0,360] 9067 DO j=1,ne 9068 IF( Alpha(j) < 0.0 ) Alpha(j) = Alpha(j) + 360.0_dp 9069 END DO 9070 IF( CenterJ > 0 ) THEN 9071 alpha(CenterJ) = 0.0_dp 9072 alpha(CenterJ) = SUM( Alpha(1:ne) ) / ( ne - 1 ) 9073 END IF 9074 amin = MINVAL( Alpha(1:ne) ) 9075 amax = MAXVAL( Alpha(1:ne) ) 9076 END IF 9077 END IF ! Naxial > 1 9078 9079 ! If we have full angle eliminate the discontinuity of the angle 9080 ! since we like to do the mapping using continuous coordinates. 9081 IF( FullCircle ) THEN 9082 LeftCircle = ( ALL( ABS( Alpha(1:ne) ) > ArcCoeff * 90.0_dp ) ) 9083 IF( LeftCircle ) THEN 9084 DO j=1,n 9085 IF( Alpha(j) < 0.0 ) Alpha(j) = Alpha(j) + ArcCoeff * 360.0_dp 9086 END DO 9087 END IF 9088 END IF 9089 9090 ! Even for quadratic elements only work with corner nodes (n >= ne) 9091 xmin = MINVAL(Nodes % x(1:ne)) 9092 xmax = MAXVAL(Nodes % x(1:ne)) 9093 9094 ymin = MINVAL(Nodes % y(1:ne)) 9095 ymax = MAXVAL(Nodes % y(1:ne)) 9096 9097 IF( HaveMaxDistance ) THEN 9098 zmin = MINVAL( BMesh1 % Nodes % z(Indexes(1:ne)) ) 9099 zmax = MAXVAL( BMesh1 % Nodes % z(Indexes(1:ne)) ) 9100 END IF 9101 9102 IF( DebugEdge ) THEN 9103 CALL LocalEdgeSolutionCoeffs( BC, Element, Nodes, ne, nf, & 9104 PiolaVersion, SecondOrder, 2, cFact ) 9105 EdgeProj = 0.0_dp; EdgeProjM = 0.0_dp 9106 END IF 9107 9108 ! Compute the reference area 9109 u = 0.0_dp; v = 0.0_dp; w = 0.0_dp; 9110 9111 IF( DebugElem ) THEN 9112 PRINT *,'inds',n,ne,LinCode,ElemCode 9113 PRINT *,'x:',Nodes % x(1:n) 9114 PRINT *,'y:',Nodes % y(1:n) 9115 PRINT *,'z:',Nodes % z(1:n) 9116 PRINT *,'xrange:',xmin,xmax 9117 PRINT *,'yrange:',ymin,ymax 9118 PRINT *,'zrange:',zmin,zmax 9119 IF( Naxial > 1 ) PRINT *,'Alpha: ',Alpha(1:n) 9120 END IF 9121 9122 9123 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 9124 9125 IP = GaussPoints( Element ) 9126 RefArea = detJ * SUM( IP % s(1:IP % n) ) 9127 SumArea = 0.0_dp 9128 9129 IF( SaveElem ) THEN 9130 FileName = 't'//TRIM(I2S(TimeStep))//'_a.dat' 9131 OPEN( 10,FILE=Filename) 9132 DO i=1,ne 9133 WRITE( 10, * ) Nodes % x(i), Nodes % y(i) 9134 END DO 9135 CLOSE( 10 ) 9136 END IF 9137 9138 IF( DebugElem ) THEN 9139 PRINT *,'RefArea:',RefArea,detJ 9140 PRINT *,'Basis:',Basis(1:n) 9141 END IF 9142 9143 9144 IF( DoNodes .AND. .NOT. StrongNodes ) THEN 9145 DO i=1,n 9146 j = InvPerm1(Indexes(i)) 9147 nrow = NodePerm(j) 9148 IF( nrow == 0 ) CYCLE 9149 CALL List_AddMatrixIndex(Projector % ListMatrix, nrow, j ) 9150 IF(ASSOCIATED(Projector % Child)) & 9151 CALL List_AddMatrixIndex(Projector % Child % ListMatrix, nrow, j ) 9152 END DO 9153 END IF 9154 9155 9156 ! Currently a n^2 loop but it could be improved 9157 !-------------------------------------------------------------------- 9158 ElemCands = 0 9159 ElemHits = 0 9160 9161 9162 DO indM=1,BMesh2 % NumberOfBulkElements 9163 9164 ElementM => BMesh2 % Elements(indM) 9165 IndexesM => ElementM % NodeIndexes 9166 9167 nM = ElementM % TYPE % NumberOfNodes 9168 neM = ElementM % TYPE % ElementCode / 100 9169 9170 ElemCodeM = Element % TYPE % ElementCode 9171 LinCodeM = 101 * neM 9172 9173 IF( DebugElem ) THEN 9174 PRINT *,'Candidate Elem:',indM,nM,NeM, ElemCodeM,LinCodeM 9175 END IF 9176 9177 IF( HaveMaxDistance ) THEN 9178 zminm = MINVAL( BMesh2 % Nodes % z(IndexesM(1:neM)) ) 9179 zmaxm = MINVAL( BMesh2 % Nodes % z(IndexesM(1:neM)) ) 9180 IF( zmaxm < zmin - MaxDistance ) CYCLE 9181 IF( zminm > zmax + MaxDistance ) CYCLE 9182 END IF 9183 9184 NodesM % y(1:nM) = BMesh2 % Nodes % y(IndexesM(1:nM)) 9185 9186 ! Make the quick and dirty search first 9187 ! This requires some minimal width of the cut 9188 IF(Naxial <= 1 ) THEN 9189 yminm = MINVAL( NodesM % y(1:neM)) 9190 IF( yminm > ymax ) CYCLE 9191 9192 ymaxm = MAXVAL( NodesM % y(1:neM)) 9193 IF( ymaxm < ymin ) CYCLE 9194 9195 NodesM % x(1:nM) = ArcCoeff * BMesh2 % Nodes % x(IndexesM(1:nM)) 9196 ELSE 9197 NodesM % x(1:nM) = ArcCoeff * BMesh2 % Nodes % x(IndexesM(1:nM)) 9198 9199 ! For axial projector first check the radius since it does not have complications with 9200 ! periodicity and is therefore cheaper. 9201 rmax2M = 0.0_dp 9202 DO j=1,neM 9203 val = NodesM % x(j)**2 + NodesM % y(j)**2 9204 rmax2M = MAX( rmax2M, val ) 9205 END DO 9206 IF( rmax2m < rmin2 ) CYCLE 9207 9208 ! The minimum distance in (r,phi) system is not simply minimum of r 9209 ! We have to find minimum between (0,0) and the line passing (x1,y1) and (x2,y2) 9210 rmin2M = HUGE( rmin2M ) 9211 DO j=1,neM 9212 k = j+1 9213 IF( k > neM ) k = 1 9214 val = SegmentOriginDistance2( NodesM % x(j), NodesM % y(j), & 9215 NodesM % x(k), NodesM % y(k) ) 9216 rmin2M = MIN( rmin2M, val ) 9217 END DO 9218 IF( rmin2m > rmax2 ) CYCLE 9219 9220 ! Angle in [-180,180] or [0,360] depending where the slave angle is mapped 9221 DO j=1,neM 9222 alphaM(j) = ( 180.0_dp / PI ) * ATAN2( NodesM % y(j), NodesM % x(j) ) 9223 END DO 9224 9225 ! If we have origin replace it with the average 9226 IF( CenterIM > 0 ) THEN 9227 CenterJm = 0 9228 DO j=1,neM 9229 IF( IndexesM(j) == CenterIM ) THEN 9230 CenterJM = j 9231 alphaM(j) = 0.0_dp 9232 alphaM(j) = SUM( AlphaM(1:neM) ) / ( neM - 1 ) 9233 EXIT 9234 END IF 9235 END DO 9236 END IF 9237 9238 aminm = MINVAL( AlphaM(1:neM) ) 9239 amaxm = MAXVAL( AlphaM(1:neM) ) 9240 9241 IF( amaxm - aminm > 180.0_dp ) THEN 9242 ! Map the angle to [0,360] 9243 DO j=1,neM 9244 IF( AlphaM(j) < 0.0 ) AlphaM(j) = AlphaM(j) + 360.0_dp 9245 END DO 9246 IF( CenterJM > 0 ) THEN 9247 alphaM(CenterJM) = 0.0_dp 9248 alphaM(CenterJM) = SUM( AlphaM(1:ne) ) / ( ne - 1 ) 9249 END IF 9250 aminm = MINVAL( AlphaM(1:neM) ) 9251 amaxm = MAXVAL( AlphaM(1:neM) ) 9252 END IF 9253 END IF 9254 9255 ! Treat the left circle differently. 9256 IF( LeftCircle ) THEN 9257 ! Omit the element if it is definitely on the right circle 9258 IF( ALL( ABS( AlphaM(1:neM) ) - ArcCoeff * 90.0_dp < ArcTol ) ) CYCLE 9259 DO j=1,neM 9260 IF( AlphaM(j) < 0.0_dp ) AlphaM(j) = AlphaM(j) + ArcCoeff * 360.0_dp 9261 END DO 9262 END IF 9263 9264 IF( Repeating ) THEN 9265 ! Enforce xmaxm to be on the same interval than xmin 9266 IF( Naxial > 1 ) THEN 9267 Nrange1 = FLOOR( Naxial * (amaxm-amin+RelTolX) / 360.0_dp ) 9268 Nrange2 = FLOOR( Naxial * (amax-aminm+RelTolX) / 360.0_dp ) 9269 9270 ! The two ranges could have just offset of 2*PI, eliminate that 9271 !Nrange2 = Nrange2 + ((Nrange1 - Nrange2)/Naxial) * Naxial 9272 ! Nrange2 = Nrange1 9273 !END IF 9274 9275 IF( MODULO( Nrange1 - Nrange2, Naxial ) == 0 ) THEN 9276 Nrange2 = Nrange1 9277 END IF 9278 9279 IF( MODULO( Nrange1, Naxial) /= 0 ) THEN 9280 dAlpha = Nrange1 * 2.0_dp * PI / Naxial 9281 DO i=1,nM 9282 x0 = NodesM % x(i) 9283 y0 = NodesM % y(i) 9284 NodesM % x(i) = COS(dAlpha) * x0 - SIN(dAlpha) * y0 9285 NodesM % y(i) = SIN(dAlpha) * x0 + COS(dAlpha) * y0 9286 END DO 9287 END IF 9288 9289 !IF( Nrange2 > Nrange1 + Naxial / 2 ) THEN 9290 ! Nrange2 = Nrange2 - Naxial 9291 !ELSE IF( Nrange2 < Nrange1 - Naxial / 2 ) THEN 9292 ! Nrange2 = Nrange2 + Naxial 9293 !END IF 9294 9295 IF( DebugElem) THEN 9296 PRINT *,'axial:',ind,indM,amin,aminm,Nrange1,Nrange2 9297 PRINT *,'coord:',Nodes % x(1), Nodes % y(1), NodesM % x(1), NodesM % y(1) 9298 PRINT *,'Alphas:',Alpha(1:n),AlphaM(1:nM) 9299 END IF 9300 9301 ELSE 9302 xminm = MINVAL( NodesM % x(1:nM) ) 9303 xmaxm = MAXVAL( NodesM % x(1:nM) ) 9304 9305 Nrange1 = FLOOR( (xmaxm-xmin+ArcTol) / ArcRange ) 9306 Nrange2 = FLOOR( (xmax-xminm+ArcTol) / ArcRange ) 9307 IF( Nrange1 /= 0 ) THEN 9308 NodesM % x(1:nM) = NodesM % x(1:nM) - NRange1 * ArcRange 9309 END IF 9310 END IF 9311 9312 Nrange = Nrange1 9313 END IF 9314 9315 xminm = MINVAL( NodesM % x(1:neM) ) 9316 xmaxm = MAXVAL( NodesM % x(1:neM) ) 9317 9318 IF( FullCircle .AND. .NOT. LeftCircle ) THEN 9319 IF( xmaxm - xminm > ArcCoeff * 180.0_dp ) CYCLE 9320 END IF 9321 9322200 IF( xminm > xmax ) GOTO 100 9323 IF( xmaxm < xmin ) GOTO 100 9324 9325 9326 ! Rotation alters also the y-coordinate for "axial projector" 9327 ! Therefore this check is postponed until here. 9328 IF( Naxial > 1 ) THEN 9329 yminm = MINVAL( NodesM % y(1:nM) ) 9330 IF( yminm > ymax ) GOTO 100 9331 9332 ymaxm = MAXVAL( NodesM % y(1:nM)) 9333 IF( ymaxm < ymin ) GOTO 100 9334 END IF 9335 9336 neM = ElementM % TYPE % NumberOfEdges 9337 nfM = ElementM % BDOFs 9338 9339 k = 0 9340 ElemCands = ElemCands + 1 9341 CornerFound = .FALSE. 9342 CornerFoundM = .FALSE. 9343 9344 ! Check through the nodes that are created in the intersections of any two edge 9345 DO i=1,ne 9346 x1 = Nodes % x(i) 9347 y1 = Nodes % y(i) 9348 i2 = i + 1 9349 IF( i2 > ne ) i2 = 1 ! check the (ne,1) edge also 9350 x2 = Nodes % x(i2) 9351 y2 = Nodes % y(i2) 9352 9353 DO iM=1,neM 9354 x1M = NodesM % x(iM) 9355 y1M = NodesM % y(iM) 9356 i2M = iM + 1 9357 IF( i2M > neM ) i2M = 1 9358 x2M = NodesM % x(i2M) 9359 y2M = NodesM % y(i2M) 9360 9361 ! Upon solution this is tampered so it must be initialized 9362 ! before each solution. 9363 A(1,1) = x2 - x1 9364 A(2,1) = y2 - y1 9365 A(1,2) = x1M - x2M 9366 A(2,2) = y1M - y2M 9367 9368 detA = A(1,1)*A(2,2)-A(1,2)*A(2,1) 9369 absA = SUM(ABS(A(1,1:2))) * SUM(ABS(A(2,1:2))) 9370 9371 ! Lines are almost parallel => no intersection possible 9372 ! Check the dist at the end of the line segments. 9373 IF(ABS(detA) < 1.0d-8 * absA + 1.0d-20 ) CYCLE 9374 9375 B(1) = x1M - x1 9376 B(2) = y1M - y1 9377 9378 CALL InvertMatrix( A,2 ) 9379 C(1:2) = MATMUL(A(1:2,1:2),B(1:2)) 9380 9381 ! Check that the hit is within the line segment 9382 IF(ANY(C(1:2) < 0.0) .OR. ANY(C(1:2) > 1.0d0)) CYCLE 9383 9384 ! We have a hit, two line segments can have only one hit 9385 k = k + 1 9386 9387 x(k) = x1 + C(1) * (x2-x1) 9388 y(k) = y1 + C(1) * (y2-y1) 9389 9390 ! If the point of intersection is at the end of a line-segment it 9391 ! is also a corner node. 9392 IF(ABS(C(1)) < 1.0d-6 ) THEN 9393 CornerFound(i) = .TRUE. 9394 ELSE IF( ABS(C(1)-1.0_dp ) < 1.0d-6 ) THEN 9395 CornerFound(i2) = .TRUE. 9396 END IF 9397 9398 IF(ABS(C(2)) < 1.0d-6 ) THEN 9399 CornerFoundM(iM) = .TRUE. 9400 ELSE IF( ABS(C(2)-1.0_dp ) < 1.0d-6 ) THEN 9401 CornerFoundM(i2M) = .TRUE. 9402 END IF 9403 9404 EdgeHits = EdgeHits + 1 9405 END DO 9406 END DO 9407 9408 IF( DebugElem ) THEN 9409 PRINT *,'EdgeHits:',k 9410 END IF 9411 9412 ! Check the nodes that are one of the existing nodes i.e. corner nodes 9413 ! that are located inside in either element. We have to check both combinations. 9414 DO i=1,ne 9415 ! This corner was already determined active as the end of edge 9416 IF( CornerFound(i) ) CYCLE 9417 9418 Point(1) = Nodes % x(i) 9419 IF( Point(1) < xminm - ArcTol ) CYCLE 9420 IF( Point(1) > xmaxm + ArcTol ) CYCLE 9421 9422 Point(2) = Nodes % y(i) 9423 IF( Point(2) < yminm - YTol ) CYCLE 9424 IF( Point(2) > ymaxm + YTol ) CYCLE 9425 9426 ! The edge intersections should catch the sharp hits so here we can use hard criteria 9427 Found = PointInElement( ElementM, NodesM, Point, uvw, LocalEps = 1.0d-8 ) 9428 IF( Found ) THEN 9429 k = k + 1 9430 x(k) = Point(1) 9431 y(k) = Point(2) 9432 CornerHits = CornerHits + 1 9433 END IF 9434 END DO 9435 9436 IF( DebugElem ) THEN 9437 PRINT *,'CornerHits:',k 9438 END IF 9439 9440 ! Possible corner hits for the master element 9441 DO i=1,neM 9442 IF( CornerFoundM(i) ) CYCLE 9443 9444 Point(1) = NodesM % x(i) 9445 IF( Point(1) < xmin - ArcTol ) CYCLE 9446 IF( Point(1) > xmax + ArcTol ) CYCLE 9447 9448 Point(2) = NodesM % y(i) 9449 IF( Point(2) < ymin - YTol ) CYCLE 9450 IF( Point(2) > ymax + YTol ) CYCLE 9451 9452 Found = PointInElement( Element, Nodes, Point, uvw, LocalEps = 1.0d-8 ) 9453 IF( Found ) THEN 9454 k = k + 1 9455 x(k) = Point(1) 9456 y(k) = Point(2) 9457 CornerHits = CornerHits + 1 9458 END IF 9459 END DO 9460 9461 IF( DebugElem ) THEN 9462 PRINT *,'CornerHitsM:',k 9463 END IF 9464 9465 kmax = k 9466 IF( kmax < 3 ) GOTO 100 9467 9468 IF( DebugEdge ) THEN 9469 CALL LocalEdgeSolutionCoeffs( BC, ElementM, NodesM, neM, nfM, & 9470 PiolaVersion, SecondOrder, 2, cFactM ) 9471 END IF 9472 9473 sgn0 = 1 9474 IF( AntiRepeating ) THEN 9475 IF ( MODULO(Nrange,2) /= 0 ) sgn0 = -1 9476 END IF 9477 9478 InitialHits = InitialHits + kmax 9479 9480 ! The polygon is convex and hence its center lies inside the polygon 9481 xt = SUM(x(1:kmax)) / kmax 9482 yt = SUM(y(1:kmax)) / kmax 9483 9484 ! Set the angle from the center and order the nodes so that they 9485 ! can be easily triangulated. 9486 DO k=1,kmax 9487 phi(k) = ATAN2( y(k)-yt, x(k)-xt ) 9488 inds(k) = k 9489 END DO 9490 9491 IF( DebugElem ) THEN 9492 PRINT *,'Phis:',phi(1:kmax) 9493 END IF 9494 9495 CALL SortR(kmax,inds,phi) 9496 x(1:kmax) = x(inds(1:kmax)) 9497 y(1:kmax) = y(inds(1:kmax)) 9498 9499 ! Eliminate redundant corners from the polygon 9500 j = 1 9501 DO k=2,kmax 9502 dist = (x(j)-x(k))**2 + (y(j)-y(k))**2 9503 IF( dist > DistTol ) THEN 9504 j = j + 1 9505 IF( j /= k ) THEN 9506 x(j) = x(k) 9507 y(j) = y(k) 9508 END IF 9509 END IF 9510 END DO 9511 kmax = j 9512 9513 IF( DebugElem ) THEN 9514 PRINT *,'Corners:',kmax 9515 PRINT *,'Center:',xt,yt 9516 END IF 9517 9518 IF( kmax < 3 ) GOTO 100 9519 9520 ElemHits = ElemHits + 1 9521 ActiveHits = ActiveHits + kmax 9522 9523 IF( kmax > MaxSubTriangles ) THEN 9524 MaxSubTriangles = kmax 9525 MaxSubElem = ind 9526 END IF 9527 9528 IF( SaveElem ) THEN 9529 FileName = 't'//TRIM(I2S(TimeStep))//'_b'//TRIM(I2S(ElemHits))//'.dat' 9530 OPEN( 10,FILE=FileName) 9531 DO i=1,nM 9532 WRITE( 10, * ) NodesM % x(i), NodesM % y(i) 9533 END DO 9534 CLOSE( 10 ) 9535 9536 FileName = 't'//TRIM(I2S(TimeStep))//'_d'//TRIM(I2S(ElemHits))//'.dat' 9537 OPEN( 10,FILE=FileName) 9538 DO i=1,nM 9539 WRITE( 10, * ) xt, yt 9540 END DO 9541 CLOSE( 10 ) 9542 9543 FileName = 't'//TRIM(I2S(TimeStep))//'_e'//TRIM(I2S(ElemHits))//'.dat' 9544 OPEN( 10,FILE=FileName) 9545 DO i=1,kmax 9546 WRITE( 10, * ) x(i), y(i) 9547 END DO 9548 CLOSE( 10 ) 9549 END IF 9550 9551 9552 ! Deal the case with multiple corners by making 9553 ! triangulariation using one corner point. 9554 ! This should be ok as the polygon is always convex. 9555 NodesT % x(1) = x(1) 9556 NodesT % y(1) = y(1) 9557 9558 ! Use somewhat higher integration rules than the default 9559 9560 NoGaussPoints = ListGetInteger( BC,'Mortar BC Gauss Points',Found ) 9561 IF(.NOT. Found ) NoGaussPoints = ElementT % Type % GaussPoints2 9562 IP = GaussPoints( ElementT, NoGaussPoints ) 9563 9564 9565 DO k=1,kmax-2 9566 9567 ! This check over area also automatically elimiates redundant nodes 9568 ! that were detected twice. 9569 dArea = 0.5_dp*ABS( (x(k+1)-x(1))*(y(k+2)-y(1)) -(x(k+2)-x(1))*(y(k+1)-y(1))) 9570 9571 IF( DebugElem ) THEN 9572 PRINT *,'dArea:',dArea,dArea / RefArea 9573 END IF 9574 9575 IF( dArea < RelTolY**2 * RefArea ) CYCLE 9576 9577 ! Triangle is created by keeping one corner node fixed and rotating through 9578 ! the other nodes. 9579 NodesT % x(2) = x(k+1) 9580 NodesT % y(2) = y(k+1) 9581 NodesT % x(3) = x(k+2) 9582 NodesT % y(3) = y(k+2) 9583 9584 IF(BiOrthogonalBasis) THEN 9585 MASS = 0 9586 CoeffBasis = 0 9587 area = 0._dp 9588 DO nip=1, IP % n 9589 stat = ElementInfo( ElementT,NodesT,IP % u(nip),& 9590 IP % v(nip),IP % w(nip),detJ,Basis) 9591 IF(.NOT. Stat ) EXIT 9592 9593 ! We will actually only use the global coordinates and the integration weight 9594 ! from the temporal mesh. 9595 9596 ! Global coordinates of the integration point 9597 xt = SUM( Basis(1:3) * NodesT % x(1:3) ) 9598 yt = SUM( Basis(1:3) * NodesT % y(1:3) ) 9599 zt = 0.0_dp 9600 9601 ! Integration weight for current integration point 9602 Wtemp = DetJ * IP % s(nip) 9603 area = area + wtemp 9604 9605 ! Integration point at the slave element 9606 IF( ElemCode /= LinCode ) THEN 9607 ElementLin % TYPE => GetElementType( LinCode, .FALSE. ) 9608 ElementLin % NodeIndexes => Element % NodeIndexes 9609 ElementP => ElementLin 9610 CALL GlobalToLocal( u, v, w, xt, yt, zt, ElementP, Nodes ) 9611 ELSE 9612 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 9613 END IF 9614 9615 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 9616 IF(.NOT. Stat) CYCLE 9617 9618 DO i=1,n 9619 DO j=1,n 9620 MASS(i,j) = MASS(i,j) + wTemp * Basis(i) * Basis(j) 9621 END DO 9622 CoeffBasis(i) = CoeffBasis(i) + wTemp * Basis(i) 9623 END DO 9624 END DO 9625 9626 IF(Area<1.d-12) GOTO 300 9627 9628 CALL InvertMatrix( MASS, n ) 9629 9630 DO i=1,n 9631 DO j=1,n 9632 MASS(i,j) = MASS(i,j) * CoeffBasis(i) 9633 END DO 9634 END DO 9635 END IF 9636 9637 ! Integration over the temporal element 9638 DO nip=1, IP % n 9639 stat = ElementInfo( ElementT,NodesT,IP % u(nip),& 9640 IP % v(nip),IP % w(nip),detJ,Basis) 9641 IF(.NOT. Stat) EXIT 9642 9643 ! We will actually only use the global coordinates and the integration weight 9644 ! from the temporal mesh. 9645 9646 ! Global coordinates of the integration point 9647 xt = SUM( Basis(1:3) * NodesT % x(1:3) ) 9648 yt = SUM( Basis(1:3) * NodesT % y(1:3) ) 9649 zt = 0.0_dp 9650 9651 ! Integration weight for current integration point 9652 Wtemp = DetJ * IP % s(nip) 9653 sumarea = sumarea + Wtemp 9654 9655 ! Integration point at the slave element 9656 IF( ElemCode /= LinCode ) THEN 9657 ElementLin % TYPE => GetElementType( LinCode, .FALSE. ) 9658 ElementLin % NodeIndexes => Element % NodeIndexes 9659 ElementP => ElementLin 9660 CALL GlobalToLocal( u, v, w, xt, yt, zt, ElementP, Nodes ) 9661 ELSE 9662 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 9663 END IF 9664 9665 9666 IF( EdgeBasis ) THEN 9667 IF (PiolaVersion) THEN 9668 ! Take into account that the reference elements are different: 9669 IF ( ne == 3) THEN 9670 uq = u 9671 vq = v 9672 u = -1.0d0 + 2.0d0*uq + vq 9673 v = SQRT(3.0d0)*vq 9674 END IF 9675 IF (SecondOrder) THEN 9676 stat = EdgeElementInfo( Element, Nodes, u, v, w, & 9677 DetF = DetJ, Basis = Basis, EdgeBasis = WBasis, & 9678 BasisDegree = 2, ApplyPiolaTransform = .TRUE.) 9679 ELSE 9680 stat = ElementInfo( Element, Nodes, u, v, w, & 9681 detJ, Basis, dBasisdx,EdgeBasis=WBasis) 9682 END IF 9683 ELSE 9684 stat = ElementInfo( Element, Nodes, u, v, w, & 9685 detJ, Basis, dBasisdx ) 9686 CALL GetEdgeBasis(Element,WBasis,RotWBasis,Basis,dBasisdx) 9687 END IF 9688 ELSE 9689 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 9690 END IF 9691 9692 ! Integration point at the master element 9693 IF( ElemCodeM /= LinCodeM ) THEN 9694 ElementLin % TYPE => GetElementType( LinCodeM, .FALSE. ) 9695 ElementLin % NodeIndexes => ElementM % NodeIndexes 9696 ElementP => ElementLin 9697 CALL GlobalToLocal( um, vm, wm, xt, yt, zt, ElementP, NodesM ) 9698 ELSE 9699 CALL GlobalToLocal( um, vm, wm, xt, yt, zt, ElementM, NodesM ) 9700 END IF 9701 9702 9703 IF( EdgeBasis ) THEN 9704 IF (PiolaVersion) THEN 9705 ! Take into account that the reference elements are different: 9706 IF ( neM == 3) THEN 9707 uq = um 9708 vq = vm 9709 um = -1.0d0 + 2.0d0*uq + vq 9710 vm = SQRT(3.0d0)*vq 9711 END IF 9712 IF (SecondOrder) THEN 9713 stat = EdgeElementInfo( ElementM, NodesM, um, vm, wm, & 9714 DetF=detJ, Basis=BasisM, EdgeBasis=WBasisM, & 9715 BasisDegree = 2, ApplyPiolaTransform = .TRUE.) 9716 ELSE 9717 stat = ElementInfo( ElementM, NodesM, um, vm, wm, & 9718 detJ, BasisM, dBasisdx, EdgeBasis=WBasisM) 9719 END IF 9720 ELSE 9721 stat = ElementInfo( ElementM, NodesM, um, vm, wm, & 9722 detJ, BasisM, dBasisdx ) 9723 CALL GetEdgeBasis(ElementM,WBasisM,RotWBasis,BasisM,dBasisdx) 9724 END IF 9725 ELSE 9726 stat = ElementInfo( ElementM, NodesM, um, vm, wm, detJ, BasisM ) 9727 END IF 9728 IF(.NOT. Stat) CYCLE 9729 9730 ! Add the nodal dofs 9731 IF( DoNodes .AND. .NOT. StrongNodes ) THEN 9732 IF(BiOrthogonalBasis) THEN 9733 CoeffBasis = 0._dp 9734 DO i=1,n 9735 DO j=1,n 9736 CoeffBasis(i) = CoeffBasis(i) + MASS(i,j) * Basis(j) 9737 END DO 9738 END DO 9739 END IF 9740 9741 DO j=1,n 9742 jj = Indexes(j) 9743 9744 nrow = NodePerm(InvPerm1(jj)) 9745 IF( nrow == 0 ) CYCLE 9746 9747 Projector % InvPerm(nrow) = InvPerm1(jj) 9748 val = Basis(j) * Wtemp 9749 IF(BiorthogonalBasis) val_dual = CoeffBasis(j) * Wtemp 9750 9751 !IF( DebugElem ) PRINT *,'Vals:',val 9752 9753 DO i=1,n 9754 Nslave = Nslave + 1 9755 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 9756 InvPerm1(Indexes(i)), NodeCoeff * Basis(i) * val ) 9757 9758 IF(BiOrthogonalBasis) THEN 9759 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 9760 InvPerm1(Indexes(i)), NodeCoeff * Basis(i) * val_dual ) 9761 END IF 9762 END DO 9763 9764 DO i=1,nM 9765 IF( ABS( val * BasisM(i) ) < 1.0d-10 ) CYCLE 9766 9767 Nmaster = Nmaster + 1 9768 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 9769 InvPerm2(IndexesM(i)), -sgn0 * NodeScale * NodeCoeff * BasisM(i) * val ) 9770 9771 IF(BiOrthogonalBasis) THEN 9772 IF(DualMaster.OR.DualLCoeff) THEN 9773 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 9774 InvPerm2(IndexesM(i)), -sgn0 * NodeScale * NodeCoeff * BasisM(i) * val_dual ) 9775 ELSE 9776 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 9777 InvPerm2(IndexesM(i)), -sgn0 * NodeScale * NodeCoeff * BasisM(i) * val ) 9778 END IF 9779 END IF 9780 END DO 9781 END DO 9782 END IF 9783 9784 IF( DoEdges ) THEN 9785 IF (SecondOrder) THEN 9786 9787 DO j=1,2*ne+nf ! for all slave dofs 9788 IF (j<=2*ne) THEN 9789 edge = 1+(j-1)/2 ! The edge to which the dof is associated 9790 edof = j-2*(edge-1) ! The edge-wise index of the dof 9791 jj = Element % EdgeIndexes(edge) 9792 IF( EdgePerm(jj) == 0 ) CYCLE 9793 nrow = EdgeRow0 + 2*(EdgePerm(jj)-1) + edof ! The row to be written 9794 jj = EdgeCol0 + 2*(jj-1) + edof ! The index of the corresponding DOF 9795 Projector % InvPerm( nrow ) = jj 9796 ELSE 9797 IF( Parallel ) THEN 9798 IF( Element % PartIndex /= ParEnv % MyPe ) CYCLE 9799 END IF 9800 fdof = j-2*ne ! The face-wise index of the dof 9801 nrow = FaceRow0 + nf * ( ind - 1 ) + fdof 9802 jj = FaceCol0 + nf * ( Element % ElementIndex - 1) + fdof 9803 Projector % InvPerm( nrow ) = jj 9804 END IF 9805 9806 DO i=1,2*ne+nf ! for all slave dofs 9807 IF( i <= 2*ne ) THEN 9808 edge = 1+(i-1)/2 ! The edge to which the dof is associated 9809 edof = i-2*(edge-1) ! The edge-wise index of the dof 9810 ii = EdgeCol0 + 2*(Element % EdgeIndexes(edge) - 1) + edof 9811 ELSE 9812 fdof = i-2*ne ! The face-wise index of the dof 9813 ii = FaceCol0 + nf * ( Element % ElementIndex - 1) + fdof 9814 END IF 9815 9816 val = Wtemp * SUM( WBasis(j,:) * Wbasis(i,:) ) 9817 IF( ABS( val ) > 1.0d-12 ) THEN 9818 Nslave = Nslave + 1 9819 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 9820 ii, EdgeCoeff * val ) 9821 END IF 9822 END DO 9823 9824 DO i=1,2*neM+nfM ! for all master dofs 9825 IF( i <= 2*neM ) THEN 9826 edge = 1+(i-1)/2 ! The edge to which the dof is associated 9827 edof = i-2*(edge-1) ! The edge-wise index of the dof 9828 ii = EdgeCol0 + 2*(ElementM % EdgeIndexes(edge) - 1) + edof 9829 ELSE 9830 fdof = i-2*neM ! The face-wise index of the dof 9831 ii = FaceCol0 + nfM * ( ElementM % ElementIndex - 1) + fdof 9832 END IF 9833 9834 val = -Wtemp * sgn0 * SUM( WBasis(j,:) * WBasisM(i,:) ) 9835 IF( ABS( val ) > 1.0d-12 ) THEN 9836 Nmaster = Nmaster + 1 9837 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 9838 ii, EdgeScale * EdgeCoeff * val ) 9839 END IF 9840 END DO 9841 END DO 9842 9843 ELSE 9844 ! Dofs are numbered as follows: 9845 ! 1....number of nodes 9846 ! + ( 1 ... number of edges ) 9847 ! + ( 1 ... 2 x number of faces ) 9848 !------------------------------------------- 9849 DO j=1,ne+nf 9850 9851 IF( j <= ne ) THEN 9852 jj = Element % EdgeIndexes(j) 9853 IF( EdgePerm(jj) == 0 ) CYCLE 9854 nrow = EdgeRow0 + EdgePerm(jj) 9855 jj = jj + EdgeCol0 9856 Projector % InvPerm( nrow ) = jj 9857 ELSE 9858 IF( Parallel ) THEN 9859 IF( Element % PartIndex /= ParEnv % MyPe ) CYCLE 9860 END IF 9861 9862 jj = 2 * ( ind - 1 ) + ( j - ne ) 9863 nrow = FaceRow0 + jj 9864 jj = 2 * ( Element % ElementIndex - 1) + ( j - ne ) 9865 Projector % InvPerm( nrow ) = FaceCol0 + jj 9866 END IF 9867 9868 9869 DO i=1,ne+nf 9870 IF( i <= ne ) THEN 9871 ii = Element % EdgeIndexes(i) + EdgeCol0 9872 ELSE 9873 ii = 2 * ( Element % ElementIndex - 1 ) + ( i - ne ) + FaceCol0 9874 END IF 9875 9876 IF( DebugEdge ) THEN 9877 ci = cFact(i) 9878 sums = sums + ci * EdgeCoeff * val 9879 EdgeProj(1:2) = EdgeProj(1:2) + ci * Wtemp * Wbasis(i,1:2) 9880 END IF 9881 9882 val = Wtemp * SUM( WBasis(j,:) * Wbasis(i,:) ) 9883 IF( ABS( val ) > 1.0d-12 ) THEN 9884 Nslave = Nslave + 1 9885 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 9886 ii, EdgeCoeff * val ) 9887 END IF 9888 END DO 9889 9890 DO i=1,neM+nfM 9891 IF( i <= neM ) THEN 9892 ii = ElementM % EdgeIndexes(i) + EdgeCol0 9893 ELSE 9894 ii = 2 * ( ElementM % ElementIndex - 1 ) + ( i - neM ) + FaceCol0 9895 END IF 9896 9897 IF( DebugEdge ) THEN 9898 ci = cFactM(i) 9899 summ = summ + ci * EdgeScale * EdgeCoeff * val 9900 summabs = summabs + ABS( ci * EdgeScale * EdgeCoeff * val ) 9901 IF( NRange /= NRange1 ) THEN 9902 summ2 = summ2 + ci * EdgeScale * EdgeCoeff * val 9903 END IF 9904 EdgeProjM(1:2) = EdgeProjM(1:2) + ci * Wtemp * sgn0 * WbasisM(i,1:2) 9905 END IF 9906 9907 val = -Wtemp * sgn0 * SUM( WBasis(j,:) * WBasisM(i,:) ) 9908 IF( ABS( val ) > 1.0d-12 ) THEN 9909 Nmaster = Nmaster + 1 9910 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 9911 ii, EdgeScale * EdgeCoeff * val ) 9912 END IF 9913 END DO 9914 END DO 9915 END IF 9916 END IF 9917 END DO 9918 9919300 CONTINUE 9920 9921 END DO 9922 9923100 IF( Repeating ) THEN 9924 IF( NRange /= NRange2 ) THEN 9925 ! Rotate the sector to a new position for axial case 9926 ! Or just some up the angle in the radial/2D case 9927 IF( Naxial > 1 ) THEN 9928 9929 IF( Nrange /= Nrange2 ) THEN 9930 dAlpha = 2.0_dp * PI * (Nrange2 - Nrange ) / Naxial 9931 Nrange = Nrange2 9932 END IF 9933 9934 DO i=1,nM 9935 x0 = NodesM % x(i) 9936 y0 = NodesM % y(i) 9937 NodesM % x(i) = COS(dAlpha) * x0 - SIN(dAlpha) * y0 9938 NodesM % y(i) = SIN(dAlpha) * x0 + COS(dAlpha) * y0 9939 END DO 9940 ELSE 9941 Nrange = Nrange2 9942 NodesM % x(1:n) = NodesM % x(1:n) + ArcRange * (Nrange2 - Nrange1) 9943 END IF 9944 xminm = MINVAL( NodesM % x(1:neM)) 9945 xmaxm = MAXVAL( NodesM % x(1:neM)) 9946 GOTO 200 9947 END IF 9948 END IF 9949 9950 END DO 9951 9952 IF( SaveElem ) THEN 9953 FileName = 't'//TRIM(I2S(TimeStep))//'_n.dat' 9954 OPEN( 10,FILE=Filename) 9955 OPEN( 10,FILE=FileName) 9956 WRITE( 10, * ) ElemHits 9957 CLOSE( 10 ) 9958 END IF 9959 9960 TotCands = TotCands + ElemCands 9961 TotHits = TotHits + ElemHits 9962 TotSumArea = TotSumArea + SumArea 9963 TotRefArea = TotRefArea + RefArea 9964 9965 Err = SumArea / RefArea 9966 IF( Err > MaxErr ) THEN 9967 MaxErr = Err 9968 MaxErrInd = Err 9969 END IF 9970 IF( Err < MinErr ) THEN 9971 MinErr = Err 9972 MinErrInd = ind 9973 END IF 9974 9975 IF( SaveErr ) THEN 9976 WRITE( 11, * ) ind,SUM( Nodes % x(1:ne))/ne, SUM( Nodes % y(1:ne))/ne, Err 9977 END IF 9978 9979 IF( DebugEdge ) THEN 9980 EdgeErr = SUM( ABS( EdgeProj-EdgeProjM) ) / SUM( ABS(EdgeProj)+ABS(EdgeProjM) ) 9981 IF( EdgeErr > 1.0e-3 ) THEN 9982 PRINT *,'EdgeProj:',ind,EdgeErr,EdgeProj,EdgeProjM 9983 END IF 9984 MaxEdgeErr = MAX( MaxEdgeErr, EdgeErr ) 9985 END IF 9986 9987 END DO 9988 9989 IF( SaveErr ) CLOSE(11) 9990 9991 9992 DEALLOCATE( Nodes % x, Nodes % y, Nodes % z, & 9993 NodesM % x, NodesM % y, NodesM % z, & 9994 NodesT % x, NodesT % y, NodesT % z, & 9995 Basis, BasisM, dBasisdx ) 9996 IF( EdgeBasis ) THEN 9997 DEALLOCATE( WBasis, WBasisM, RotWBasis ) 9998 END IF 9999 IF(BiOrthogonalBasis) THEN 10000 DEALLOCATE(CoeffBasis, MASS ) 10001 END IF 10002 10003 CALL Info('AddProjectorWeakGeneric','Number of integration pair candidates: '& 10004 //TRIM(I2S(TotCands)),Level=10) 10005 CALL Info('AddProjectorWeakGeneric','Number of integration pairs: '& 10006 //TRIM(I2S(TotHits)),Level=10) 10007 10008 CALL Info('AddProjectorWeakGeneric','Number of edge intersections: '& 10009 //TRIM(I2S(EdgeHits)),Level=10) 10010 CALL Info('AddProjectorWeakGeneric','Number of corners inside element: '& 10011 //TRIM(I2S(EdgeHits)),Level=10) 10012 10013 CALL Info('AddProjectorWeakGeneric','Number of initial corners: '& 10014 //TRIM(I2S(InitialHits)),Level=10) 10015 CALL Info('AddProjectorWeakGeneric','Number of active corners: '& 10016 //TRIM(I2S(ActiveHits)),Level=10) 10017 10018 CALL Info('AddProjectorWeakGeneric','Number of most subelement corners: '& 10019 //TRIM(I2S(MaxSubTriangles)),Level=10) 10020 CALL Info('AddProjectorWeakGeneric','Element of most subelement corners: '& 10021 //TRIM(I2S(MaxSubElem)),Level=10) 10022 10023 WRITE( Message,'(A,ES12.5)') 'Total reference area:',TotRefArea 10024 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10025 WRITE( Message,'(A,ES12.5)') 'Total integrated area:',TotSumArea 10026 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10027 10028 Err = TotSumArea / TotRefArea 10029 WRITE( Message,'(A,ES15.6)') 'Average ratio in area integration:',Err 10030 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10031 10032 WRITE( Message,'(A,I0,A,ES12.4)') & 10033 'Maximum relative discrepancy in areas (element: ',MaxErrInd,'):',MaxErr-1.0_dp 10034 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10035 WRITE( Message,'(A,I0,A,ES12.4)') & 10036 'Minimum relative discrepancy in areas (element: ',MinErrInd,'):',MinErr-1.0_dp 10037 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10038 10039 CALL Info('AddProjectorWeakGeneric','Number of slave entries: '& 10040 //TRIM(I2S(Nslave)),Level=10) 10041 CALL Info('AddProjectorWeakGeneric','Number of master entries: '& 10042 //TRIM(I2S(Nmaster)),Level=10) 10043 10044 IF( DebugEdge ) THEN 10045 CALL ListAddConstReal( CurrentModel % Simulation,'res: err',err) 10046 10047 WRITE( Message,'(A,ES15.6)') 'Slave entries total sum:', sums 10048 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10049 WRITE( Message,'(A,ES15.6)') 'Master entries total sum:', summ 10050 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10051 WRITE( Message,'(A,ES15.6)') 'Master entries total sum2:', summ2 10052 CALL Info('AddProjectorWeakGeneric',Message,Level=8) 10053 WRITE( Message,'(A,ES15.6)') 'Maximum edge projection error:', MaxEdgeErr 10054 CALL Info('AddProjectorWeakGeneric',Message,Level=6) 10055 10056 CALL ListAddConstReal( CurrentModel % Simulation,'res: sums',sums) 10057 CALL ListAddConstReal( CurrentModel % Simulation,'res: summ',summ) 10058 CALL ListAddConstReal( CurrentModel % Simulation,'res: summ2',summ2) 10059 CALL ListAddConstReal( CurrentModel % Simulation,'res: summabs',summabs) 10060 CALL ListAddConstReal( CurrentModel % Simulation,'res: maxedgerr',MaxEdgeErr) 10061 END IF 10062 10063 END SUBROUTINE AddProjectorWeakGeneric 10064 10065 10066 10067 ! Return shortest distance squared of a point to a line segment. 10068 ! This is limited to the spacial case when the point lies in origin. 10069 FUNCTION SegmentOriginDistance2(x1,y1,x2,y2) RESULT ( r2 ) 10070 REAL(KIND=dp) :: x1,y1,x2,y2,r2 10071 REAL(KIND=dp) :: q,xc,yc 10072 10073 q = ( x1*(x1-x2) + y1*(y1-y2) ) / & 10074 SQRT((x1**2+y1**2) * ((x1-x2)**2+(y1-y2)**2)) 10075 IF( q <= 0.0_dp ) THEN 10076 r2 = x1**2 + y1**2 10077 ELSE IF( q >= 1.0_dp ) THEN 10078 r2 = x2**2 + y2**2 10079 ELSE 10080 xc = x1 + q * (x2-x1) 10081 yc = y1 + q * (y2-y1) 10082 r2 = xc**2 + yc**2 10083 END IF 10084 10085 END FUNCTION SegmentOriginDistance2 10086 10087 10088 !---------------------------------------------------------------------- 10089 ! Create weak projector for the nodes in 1D mesh. 10090 !---------------------------------------------------------------------- 10091 SUBROUTINE AddProjectorWeak1D() 10092 10093 INTEGER, TARGET :: IndexesT(3) 10094 INTEGER, POINTER :: Indexes(:), IndexesM(:) 10095 INTEGER :: jj,ii,sgn0,k,kmax,ind,indM,nip,nn,inds(10),nM,iM,i2,i2M 10096 INTEGER :: ElemHits, TotHits, MaxErrInd, MinErrInd, TimeStep, AntiPeriodicHits 10097 TYPE(Element_t), POINTER :: Element, ElementM 10098 TYPE(Element_t) :: ElementT 10099 TYPE(GaussIntegrationPoints_t) :: IP 10100 TYPE(Nodes_t) :: Nodes, NodesM, NodesT 10101 REAL(KIND=dp) :: xt,yt,zt,xmax,xmin,xmaxm,ymaxm,& 10102 xminm,yminm,DetJ,Wtemp,q,u,v,w,um,vm,wm,val,RefArea,dArea,& 10103 SumArea,MaxErr,MinErr,Err,uvw(3),val_dual,dx,dxcut, & 10104 zmin,zmax, zminm, zmaxm 10105 REAL(KIND=dp) :: TotRefArea, TotSumArea 10106 REAL(KIND=dp), ALLOCATABLE :: Basis(:), BasisM(:) 10107 LOGICAL :: LeftCircle, Stat 10108 TYPE(Mesh_t), POINTER :: Mesh 10109 TYPE(Variable_t), POINTER :: TimestepVar 10110 10111 ! These are used temporarily for debugging purposes 10112 INTEGER :: SaveInd 10113 LOGICAL :: SaveElem 10114 CHARACTER(LEN=20) :: FileName 10115 10116 REAL(KIND=dp), ALLOCATABLE :: CoeffBasis(:), MASS(:,:) 10117 10118 CALL Info('AddProjectorWeak1D','Creating weak constraints using a 1D integrator',Level=8) 10119 10120 Mesh => CurrentModel % Solver % Mesh 10121 10122 SaveInd = ListGetInteger( BC,'Level Projector Save Element Index',Found ) 10123 TimestepVar => VariableGet( Mesh % Variables,'Timestep',ThisOnly=.TRUE. ) 10124 Timestep = NINT( TimestepVar % Values(1) ) 10125 10126 n = Mesh % MaxElementNodes 10127 ALLOCATE( Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 10128 ALLOCATE( NodesM % x(n), NodesM % y(n), NodesM % z(n) ) 10129 ALLOCATE( NodesT % x(n), NodesT % y(n), NodesT % z(n) ) 10130 ALLOCATE( Basis(n), BasisM(n) ) 10131 10132 IF (BiOrthogonalBasis) ALLOCATE(CoeffBasis(n), MASS(n,n)) 10133 10134 Nodes % y = 0.0_dp 10135 NodesM % y = 0.0_dp 10136 NodesT % y = 0.0_dp 10137 Nodes % z = 0.0_dp 10138 NodesM % z = 0.0_dp 10139 NodesT % z = 0.0_dp 10140 yt = 0.0_dp 10141 zt = 0.0_dp 10142 10143 MaxErr = 0.0_dp 10144 MinErr = HUGE( MinErr ) 10145 MaxErrInd = 0 10146 MinErrInd = 0 10147 zt = 0.0_dp 10148 LeftCircle = .FALSE. 10149 10150 ! The temporal element segment used in the numerical integration 10151 ElementT % TYPE => GetElementType( 202, .FALSE. ) 10152 ElementT % NodeIndexes => IndexesT 10153 IP = GaussPoints( ElementT, ElementT % TYPE % GaussPoints2 ) 10154 10155 TotHits = 0 10156 AntiPeriodicHits = 0 10157 TotRefArea = 0.0_dp 10158 TotSumArea = 0.0_dp 10159 10160 10161 DO ind=1,BMesh1 % NumberOfBulkElements 10162 10163 ! Optionally save the submesh for specified element, for vizualization and debugging 10164 SaveElem = ( SaveInd == ind ) 10165 10166 Element => BMesh1 % Elements(ind) 10167 Indexes => Element % NodeIndexes 10168 10169 n = Element % TYPE % NumberOfNodes 10170 Nodes % x(1:n) = BMesh1 % Nodes % x(Indexes(1:n)) 10171 10172 ! There is a discontinuity of angle at 180 degs 10173 ! If we are working on left-hand-side then add 360 degs to the negative angles 10174 ! to remove this discontinuity. 10175 IF( FullCircle ) THEN 10176 LeftCircle = ( ALL( ABS( Nodes % x(1:n) ) > 90.0_dp ) ) 10177 IF( LeftCircle ) THEN 10178 DO j=1,n 10179 IF( Nodes % x(j) < 0.0 ) Nodes % x(j) = & 10180 Nodes % x(j) + 360.0_dp 10181 END DO 10182 END IF 10183 END IF 10184 10185 xmin = MINVAL(Nodes % x(1:n)) 10186 xmax = MAXVAL(Nodes % x(1:n)) 10187 dx = xmax - xmin 10188 10189 ! The flattened dimension is always the z-component 10190 IF( HaveMaxDistance ) THEN 10191 zmin = MINVAL( BMesh1 % Nodes % z(Indexes(1:n)) ) 10192 zmax = MAXVAL( BMesh1 % Nodes % z(Indexes(1:n)) ) 10193 END IF 10194 10195 ! Compute the reference area 10196 u = 0.0_dp; v = 0.0_dp; w = 0.0_dp; 10197 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 10198 RefArea = detJ * ArcCoeff * SUM( IP % s(1:IP % n) ) 10199 SumArea = 0.0_dp 10200 10201 IF( SaveElem ) THEN 10202 FileName = 't'//TRIM(I2S(TimeStep))//'_a.dat' 10203 OPEN( 10,FILE=Filename) 10204 DO i=1,n 10205 WRITE( 10, * ) Nodes % x(i) 10206 END DO 10207 CLOSE( 10 ) 10208 END IF 10209 10210 ! Set the values to maintain the size of the matrix 10211 ! The size of the matrix is used when allocating for utility vectors of contact algo. 10212 ! This does not set the Projector % InvPerm to nonzero value that is used to 10213 ! determine whether there really is a projector. 10214 DO i=1,n 10215 j = InvPerm1(Indexes(i)) 10216 nrow = NodePerm(j) 10217 IF( nrow == 0 ) CYCLE 10218 CALL List_AddMatrixIndex(Projector % ListMatrix, nrow, j ) 10219 END DO 10220 10221 ! Currently a n^2 loop but it could be improved 10222 !-------------------------------------------------------------------- 10223 ElemHits = 0 10224 DO indM=1,BMesh2 % NumberOfBulkElements 10225 10226 ElementM => BMesh2 % Elements(indM) 10227 IndexesM => ElementM % NodeIndexes 10228 10229 nM = ElementM % TYPE % NumberOfNodes 10230 10231 10232 NodesM % x(1:nM) = BMesh2 % Nodes % x(IndexesM(1:nM)) 10233 10234 ! Treat the left circle differently. 10235 IF( LeftCircle ) THEN 10236 ! Omit the element if it is definitely on the right circle 10237 IF( ALL( ABS( NodesM % x(1:nM) ) - 90.0_dp < XTol ) ) CYCLE 10238 DO j=1,nM 10239 IF( NodesM % x(j) < 0.0_dp ) NodesM % x(j) = & 10240 NodesM % x(j) + 360.0_dp 10241 END DO 10242 END IF 10243 10244 xminm = MINVAL( NodesM % x(1:nM)) 10245 xmaxm = MAXVAL( NodesM % x(1:nM)) 10246 10247 IF( Repeating ) THEN 10248 ! Enforce xmaxm to be on the same interval than xmin 10249 Nrange = FLOOR( (xmaxm-xmin+XTol) / XRange ) 10250 IF( Nrange /= 0 ) THEN 10251 xminm = xminm - Nrange * XRange 10252 xmaxm = xmaxm - Nrange * XRange 10253 NodesM % x(1:nM) = NodesM % x(1:nM) - NRange * XRange 10254 END IF 10255 10256 ! Check whether there could be a intersection in an other interval as well 10257 IF( xminm + XRange < xmax + XTol ) THEN 10258 Nrange2 = 1 10259 ELSE 10260 Nrange2 = 0 10261 END IF 10262 END IF 10263 10264 IF( FullCircle .AND. .NOT. LeftCircle ) THEN 10265 IF( xmaxm - xminm > 180.0_dp ) CYCLE 10266 END IF 10267 10268200 IF( xminm >= xmax ) GOTO 100 10269 IF( xmaxm <= xmin ) GOTO 100 10270 10271 10272 ! This is a cheap test so perform that first, if requested 10273 IF( HaveMaxDistance ) THEN 10274 zminm = MINVAL( BMesh2 % Nodes % z(IndexesM(1:nM)) ) 10275 zmaxm = MAXVAL( BMesh2 % Nodes % z(IndexesM(1:nM)) ) 10276 IF( zmaxm < zmin - MaxDistance ) GOTO 100 10277 IF( zminm > zmax + MaxDistance ) GOTO 100 10278 END IF 10279 10280 10281 NodesT % x(1) = MAX( xmin, xminm ) 10282 NodesT % x(2) = MIN( xmax, xmaxm ) 10283 dxcut = ABS( NodesT % x(1)-NodesT % x(2) ) 10284 10285 ! Too small absolute values may result to problems when inverting matrix 10286 IF( dxcut < 1.0d-12 ) GOTO 100 10287 10288 ! Too small relative value is irrelevant 10289 IF( dxcut < 1.0d-8 * dx ) GOTO 100 10290 10291 sgn0 = 1 10292 IF( AntiRepeating ) THEN 10293 IF ( MODULO(Nrange,2) /= 0 ) THEN 10294 sgn0 = -1 10295 AntiPeriodicHits = AntiPeriodicHits + 1 10296 END IF 10297 END IF 10298 10299 ElemHits = ElemHits + 1 10300 10301 IF( SaveElem ) THEN 10302 FileName = 't'//TRIM(I2S(TimeStep))//'_b'//TRIM(I2S(ElemHits))//'.dat' 10303 OPEN( 10,FILE=FileName) 10304 DO i=1,nM 10305 WRITE( 10, * ) NodesM % x(i) 10306 END DO 10307 CLOSE( 10 ) 10308 10309 FileName = 't'//TRIM(I2S(TimeStep))//'_e'//TRIM(I2S(ElemHits))//'.dat' 10310 OPEN( 10,FILE=FileName) 10311 DO i=1,2 10312 WRITE( 10, * ) NodesT % x(i) 10313 END DO 10314 CLOSE( 10 ) 10315 END IF 10316 10317 ! Use somewhat higher integration rules than the default 10318 IP = GaussPoints( ElementT, ElementT % TYPE % GaussPoints2 ) 10319 10320 IF(BiOrthogonalBasis) THEN 10321 MASS = 0 10322 CoeffBasis = 0 10323 DO nip=1, IP % n 10324 stat = ElementInfo( ElementT,NodesT,IP % u(nip),& 10325 IP % v(nip),IP % w(nip),detJ,Basis) 10326 10327 ! Global coordinate of the integration point 10328 xt = SUM( Basis(1:2) * NodesT % x(1:2) ) 10329 10330 ! Integration weight for current integration point 10331 Wtemp = DetJ * ArcCoeff * IP % s(nip) 10332 10333 ! Integration point at the slave element 10334 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 10335 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 10336 10337 DO i=1,n 10338 DO j=1,n 10339 MASS(i,j) = MASS(i,j) + wTemp * Basis(i) * Basis(j) 10340 END DO 10341 CoeffBasis(i) = CoeffBasis(i) + wTemp * Basis(i) 10342 END DO 10343 END DO 10344 10345 CALL InvertMatrix( MASS, n ) 10346 10347 DO i=1,n 10348 DO j=1,n 10349 MASS(i,j) = MASS(i,j) * CoeffBasis(i) 10350 END DO 10351 END DO 10352 END IF 10353 10354 10355 DO nip=1, IP % n 10356 stat = ElementInfo( ElementT,NodesT,IP % u(nip),& 10357 IP % v(nip),IP % w(nip),detJ,Basis) 10358 10359 ! We will actually only use the global coordinates and the integration weight 10360 ! from the temporal mesh. 10361 10362 ! Global coordinate of the integration point 10363 xt = SUM( Basis(1:2) * NodesT % x(1:2) ) 10364 10365 ! Integration weight for current integration point 10366 ! Use the real arc length so that this projector weights correctly 10367 ! in rotational case when used with other projectors. 10368 Wtemp = ArcCoeff * DetJ * IP % s(nip) 10369 sumarea = sumarea + Wtemp 10370 10371 ! Integration point at the slave element 10372 CALL GlobalToLocal( u, v, w, xt, yt, zt, Element, Nodes ) 10373 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 10374 10375 ! Integration point at the master element 10376 CALL GlobalToLocal( um, vm, wm, xt, yt, zt, ElementM, NodesM ) 10377 stat = ElementInfo( ElementM, NodesM, um, vm, wm, detJ, BasisM ) 10378 10379 IF(BiOrthogonalBasis) THEN 10380 CoeffBasis = 0._dp 10381 DO i=1,n 10382 DO j=1,n 10383 CoeffBasis(i) = CoeffBasis(i) + MASS(i,j) * Basis(j) 10384 END DO 10385 END DO 10386 END IF 10387 10388 ! Add the entries to the projector 10389 DO j=1,n 10390 jj = Indexes(j) 10391 nrow = NodePerm(InvPerm1(jj)) 10392 IF( nrow == 0 ) CYCLE 10393 10394 Projector % InvPerm(nrow) = InvPerm1(jj) 10395 val = Basis(j) * Wtemp 10396 IF(BiorthogonalBasis) THEN 10397 val_dual = CoeffBasis(j) * Wtemp 10398 END IF 10399 10400 DO i=1,n 10401 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 10402 InvPerm1(Indexes(i)), NodeCoeff * Basis(i) * val ) 10403 10404 IF(BiorthogonalBasis ) THEN 10405 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 10406 InvPerm1(Indexes(i)), NodeCoeff * Basis(i) * val_dual ) 10407 END IF 10408 END DO 10409 10410 DO i=1,nM 10411 CALL List_AddToMatrixElement(Projector % ListMatrix, nrow, & 10412 InvPerm2(IndexesM(i)), -sgn0 * NodeScale * NodeCoeff * BasisM(i) * val ) 10413 10414 IF(BiorthogonalBasis) THEN 10415 IF(DualMaster .OR. DualLCoeff) THEN 10416 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 10417 InvPerm2(IndexesM(i)), -sgn0 * NodeScale * NodeCoeff * BasisM(i) * val_dual ) 10418 ELSE 10419 CALL List_AddToMatrixElement(Projector % Child % ListMatrix, nrow, & 10420 InvPerm2(IndexesM(i)), -sgn0 * NodeScale * NodeCoeff * BasisM(i) * val ) 10421 END IF 10422 END IF 10423 END DO 10424 END DO 10425 10426 ! Add the entries to the dual projector 10427 IF( CreateDual ) THEN 10428 DO j=1,nM 10429 jj = IndexesM(j) 10430 nrow = DualNodePerm(InvPerm2(jj)) 10431 IF( nrow == 0 ) CYCLE 10432 10433 DualProjector % InvPerm(nrow) = InvPerm2(jj) 10434 val = BasisM(j) * Wtemp 10435 10436 DO i=1,nM 10437 CALL List_AddToMatrixElement(DualProjector % ListMatrix, nrow, & 10438 InvPerm2(IndexesM(i)), sgn0 * NodeCoeff * BasisM(i) * val ) 10439 END DO 10440 10441 DO i=1,n 10442 !IF( ABS( val * BasisM(i) ) < 1.0d-10 ) CYCLE 10443 CALL List_AddToMatrixElement(DualProjector % ListMatrix, nrow, & 10444 InvPerm1(Indexes(i)), -NodeScale * NodeCoeff * Basis(i) * val ) 10445 END DO 10446 END DO 10447 END IF 10448 END DO 10449 10450100 IF( Repeating ) THEN 10451 IF( NRange2 /= 0 ) THEN 10452 xminm = xminm + Nrange2 * XRange 10453 xmaxm = xmaxm + Nrange2 * XRange 10454 NodesM % x(1:n) = NodesM % x(1:n) + NRange2 * XRange 10455 NRange = NRange + NRange2 10456 NRange2 = 0 10457 GOTO 200 10458 END IF 10459 END IF 10460 10461 END DO 10462 10463 IF( SaveElem ) THEN 10464 FileName = 't'//TRIM(I2S(TimeStep))//'_n.dat' 10465 OPEN( 10,FILE=Filename) 10466 WRITE( 10, * ) ElemHits 10467 CLOSE( 10 ) 10468 END IF 10469 10470 TotHits = TotHits + ElemHits 10471 TotSumArea = TotSumArea + SumArea 10472 TotRefArea = TotRefArea + RefArea 10473 10474 Err = SumArea / RefArea 10475 IF( Err > MaxErr ) THEN 10476 MaxErr = Err 10477 MaxErrInd = Err 10478 END IF 10479 IF( Err < MinErr ) THEN 10480 MinErr = Err 10481 MinErrInd = ind 10482 END IF 10483 END DO 10484 10485 DEALLOCATE( Nodes % x, Nodes % y, Nodes % z ) 10486 DEALLOCATE( NodesM % x, NodesM % y, NodesM % z ) 10487 DEALLOCATE( NodesT % x, NodesT % y, NodesT % z ) 10488 DEALLOCATE( Basis, BasisM ) 10489 10490 CALL Info('AddProjectorWeak1D','Number of integration pairs: '& 10491 //TRIM(I2S(TotHits)),Level=10) 10492 IF( AntiPeriodicHits > 0 ) THEN 10493 CALL Info('AddProjectorWeak1D','Number of antiperiodic pairs: '& 10494 //TRIM(I2S(AntiPeriodicHits)),Level=10) 10495 END IF 10496 10497 WRITE( Message,'(A,ES12.5)') 'Total reference length:',TotRefArea / ArcCoeff 10498 CALL Info('AddProjectorWeak1D',Message,Level=8) 10499 WRITE( Message,'(A,ES12.5)') 'Total integrated length:',TotSumArea / ArcCoeff 10500 CALL Info('AddProjectorWeak1D',Message,Level=8) 10501 10502 Err = TotSumArea / TotRefArea 10503 WRITE( Message,'(A,ES12.3)') 'Average ratio in length integration:',Err 10504 CALL Info('AddProjectorWeak1D',Message,Level=8) 10505 10506 WRITE( Message,'(A,I0,A,ES12.4)') & 10507 'Maximum relative discrepancy in length (element: ',MaxErrInd,'):',MaxErr-1.0_dp 10508 CALL Info('AddProjectorWeak1D',Message,Level=8) 10509 WRITE( Message,'(A,I0,A,ES12.4)') & 10510 'Minimum relative discrepancy in length (element: ',MinErrInd,'):',MinErr-1.0_dp 10511 CALL Info('AddProjectorWeak1D',Message,Level=8) 10512 10513 10514 END SUBROUTINE AddProjectorWeak1D 10515 10516 END FUNCTION LevelProjector 10517 !------------------------------------------------------------------------------ 10518 10519 10520!--------------------------------------------------------------------------- 10521!> Create a Galerkin projector related to discontinuous interface. 10522!> This uses the information stored when the discontinuous interface 10523!> was first coined. This enables simple one-to-one mapping. Integration 10524!> weight is used for the nodel projector to allow physical jump conditions. 10525!> For the edge dofs there is no such jumps and hence the projector uses 10526!> weights of one. 10527!--------------------------------------------------------------------------- 10528 FUNCTION WeightedProjectorDiscont(Mesh, bc ) RESULT ( Projector ) 10529 !--------------------------------------------------------------------------- 10530 USE Lists 10531 USE ListMatrix 10532 10533 TYPE(Mesh_t), POINTER :: Mesh 10534 INTEGER :: bc 10535 TYPE(Matrix_t), POINTER :: Projector 10536 !-------------------------------------------------------------------------- 10537 INTEGER, POINTER :: NodePerm(:) 10538 TYPE(Model_t), POINTER :: Model 10539 TYPE(GaussIntegrationPoints_t), TARGET :: IntegStuff 10540 INTEGER :: p,q,i,j,it,nn,n,m,t,NoOrigNodes, NoDiscontNodes, indp, indq, & 10541 e1, e2, e12, i1, i2, j1, j2, ParentMissing, ParentFound, PosSides, ActSides, & 10542 InvPermSize, indpoffset 10543 INTEGER, POINTER :: Rows(:),Cols(:), InvPerm(:) 10544 REAL(KIND=dp), POINTER :: Values(:), Basis(:), WBasis(:,:), & 10545 Wbasis2(:,:),RotWBasis(:,:),dBasisdx(:,:) 10546 REAL(KIND=dp) :: u,v,w,val,detJ,Scale,x,weight,Coeff 10547 INTEGER, ALLOCATABLE :: Indexes(:), DiscontIndexes(:) 10548 TYPE(Nodes_t) :: ElementNodes 10549 TYPE(Element_t), POINTER :: Element, Left, Right, OldFace, NewFace, Swap 10550 LOGICAL :: Stat,DisCont,Found,NodalJump,AxisSym, SetDiag, & 10551 SetDiagEdges, DoNodes, DoEdges, LocalConstraints, NoHalo 10552 LOGICAL, ALLOCATABLE :: EdgeDone(:) 10553 REAL(KIND=dp) :: point(3), uvw(3), DiagEps 10554 INTEGER, ALLOCATABLE :: EQind(:) 10555 INTEGER, POINTER :: OldMap(:,:), NewMap(:,:) 10556 TYPE(ValueList_t), POINTER :: BCParams 10557 LOGICAL :: CheckHaloNodes 10558 LOGICAL, POINTER :: HaloNode(:) 10559 10560 CALL Info('WeightedProjectorDiscont','Creating projector for discontinuous boundary '& 10561 //TRIM(I2S(bc)),Level=7) 10562 10563 Projector => NULL() 10564 IF( .NOT. Mesh % DisContMesh ) THEN 10565 CALL Warn('WeightedProjectorDiscont','Discontinuous mesh not created?') 10566 RETURN 10567 END IF 10568 10569 Model => CurrentModel 10570 10571 j = 0 10572 DO i=1,Model % NumberOfBCs 10573 IF( ListGetLogical(Model % BCs(i) % Values,'Discontinuous Boundary',Found) ) THEN 10574 j = j + 1 10575 END IF 10576 END DO 10577 IF( j > 1 ) THEN 10578 CALL Warn('WeightedProjectorDiscont','One BC (not '& 10579 //TRIM(I2S(j))//') only for discontinuous boundary!') 10580 END IF 10581 10582 BCParams => Model % BCs(bc) % Values 10583 10584 Scale = ListGetCReal( BCParams,'Mortar BC Scaling',Stat ) 10585 IF(.NOT. Stat) Scale = -1.0_dp 10586 10587 NodalJump = ListCheckPrefix( BCParams,'Mortar BC Coefficient') 10588 IF(.NOT. NodalJump ) THEN 10589 NodalJump = ListCheckPrefix( BCParams,'Mortar BC Resistivity') 10590 END IF 10591 10592 ! Take the full weight when creating the constraints since the values will 10593 ! not be communicated 10594 LocalConstraints = ListGetLogical(Model % Solver % Values, & 10595 'Partition Local Projector',Found) 10596 IF(.NOT. Found ) LocalConstraints = ListGetLogical(Model % Solver % Values, & 10597 'Partition Local Constraints',Found) 10598 10599 ! Don't consider halo when creating discontinuity 10600 NoHalo = ListGetLogical(Model % Solver % Values, & 10601 'Projector No Halo',Found) 10602 10603 ! Don't consider single halo nodes when creating discontinuity 10604 CheckHaloNodes = ListGetLogical( Model % Solver % Values,& 10605 'Projector No Halo Nodes',Found ) 10606 IF( CheckHaloNodes ) THEN 10607 CALL MarkHaloNodes( Mesh, HaloNode, CheckHaloNodes ) 10608 END IF 10609 10610 10611 IF( ListGetLogical( Model % Solver % Values,'Projector Skip Edges',Found ) ) THEN 10612 DoEdges = .FALSE. 10613 ELSE IF( ListGetLogical( BCParams,'Projector Skip Edges',Found ) ) THEN 10614 DoEdges = .FALSE. 10615 ELSE 10616 DoEdges = ( Mesh % NumberOfEdges > 0 ) 10617 END IF 10618 IF( DoEdges .AND. Mesh % NumberOfEdges == 0 ) THEN 10619 CALL Warn('WeightedProjectorDiscont','Edge basis requested but mesh has no edges!') 10620 DoEdges = .FALSE. 10621 END IF 10622 10623 IF( ListGetLogical( Model % Solver % Values,'Projector Skip Nodes',Found ) ) THEN 10624 DoNodes = .FALSE. 10625 ELSE IF( ListGetLogical( BCParams,'Projector Skip Nodes',Found ) ) THEN 10626 DoNodes = .FALSE. 10627 ELSE 10628 DoNodes = ( Mesh % NumberOfNodes > 0 ) 10629 END IF 10630 10631 ! Should the projector be diagonal or mass matrix type 10632 SetDiag = ListGetLogical( BCParams,'Mortar BC Diag',Found ) 10633 10634 IF(.NOT. Found ) SetDiag = ListGetLogical( BCParams, 'Use Biorthogonal Basis', Found) 10635 10636 ! If we want to eliminate the constraints we have to have a biortgonal basis 10637 IF(.NOT. Found ) THEN 10638 SetDiag = ListGetLogical( CurrentModel % Solver % Values, & 10639 'Eliminate Linear Constraints',Found ) 10640 IF( SetDiag ) THEN 10641 CALL Info('WeightedProjectorDiscont',& 10642 'Setting > Use Biorthogonal Basis < to True to enable elimination',Level=8) 10643 END IF 10644 END IF 10645 10646 10647 SetDiagEdges = ListGetLogical( BCParams,'Mortar BC Diag Edges',Found ) 10648 IF(.NOT. Found ) SetDiagEdges = SetDiag 10649 DiagEps = ListGetConstReal( BCParams,'Mortar BC Diag Eps',Found ) 10650 10651 ! Integration weights should follow the metrics if we want physical nodal jumps. 10652 AxisSym = .FALSE. 10653 IF ( CurrentCoordinateSystem() == AxisSymmetric .OR. & 10654 CurrentCoordinateSystem() == CylindricSymmetric ) THEN 10655 IF( NodalJump ) THEN 10656 AxisSym = .TRUE. 10657 ELSE IF (ASSOCIATED(CurrentModel % Solver)) THEN 10658 AxisSym = ListGetLogical(CurrentModel % Solver % Values,'Projector Metrics',Found) 10659 END IF 10660 IF( AxisSym ) CALL Info('weightedProjectorDiscont','Projector will be weighted for axi symmetry',Level=7) 10661 END IF 10662 10663 10664 n = Mesh % MaxElementDOFs 10665 ALLOCATE( ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n) ) 10666 ALLOCATE( Indexes(n), DisContIndexes(n), Basis(n), Wbasis(n,3), & 10667 Wbasis2(n,3), dBasisdx(n,3), RotWBasis(n,3) ) 10668 Indexes = 0 10669 Basis = 0.0_dp 10670 DiscontIndexes = 0 10671 10672 NodePerm => Mesh % DisContPerm 10673 NoOrigNodes = SIZE( NodePerm ) 10674 NoDiscontNodes = COUNT( NodePerm > 0 ) 10675 10676 IF( DoNodes ) THEN 10677 indpoffset = NoDiscontNodes 10678 ELSE 10679 indpoffset = 0 10680 END IF 10681 InvPerm => NULL() 10682 InvPermSize = indpoffset 10683 10684 ! Compute the number of potential edges. This mimics the loop that really creates the projector 10685 ! below. 10686 IF( DoEdges ) THEN 10687 ALLOCATE( EdgeDone( Mesh % NumberOfEdges ) ) 10688 EdgeDone = .FALSE. 10689 indp = indpoffset 10690 10691 DO t = 1, Mesh % NumberOfBoundaryElements 10692 10693 Element => Mesh % Elements(Mesh % NumberOfBulkElements + t ) 10694 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 10695 10696 Left => Element % BoundaryInfo % Left 10697 Right => Element % BoundaryInfo % Right 10698 10699 IF(.NOT. ASSOCIATED( Left ) .OR. .NOT. ASSOCIATED( Right ) ) THEN 10700 CYCLE 10701 END IF 10702 10703 ActSides = 0 10704 IF( ASSOCIATED( Left ) ) THEN 10705 IF( Left % PartIndex == ParEnv % myPE ) ActSides = ActSides + 1 10706 END IF 10707 IF( ASSOCIATED( Right ) ) THEN 10708 IF( Right % PartIndex == ParEnv % myPe ) ActSides = ActSides + 1 10709 END IF 10710 IF( NoHalo .AND. ActSides == 0 ) CYCLE 10711 10712 ! Consistently choose the face with the old edges 10713 IF( ALL( Left % NodeIndexes <= NoOrigNodes ) ) THEN 10714 OldFace => Left 10715 ELSE IF( ALL( Right % NodeIndexes <= NoOrigNodes ) ) THEN 10716 OldFace => Right 10717 ELSE 10718 CALL Warn('WeightedProjectorDiscont','Neither face is purely old!') 10719 CYCLE 10720 END IF 10721 10722 OldMap => GetEdgeMap( OldFace % TYPE % ElementCode / 100) 10723 10724 DO i = 1,OldFace % TYPE % NumberOfEdges 10725 e1 = OldFace % EdgeIndexes(i) 10726 IF( EdgeDone(e1) ) CYCLE 10727 10728 i1 = OldFace % NodeIndexes( OldMap(i,1) ) 10729 i2 = OldFace % NodeIndexes( OldMap(i,2) ) 10730 10731 ! i1 and i2 were already checked to be "old" nodes 10732 IF( NodePerm(i1) == 0 ) CYCLE 10733 IF( NodePerm(i2) == 0 ) CYCLE 10734 10735 indp = indp + 1 10736 EdgeDone(e1) = .TRUE. 10737 END DO 10738 END DO 10739 InvPermSize = indp 10740 CALL Info('WeightedProjectorDiscont',& 10741 'Size of InvPerm estimated to be: '//TRIM(I2S(InvPermSize)),Level=8) 10742 END IF 10743 10744 ! Ok, nothing to do just go end tidy things up 10745 IF( InvPermSize == 0 ) GOTO 100 10746 10747 ! Create a list matrix that allows for unspecified entries in the matrix 10748 ! structure to be introduced. 10749 Projector => AllocateMatrix() 10750 Projector % FORMAT = MATRIX_LIST 10751 Projector % ProjectorType = PROJECTOR_TYPE_GALERKIN 10752 Projector % ProjectorBC = bc 10753 10754 ! Create the inverse permutation needed when the projector matrix is added to the global 10755 ! matrix. 10756 ALLOCATE( Projector % InvPerm( InvPermSize ) ) 10757 InvPerm => Projector % InvPerm 10758 InvPerm = 0 10759 10760 10761 ! Projector for the nodal dofs. 10762 !------------------------------------------------------------------------ 10763 IF( DoNodes ) THEN 10764 10765 ParentMissing = 0 10766 ParentFound = 0 10767 DO t = 1, Mesh % NumberOfBoundaryElements 10768 10769 Element => Mesh % Elements(Mesh % NumberOfBulkElements + t ) 10770 n = Element % TYPE % NumberOfNodes 10771 Indexes(1:n) = Element % NodeIndexes(1:n) 10772 10773 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 10774 10775 Left => Element % BoundaryInfo % Left 10776 Right => Element % BoundaryInfo % Right 10777 10778 ! Here we really need both sides to be able to continue! 10779 !IF(.NOT. ASSOCIATED( Left ) .OR. .NOT. ASSOCIATED( Right ) ) THEN 10780 ! ParentMissing = ParentMissing + 1 10781 ! CYCLE 10782 !END IF 10783 10784 PosSides = 0 10785 ActSides = 0 10786 IF( ASSOCIATED( Left ) ) THEN 10787 PosSides = PosSides + 1 10788 IF( Left % PartIndex == ParEnv % myPE ) ActSides = ActSides + 1 10789 END IF 10790 IF( ASSOCIATED( Right ) ) THEN 10791 PosSides = PosSides + 1 10792 IF( Right % PartIndex == ParEnv % myPe ) ActSides = ActSides + 1 10793 END IF 10794 IF( NoHalo .AND. ActSides == 0 ) CYCLE 10795 10796 IF( LocalConstraints ) THEN 10797 Coeff = 1.0_dp 10798 ELSE 10799 Coeff = 1.0_dp * ActSides / PosSides 10800 END IF 10801 IF( ABS( Coeff ) < TINY( 1.0_dp ) ) CYCLE 10802 10803 ParentFound = ParentFound + 1 10804 10805 ElementNodes % x(1:n) = Mesh % Nodes % x(Indexes(1:n)) 10806 ElementNodes % y(1:n) = Mesh % Nodes % y(Indexes(1:n)) 10807 ElementNodes % z(1:n) = Mesh % Nodes % z(Indexes(1:n)) 10808 10809 IF( ALL( NodePerm(Indexes(1:n)) == 0 ) ) CYCLE 10810 10811 IF( CheckHaloNodes ) THEN 10812 IF( ALL( HaloNode(Indexes(1:n)) ) ) CYCLE 10813 END IF 10814 10815 ! Get the indexes on the other side of the discontinuous boundary 10816 DO i=1,n 10817 j = NodePerm( Indexes(i) ) 10818 IF( j == 0 ) THEN 10819 DiscontIndexes(i) = Indexes(i) 10820 ELSE 10821 DiscontIndexes(i) = j + NoOrigNodes 10822 END IF 10823 END DO 10824 10825 IntegStuff = GaussPoints( Element ) 10826 DO j=1,IntegStuff % n 10827 u = IntegStuff % u(j) 10828 v = IntegStuff % v(j) 10829 w = IntegStuff % w(j) 10830 10831 Stat = ElementInfo(Element, ElementNodes, u, v, w, detJ, Basis) 10832 10833 weight = Coeff * detJ * IntegStuff % s(j) 10834 IF( AxisSym ) THEN 10835 x = SUM( Basis(1:n) * ElementNodes % x(1:n) ) 10836 weight = weight * x 10837 END IF 10838 10839 DO p=1,n 10840 indp = NodePerm( Indexes(p) ) 10841 IF( indp == 0 ) CYCLE 10842 IF( CheckHaloNodes ) THEN 10843 IF( HaloNode( Indexes(p) ) ) CYCLE 10844 END IF 10845 10846 val = weight * Basis(p) 10847 10848 ! Only set for the nodes are are really used 10849 InvPerm(indp) = Indexes(p) 10850 10851 IF( SetDiag ) THEN 10852 CALL List_AddToMatrixElement(Projector % ListMatrix, indp, & 10853 Indexes(p), val ) 10854 10855 CALL List_AddToMatrixElement(Projector % ListMatrix, indp, & 10856 DiscontIndexes(p), Scale * val ) 10857 ELSE 10858 DO q=1,n 10859 10860 indq = NodePerm(Indexes(q)) 10861 IF( indq == 0 ) CYCLE 10862 10863 IF( CheckHaloNodes ) THEN 10864 IF( HaloNode( Indexes(p) ) ) CYCLE 10865 END IF 10866 10867 CALL List_AddToMatrixElement(Projector % ListMatrix, indp, & 10868 Indexes(q), Basis(q) * val ) 10869 CALL List_AddToMatrixElement(Projector % ListMatrix, indp, & 10870 DiscontIndexes(q), Scale * Basis(q) * val ) 10871 END DO 10872 END IF 10873 END DO 10874 END DO 10875 END DO 10876 IF( ParentMissing > 0 ) THEN 10877 CALL Warn('WeightedProjectorDiscont','Number of half-sided discontinuous BC elements in partition '& 10878 //TRIM(I2S(ParEnv % myPE))//': '//TRIM(I2S(ParentMissing)) ) 10879 CALL Warn('WeightedProjectorDiscont','Number of proper discontinuous BC elements in partition '& 10880 //TRIM(I2S(ParEnv % myPE))//': '//TRIM(I2S(ParentFound)) ) 10881 END IF 10882 CALL Info('WeightedProjectorDiscont','Created projector for '& 10883 //TRIM(I2S(NoDiscontNodes))//' discontinuous nodes',Level=10) 10884 END IF 10885 10886 10887 ! Create the projector also for edge dofs if they exist and are 10888 ! requested. 10889 !---------------------------------------------------------------- 10890 IF( DoEdges ) THEN 10891 ParentMissing = 0 10892 ParentFound = 0 10893 n = Mesh % NumberOfNodes 10894 10895 val = 1.0_dp 10896 Scale = 1.0_dp 10897 10898 indp = indpoffset 10899 ALLOCATE( Eqind(Mesh % NumberOfEdges) ); EQind = 0 10900 10901 DO t = 1, Mesh % NumberOfBoundaryElements 10902 10903 Element => Mesh % Elements(Mesh % NumberOfBulkElements + t ) 10904 10905 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 10906 10907 Left => Element % BoundaryInfo % Left 10908 Right => Element % BoundaryInfo % Right 10909 10910 ! Here we really need both sides to be able to continue! 10911 IF(.NOT. ASSOCIATED( Left ) .OR. .NOT. ASSOCIATED( Right ) ) THEN 10912 ParentMissing = ParentMissing + 1 10913 CYCLE 10914 END IF 10915 10916 PosSides = 0 10917 ActSides = 0 10918 IF( ASSOCIATED( Left ) ) THEN 10919 PosSides = PosSides + 1 10920 IF( Left % PartIndex == ParEnv % myPE ) ActSides = ActSides + 1 10921 END IF 10922 IF( ASSOCIATED( Right ) ) THEN 10923 PosSides = PosSides + 1 10924 IF( Right % PartIndex == ParEnv % myPe ) ActSides = ActSides + 1 10925 END IF 10926 10927 IF( NoHalo .AND. ActSides == 0 ) CYCLE 10928 10929 IF( LocalConstraints ) THEN 10930 Coeff = 1.0_dp 10931 ELSE 10932 Coeff = (1.0_dp * ActSides) / (1.0_dp * PosSides) 10933 END IF 10934 10935 ! Consistently choose the face with the old edges 10936 IF( ALL( Left % NodeIndexes <= NoOrigNodes ) ) THEN 10937 ELSE IF( ALL( Right % NodeIndexes <= NoOrigNodes ) ) THEN 10938 swap => Left 10939 Left => Right 10940 Right => swap 10941 ELSE 10942 ! We already complained once 10943 CYCLE 10944 END IF 10945 10946 OldFace => Find_Face( Mesh, Left, Element ) 10947 nn = SIZE(Element % NodeIndexes) 10948 Indexes(1:nn) = Element % NodeIndexes 10949 Element % NodeIndexes = NodePerm(Indexes(1:nn)) + NoOrigNodes 10950 NewFace => Find_Face( Mesh, Right, Element ) 10951 Element % NodeIndexes = Indexes(1:nn) 10952 10953 ParentFound = ParentFound + 1 10954 10955 OldMap => GetEdgeMap( OldFace % TYPE % ElementCode / 100 ) 10956 NewMap => GetEdgeMap( NewFace % TYPE % ElementCode / 100 ) 10957 10958 IntegStuff = GaussPoints( oldface ) 10959 DO it = 1,IntegStuff % n 10960 u = integstuff % u(it) 10961 v = integstuff % v(it) 10962 w = integstuff % w(it) 10963 10964 nn = OldFace % TYPE % NumberOfNodes 10965 ElementNodes % x(1:nn) = Mesh % Nodes % x(oldface % NodeIndexes(1:nn)) 10966 ElementNodes % y(1:nn) = Mesh % Nodes % y(oldface % NodeIndexes(1:nn)) 10967 ElementNodes % z(1:nn) = Mesh % Nodes % z(oldface % NodeIndexes(1:nn)) 10968 10969 Stat = ElementInfo( OldFace, ElementNodes,u,v,w, DetJ, Basis,dBasisdx ) 10970 CALL GetEdgeBasis( OldFace, Wbasis, RotWbasis, Basis, dBasisdx ) 10971 10972 Point(1) = SUM(Basis(1:nn) * ElementNodes % x(1:nn)) 10973 Point(2) = SUM(Basis(1:nn) * ElementNodes % y(1:nn)) 10974 Point(3) = SUM(Basis(1:nn) * ElementNodes % z(1:nn)) 10975 10976 nn = NewFace % TYPE % NumberOfNodes 10977 ElementNodes % x(1:nn) = Mesh % Nodes % x(newface % NodeIndexes(1:nn)) 10978 ElementNodes % y(1:nn) = Mesh % Nodes % y(newface % NodeIndexes(1:nn)) 10979 ElementNodes % z(1:nn) = Mesh % Nodes % z(newface % NodeIndexes(1:nn)) 10980 10981 Found = PointInElement( NewFace, ElementNodes, Point, uvw ) 10982 u = uvw(1); v=uvw(2); w=uvw(3) 10983 Stat = ElementInfo(NewFace, ElementNodes,u,v,w, detj, Basis,dbasisdx ) 10984 CALL GetEdgeBasis( NewFace, Wbasis2, RotwBasis, Basis, dBasisdx ) 10985 10986 Weight = detJ * IntegStuff % s(it) * Coeff 10987 10988 ! Go through combinations of edges and find the edges for which the 10989 ! indexes are the same. 10990 DO i = 1,OldFace % TYPE % NumberOfEdges 10991 e1 = OldFace % EdgeIndexes(i) 10992 10993 IF ( EQind(e1) == 0 ) THEN 10994 indp = indp + 1 10995 EQind(e1) = indp 10996 InvPerm(indp) = n + e1 10997 END IF 10998 10999 IF( SetDiagEdges ) THEN 11000 i1 = OldFace % NodeIndexes( OldMap(i,1) ) 11001 i1 = NoOrigNodes + NodePerm(i1) 11002 i2 = OldFace % NodeIndexes( OldMap(i,2) ) 11003 i2 = NoOrigNodes + NodePerm(i2) 11004 11005 DO j = 1,NewFace % TYPE % NumberOfEdges 11006 j1 = NewFace % NodeIndexes( NewMap(j,1) ) 11007 j2 = NewFace % NodeIndexes( NewMap(j,2) ) 11008 IF (i1==j1 .AND. i2==j2 .OR. i1==j2 .AND. i2==j1 ) EXIT 11009 END DO 11010 val = Weight * SUM(WBasis(i,:) * Wbasis(i,:)) 11011 IF ( ABS(Val)>= 10*AEPS ) & 11012 CALL List_AddToMatrixElement(Projector % ListMatrix, EQind(e1), n + e1, Val ) 11013 11014 e2 = NewFace % EdgeIndexes(j) 11015 val = Weight * SUM(WBasis(i,:) * Wbasis2(j,:)) 11016 IF ( ABS(val) >= 10*AEPS ) & 11017 CALL List_AddToMatrixElement(Projector % ListMatrix, EQind(e1), n + e2, -Val ) 11018 ELSE 11019 DO j = 1,NewFace % TYPE % NumberOfEdges 11020 e2 = NewFace % EdgeIndexes(j) 11021 e12 = OldFace % EdgeIndexes(j) 11022 11023 val = Weight * SUM(WBasis(i,:) * Wbasis(j,:)) 11024 IF ( ABS(Val)>= 10*AEPS ) & 11025 CALL List_AddToMatrixElement(Projector % ListMatrix, EQind(e1), n + e12, Val ) 11026 11027 val = Weight * SUM(WBasis(i,:) * Wbasis2(j,:)) 11028 IF ( ABS(val) >= 10*AEPS ) & 11029 CALL List_AddToMatrixElement(Projector % ListMatrix, EQind(e1), n + e2, -Val ) 11030 END DO 11031 END IF 11032 11033 END DO 11034 END DO 11035 END DO 11036 11037 DEALLOCATE( EdgeDone ) 11038 IF( .NOT. DoNodes .AND. ParentMissing > 0 ) THEN 11039 CALL Warn('WeightedProjectorDiscont','Number of half-sided discontinuous BC elements in partition '& 11040 //TRIM(I2S(ParEnv % myPE))//': '//TRIM(I2S(ParentMissing)) ) 11041 CALL Warn('WeightedProjectorDiscont','Number of proper discontinuous BC elements in partition '& 11042 //TRIM(I2S(ParEnv % myPE))//': '//TRIM(I2S(ParentFound)) ) 11043 END IF 11044 CALL Info('WeightedProjectorDiscont','Created projector for '& 11045 //TRIM(I2S(indp-NoDiscontNodes))//' discontinuous edges',Level=10) 11046 END IF 11047 11048 ! Convert from list matrix to CRS matrix format 11049 CALL List_ToCRSMatrix(Projector) 11050 11051 IF( Projector % NumberOfRows > 0) THEN 11052 CALL CRS_SortMatrix(Projector,.TRUE.) 11053 CALL Info('WeightedProjectorDiscont','Number of entries in projector matrix: '//& 11054 TRIM(I2S(SIZE(Projector % Cols)) ), Level=9) 11055 ELSE 11056 CALL FreeMatrix(Projector); Projector=>NULL() 11057 END IF 11058 11059100 DEALLOCATE( ElementNodes % x, ElementNodes % y, ElementNodes % z ) 11060 DEALLOCATE( Indexes, DisContIndexes, Basis, dBasisdx, WBasis, WBasis2, RotWBasis ) 11061 IF( CheckHaloNodes ) DEALLOCATE( HaloNode ) 11062 11063 11064 END FUNCTION WeightedProjectorDiscont 11065 !------------------------------------------------------------------------------ 11066 11067 11068 !--------------------------------------------------------------------------- 11069 ! Simply fitting of cylinder into a point cloud. This is done in two phases. 11070 ! 1) The axis of the cylinder is found by minimizing the \sum((n_i*t)^2) 11071 ! for each component of of t where n_i:s are the surface normals. 11072 ! This is fully generic and assumes no positions. 11073 ! 2) The radius and center point of the cylinder are found by fitting a circle 11074 ! in the chosen plane to three representative points. Currently the fitting 11075 ! can only be done in x-y plane. 11076 !--------------------------------------------------------------------------- 11077 SUBROUTINE CylinderFit(PMesh, PParams) 11078 !--------------------------------------------------------------------------- 11079 TYPE(Mesh_t), POINTER :: PMesh 11080 TYPE(Valuelist_t), POINTER :: PParams 11081 11082 INTEGER :: i,j,k,n,t,AxisI,iter 11083 INTEGER, POINTER :: NodeIndexes(:) 11084 TYPE(Element_t), POINTER :: Element 11085 TYPE(Nodes_t) :: Nodes 11086 REAL(KIND=dp) :: NiNj(3,3),A(3,3),F(3),M11,M12,M13,M14 11087 REAL(KIND=dp) :: d1,d2,MinDist,MaxDist,Dist,X0,Y0,Rad 11088 REAL(KIND=dp) :: Normal(3), AxisNormal(3), Tangent1(3), Tangent2(3), Coord(3), & 11089 CircleCoord(3,3) 11090 INTEGER :: CircleInd(3) 11091 11092 CALL Info('CylinderFit','Trying to fit a cylinder to the surface patch',Level=10) 11093 11094 NiNj = 0.0_dp 11095 11096 n = PMesh % MaxElementNodes 11097 ALLOCATE( Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 11098 11099 ! If the initial mesh is in 2D there is really no need to figure out the 11100 ! direction of the rotational axis. It can only be aligned with the z-axis. 11101 IF( CurrentModel % Mesh % MeshDim == 2 ) THEN 11102 AxisNormal = 0.0_dp 11103 AxisNormal(3) = 1.0_dp 11104 GOTO 100 11105 END IF 11106 11107 11108 ! Compute the inner product of <N*N> for the elements 11109 DO t=1, PMesh % NumberOfBulkElements 11110 Element => PMesh % Elements(t) 11111 11112 n = Element % TYPE % NumberOfNodes 11113 NodeIndexes => Element % NodeIndexes 11114 11115 Nodes % x(1:n) = PMesh % Nodes % x(NodeIndexes(1:n)) 11116 Nodes % y(1:n) = PMesh % Nodes % y(NodeIndexes(1:n)) 11117 Nodes % z(1:n) = PMesh % Nodes % z(NodeIndexes(1:n)) 11118 11119 Normal = NormalVector( Element, Nodes, Check = .FALSE. ) 11120 11121 DO i=1,3 11122 DO j=1,3 11123 NiNj(i,j) = NiNj(i,j) + Normal(i) * Normal(j) 11124 END DO 11125 END DO 11126 END DO 11127 11128 ! Normalize by the number of boundary elements 11129 NiNj = NiNj / PMesh % NumberOfBulkElements 11130 11131 ! The potential direction for the cylinder axis is the direction with 11132 ! least hits for the normal. 11133 AxisI = 1 11134 DO i=2,3 11135 IF( NiNj(i,i) < NiNj(AxisI,AxisI) ) AxisI = i 11136 END DO 11137 11138 CALL Info('CylinderFit','Axis coordinate set to be: '//TRIM(I2S(AxisI))) 11139 11140 ! Keep the dominating direction fixed and iteratively solve the two other directions 11141 AxisNormal = 0.0_dp 11142 AxisNormal(AxisI) = 1.0_dp 11143 11144 ! Basically we could solve from equation Ax=0 the tangent but only up to a constant. 11145 ! Thus we enforce the axis direction to one by manipulation the matrix equation 11146 ! thereby can get a unique solution. 11147 A = NiNj 11148 A(AxisI,1:3) = 0.0_dp 11149 A(AxisI,AxisI) = 1.0_dp 11150 CALL InvertMatrix( A, 3 ) 11151 AxisNormal = A(1:3,AxisI) 11152 11153 ! Normalize the axis normal length to one 11154 AxisNormal = AxisNormal / SQRT( SUM( AxisNormal ** 2 ) ) 11155 IF( 1.0_dp - ABS( AxisNormal(3) ) > 1.0d-5 ) THEN 11156 CALL Warn('CylinderFit','The cylinder axis is not aligned with z-axis!') 11157 END IF 11158 11159100 CALL TangentDirections( AxisNormal,Tangent1,Tangent2 ) 11160 11161 IF(.FALSE.) THEN 11162 PRINT *,'Axis Normal:',AxisNormal 11163 PRINT *,'Axis Tangent 1:',Tangent1 11164 PRINT *,'Axis Tangent 2:',Tangent2 11165 END IF 11166 11167 ! Finding three points with maximum distance in the tangent directions 11168 11169 ! First, find the single extremum point in the first tangent direction 11170 ! Save the local coordinates in the N-T system of the cylinder 11171 MinDist = HUGE(MinDist) 11172 DO i=1, PMesh % NumberOfNodes 11173 Coord(1) = PMesh % Nodes % x(i) 11174 Coord(2) = PMesh % Nodes % y(i) 11175 Coord(3) = PMesh % Nodes % z(i) 11176 11177 d1 = SUM( Tangent1 * Coord ) 11178 IF( d1 < MinDist ) THEN 11179 MinDist = d1 11180 CircleInd(1) = i 11181 END IF 11182 END DO 11183 11184 i = CircleInd(1) 11185 Coord(1) = PMesh % Nodes % x(i) 11186 Coord(2) = PMesh % Nodes % y(i) 11187 Coord(3) = PMesh % Nodes % z(i) 11188 11189 CircleCoord(1,1) = SUM( Tangent1 * Coord ) 11190 CircleCoord(1,2) = SUM( Tangent2 * Coord ) 11191 CircleCoord(1,3) = SUM( AxisNormal * Coord ) 11192 11193 11194 !PRINT *,'MinDist1:',MinDist,CircleInd(1),CircleCoord(1,:) 11195 11196 ! Find two more points such that their minimum distance to the previous point(s) 11197 ! is maximized. This takes some time but the further the nodes are apart the more 11198 ! accurate it will be to fit the circle to the points. Also if there is just 11199 ! a symmetric section of the cylinder it is important to find the points rigorously. 11200 DO j=2,3 11201 ! The maximum minimum distance of any node from the previously defined nodes 11202 MaxDist = 0.0_dp 11203 DO i=1, PMesh % NumberOfNodes 11204 Coord(1) = PMesh % Nodes % x(i) 11205 Coord(2) = PMesh % Nodes % y(i) 11206 Coord(3) = PMesh % Nodes % z(i) 11207 11208 ! Minimum distance from the previously defined nodes 11209 MinDist = HUGE(MinDist) 11210 DO k=1,j-1 11211 d1 = SUM( Tangent1 * Coord ) 11212 d2 = SUM( Tangent2 * Coord ) 11213 Dist = ( d1 - CircleCoord(k,1) )**2 + ( d2 - CircleCoord(k,2) )**2 11214 MinDist = MIN( Dist, MinDist ) 11215 END DO 11216 11217 ! If the minimum distance is greater than in any other node, choose this 11218 IF( MaxDist < MinDist ) THEN 11219 MaxDist = MinDist 11220 CircleInd(j) = i 11221 END IF 11222 END DO 11223 11224 ! Ok, we have found the point now set the circle coordinates 11225 i = CircleInd(j) 11226 Coord(1) = PMesh % Nodes % x(i) 11227 Coord(2) = PMesh % Nodes % y(i) 11228 Coord(3) = PMesh % Nodes % z(i) 11229 11230 CircleCoord(j,1) = SUM( Tangent1 * Coord ) 11231 CircleCoord(j,2) = SUM( Tangent2 * Coord ) 11232 CircleCoord(j,3) = SUM( AxisNormal * Coord ) 11233 END DO 11234 11235 11236 !PRINT *,'Circle Indexes:',CircleInd 11237 11238 ! Given three nodes it is possible to analytically compute the center point and 11239 ! radius of the cylinder from a 4x4 determinant equation. The matrices values 11240 ! m1i are the determinants of the comatrices. 11241 11242 A(1:3,1) = CircleCoord(1:3,1) ! x 11243 A(1:3,2) = CircleCoord(1:3,2) ! y 11244 A(1:3,3) = 1.0_dp 11245 m11 = Det3x3( a ) 11246 11247 A(1:3,1) = CircleCoord(1:3,1)**2 + CircleCoord(1:3,2)**2 ! x^2+y^2 11248 A(1:3,2) = CircleCoord(1:3,2) ! y 11249 A(1:3,3) = 1.0_dp 11250 m12 = Det3x3( a ) 11251 11252 A(1:3,1) = CircleCoord(1:3,1)**2 + CircleCoord(1:3,2)**2 ! x^2+y^2 11253 A(1:3,2) = CircleCoord(1:3,1) ! x 11254 A(1:3,3) = 1.0_dp 11255 m13 = Det3x3( a ) 11256 11257 A(1:3,1) = CircleCoord(1:3,1)**2 + CircleCoord(1:3,2)**2 ! x^2+y^2 11258 A(1:3,2) = CircleCoord(1:3,1) ! x 11259 A(1:3,3) = CircleCoord(1:3,2) ! y 11260 m14 = Det3x3( a ) 11261 11262 !PRINT *,'determinants:',m11,m12,m13,m14 11263 11264 IF( ABS( m11 ) < EPSILON( m11 ) ) THEN 11265 CALL Fatal('CylinderFit','Points cannot be an a circle') 11266 END IF 11267 11268 X0 = 0.5_dp * m12 / m11 11269 Y0 = -0.5_dp * m13 / m11 11270 rad = SQRT( x0**2 + y0**2 + m14/m11 ) 11271 11272 Coord = x0 * Tangent1 + y0 * Tangent2 11273 11274 !PRINT *,'Center point in cartesian coordinates:',Coord 11275 11276 CALL ListAddConstReal( PParams,'Rotational Projector Center X',Coord(1)) 11277 CALL ListAddConstReal( PParams,'Rotational Projector Center Y',Coord(2)) 11278 CALL ListAddConstReal( PParams,'Rotational Projector Center Z',Coord(3)) 11279 11280 CALL ListAddConstReal( PParams,'Rotational Projector Normal X',AxisNormal(1)) 11281 CALL ListAddConstReal( PParams,'Rotational Projector Normal Y',AxisNormal(2)) 11282 CALL ListAddConstReal( PParams,'Rotational Projector Normal Z',AxisNormal(3)) 11283 11284 11285 CONTAINS 11286 11287 ! Compute the value of 3x3 determinant 11288 !------------------------------------------- 11289 FUNCTION Det3x3( A ) RESULT ( val ) 11290 11291 REAL(KIND=dp) :: A(:,:) 11292 REAL(KIND=dp) :: val 11293 11294 val = A(1,1) * ( A(2,2) * A(3,3) - A(2,3) * A(3,2) ) & 11295 - A(1,2) * ( A(2,1) * A(3,3) - A(2,3) * A(3,1) ) & 11296 + A(1,3) * ( A(2,1) * A(3,2) - A(2,2) * A(3,1) ) 11297 11298 END FUNCTION Det3x3 11299 11300 END SUBROUTINE CylinderFit 11301 11302 !------------------------------------------------------------------------------------------------ 11303 !> Finds nodes for which CandNodes are True such that their mutual distance is somehow 11304 !> maximized. We first find lower left corner, then the node that is furtherst apart from it, 11305 !> and continue as long as there are nodes to find. Typically we would be content with two nodes 11306 !> on a line, three nodes on a plane, and four nodes on a volume. 11307 !------------------------------------------------------------------------------------------------- 11308 SUBROUTINE FindExtremumNodes(Mesh,CandNodes,NoExt,Inds) 11309 TYPE(Mesh_t), POINTER :: Mesh 11310 LOGICAL, ALLOCATABLE :: CandNodes(:) 11311 INTEGER :: NoExt 11312 INTEGER, POINTER :: Inds(:) 11313 11314 REAL(KIND=dp) :: Coord(3),dCoord(3),dist,MinDist,MaxDist 11315 REAL(KIND=dp), ALLOCATABLE :: SetCoord(:,:) 11316 INTEGER :: i,j,k 11317 11318 ALLOCATE( SetCoord(NoExt,3) ) 11319 SetCoord = 0.0_dp 11320 Inds = 0 11321 11322 ! First find the lower left corner 11323 MinDist = HUGE(MinDist) 11324 DO i=1, Mesh % NumberOfNodes 11325 IF(.NOT. CandNodes(i) ) CYCLE 11326 Coord(1) = Mesh % Nodes % x(i) 11327 Coord(2) = Mesh % Nodes % y(i) 11328 Coord(3) = Mesh % Nodes % z(i) 11329 Dist = SUM( Coord ) 11330 IF( Dist < MinDist ) THEN 11331 Inds(1) = i 11332 MinDist = Dist 11333 SetCoord(1,:) = Coord 11334 END IF 11335 END DO 11336 11337 ! Find more points such that their minimum distance to the previous point(s) 11338 ! is maximized. 11339 DO j=2,NoExt 11340 ! The maximum minimum distance of any node from the previously defined nodes 11341 MaxDist = 0.0_dp 11342 DO i=1, Mesh % NumberOfNodes 11343 IF(.NOT. CandNodes(i) ) CYCLE 11344 Coord(1) = Mesh % Nodes % x(i) 11345 Coord(2) = Mesh % Nodes % y(i) 11346 Coord(3) = Mesh % Nodes % z(i) 11347 11348 ! Minimum distance from the previously defined nodes 11349 MinDist = HUGE(MinDist) 11350 DO k=1,j-1 11351 dCoord = SetCoord(k,:) - Coord 11352 Dist = SUM( dCoord**2 ) 11353 MinDist = MIN( Dist, MinDist ) 11354 END DO 11355 11356 ! If the minimum distance is greater than in any other node, choose this 11357 IF( MaxDist < MinDist ) THEN 11358 MaxDist = MinDist 11359 Inds(j) = i 11360 SetCoord(j,:) = Coord 11361 END IF 11362 END DO 11363 END DO 11364 11365 PRINT *,'Extremum Inds:',Inds 11366 DO i=1,NoExt 11367 PRINT *,'Node:',Inds(i),SetCoord(i,:) 11368 END DO 11369 11370 END SUBROUTINE FindExtremumNodes 11371 11372 11373 11374 !--------------------------------------------------------------------------- 11375 !> Given two interface meshes for nonconforming rotating boundaries make 11376 !> a coordinate transformation to (phi,z) level where the interpolation 11377 !> accuracy is not limited by the curvilinear coordinates. Also ensure 11378 !> that the master nodes manipulated so they for sure hit the target nodes. 11379 !--------------------------------------------------------------------------- 11380 SUBROUTINE RotationalInterfaceMeshes(BMesh1, BMesh2, BParams, Cylindrical, & 11381 Radius, FullCircle ) 11382 !--------------------------------------------------------------------------- 11383 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 11384 TYPE(Valuelist_t), POINTER :: BParams 11385 REAL(KIND=dp) :: Radius 11386 LOGICAL :: FullCircle, Cylindrical 11387 !-------------------------------------------------------------------------- 11388 TYPE(Mesh_t), POINTER :: PMesh 11389 TYPE(Element_t), POINTER :: Element 11390 REAL(KIND=dp) :: x1_min(3),x1_max(3),x2_min(3),x2_max(3),& 11391 x1r_min(3),x1r_max(3),x2r_min(3),x2r_max(3) 11392 REAL(KIND=dp) :: x(3), xcyl(3),rad2deg,F1min,F1max,F2min,F2max,dFii1,dFii2,eps_rad,& 11393 err1,err2,dF,Fii,Fii0,Nsymmetry,fmin,fmax,DegOffset,rad,alpha,x0(3),xtmp(3),& 11394 Normal(3), Tangent1(3), Tangent2(3) 11395 REAL(KIND=dp), POINTER :: TmpCoord(:) 11396 REAL(KIND=dp),ALLOCATABLE :: Angles(:) 11397 INTEGER, POINTER :: NodeIndexes(:) 11398 INTEGER :: i,j,k,n,ind,Nmax,Nmin,Nfii,Nnodes,MaxElemNodes,NElems 11399 LOGICAL :: Found, Hit0, Hit90, Hit180, Hit270, SetDegOffset 11400 LOGICAL :: GotNormal, GotCenter, MoveAngle 11401 11402 ! We choose degrees as they are more intuitive 11403 rad2deg = 180.0_dp / PI 11404 MaxElemNodes = BMesh2 % MaxElementNodes 11405 ALLOCATE( Angles(MaxElemNodes) ) 11406 11407 Nnodes = BMesh2 % NumberOfNodes 11408 NElems = BMesh2 % NumberOfBulkElements 11409 FullCircle = .FALSE. 11410 11411 ! Cylindrical projector is fitted always and rotational only when requested. 11412 IF( ListGetLogical( BParams,'Rotational Projector Center Fit',Found ) .OR. & 11413 Cylindrical ) THEN 11414 IF( .NOT. ListCheckPresent( BParams,'Rotational Projector Center X') ) THEN 11415 CALL CylinderFit( BMesh1, BParams ) 11416 END IF 11417 END IF 11418 11419 x0(1) = ListGetCReal( BParams,'Rotational Projector Center X',GotCenter ) 11420 x0(2) = ListGetCReal( BParams,'Rotational Projector Center Y',Found ) 11421 GotCenter = GotCenter .OR. Found 11422 x0(3) = ListGetCReal( BParams,'Rotational Projector Center Z',Found ) 11423 GotCenter = GotCenter .OR. Found 11424 11425 Normal(1) = ListGetCReal( BParams,'Rotational Projector Normal X',GotNormal ) 11426 Normal(2) = ListGetCReal( BParams,'Rotational Projector Normal Y',Found ) 11427 GotNormal = GotNormal .OR. Found 11428 Normal(3) = ListGetCReal( BParams,'Rotational Projector Normal Z',Found ) 11429 GotNormal = GotNormal .OR. Found 11430 11431 IF( GotNormal ) THEN 11432 CALL TangentDirections( Normal,Tangent1,Tangent2 ) 11433 END IF 11434 11435 ! Go through master (k=1) and target mesh (k=2) 11436 !-------------------------------------------- 11437 DO k=1,2 11438 11439 ! Potentially the projector may be set to rotate by just adding an offset 11440 ! to the angle. This may depende on time etc. 11441 IF( k == 1 ) THEN 11442 DegOffset = ListGetCReal(BParams,'Rotational Projector Angle Offset',SetDegOffset ) 11443 ELSE 11444 SetDegOffset = .FALSE. 11445 END IF 11446 11447 IF( k == 1 ) THEN 11448 PMesh => BMesh1 11449 ELSE 11450 PMesh => BMesh2 11451 END IF 11452 11453 ! Check the initial bounding boxes 11454 !--------------------------------------------------------------------------- 11455 x2_min(1) = MINVAL( PMesh % Nodes % x ) 11456 x2_min(2) = MINVAL( PMesh % Nodes % y ) 11457 x2_min(3) = MINVAL( PMesh % Nodes % z ) 11458 11459 x2_max(1) = MAXVAL( PMesh % Nodes % x ) 11460 x2_max(2) = MAXVAL( PMesh % Nodes % y ) 11461 x2_max(3) = MAXVAL( PMesh % Nodes % z ) 11462 11463 IF( k == 1 ) THEN 11464 CALL Info('RotationalInterfaceMeshes',& 11465 'Initial extrema for this boundary (x,y,z)',Level=8) 11466 ELSE IF( k == 2 ) THEN 11467 CALL Info('RotationalInterfaceMeshes',& 11468 'Initial extrema for target boundary (x,y,z)',Level=8) 11469 END IF 11470 DO i=1,3 11471 WRITE(Message,'(A,I0,A,2ES12.3)') 'Coordinate ',i,': ',x2_min(i),x2_max(i) 11472 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11473 END DO 11474 11475 ! Memorize the bounding box of the master mesh 11476 !-------------------------------------------------------------------------- 11477 IF( k == 1 ) THEN 11478 x1_min = x2_min 11479 x1_max = x2_max 11480 END IF 11481 11482 ! Do the actual coordinate transformation 11483 !--------------------------------------------------------------------------- 11484 n = PMesh % NumberOfNodes 11485 DO i=1,n 11486 x(1) = PMesh % Nodes % x(i) 11487 x(2) = PMesh % Nodes % y(i) 11488 x(3) = PMesh % Nodes % z(i) 11489 11490 ! Subtract the center of axis 11491 IF( GotCenter ) THEN 11492 x = x - x0 11493 END IF 11494 11495 IF( GotNormal ) THEN 11496 xtmp = x 11497 x(1) = SUM( Tangent1 * xtmp ) 11498 x(2) = SUM( Tangent2 * xtmp ) 11499 x(3) = SUM( Normal * xtmp ) 11500 END IF 11501 11502 11503 ! Set the angle to be the first coordinate as it may sometimes be the 11504 ! only nonzero coordinate. Z-coordinate is always unchanged. 11505 !------------------------------------------------------------------------ 11506 alpha = rad2deg * ATAN2( x(2), x(1) ) 11507 rad = SQRT( x(1)**2 + x(2)**2) 11508 11509 ! Set the offset and revert then the angle to range [-180,180] 11510 IF( SetDegOffset ) THEN 11511 alpha = MODULO( alpha + DegOffset, 360.0_dp ) 11512 IF( alpha > 180.0_dp ) alpha = alpha - 360.0 11513 END IF 11514 11515 PMesh % Nodes % x(i) = alpha 11516 PMesh % Nodes % y(i) = x(3) 11517 PMesh % Nodes % z(i) = rad 11518 END DO 11519 11520 11521 ! For cylindrical projector follow exactly the same logic for slave and master 11522 !------------------------------------------------------------------------------ 11523 IF( Cylindrical .AND. k == 2 ) THEN 11524 IF( MoveAngle ) THEN 11525 CALL Info('RotationalInterfaceMeshes','Moving the 2nd mesh discontinuity to same angle',Level=6) 11526 DO j=1,PMesh % NumberOfNodes 11527 IF( PMesh % Nodes % x(j) < Fii0 ) PMesh % Nodes % x(j) = & 11528 PMesh % Nodes % x(j) + 360.0_dp 11529 END DO 11530 END IF 11531 ELSE 11532 ! Let's see if we have a full angle to operate or not. 11533 ! If not, then make the interval continuous. 11534 ! Here we check only four critical angles: (0,90,180,270) degs. 11535 Hit0 = .FALSE.; Hit90 = .FALSE.; Hit180 = .FALSE.; Hit270 = .FALSE. 11536 MoveAngle = .FALSE.; Fii = 0.0_dp; Fii0 = 0.0_dp 11537 11538 DO i=1, PMesh % NumberOfBulkElements 11539 Element => PMesh % Elements(i) 11540 n = Element % TYPE % NumberOfNodes 11541 NodeIndexes => Element % NodeIndexes 11542 Angles(1:n) = PMesh % Nodes % x(NodeIndexes) 11543 11544 fmin = MINVAL( Angles(1:n) ) 11545 fmax = MAXVAL( Angles(1:n) ) 11546 11547 IF( fmax - fmin > 180.0_dp ) THEN 11548 Hit180 = .TRUE. 11549 ELSE 11550 IF( fmax >= 0.0 .AND. fmin <= 0.0 ) Hit0 = .TRUE. 11551 IF( fmax >= 90.0_dp .AND. fmin <= 90.0_dp ) Hit90 = .TRUE. 11552 IF( fmax >= -90.0_dp .AND. fmin <= -90.0_dp ) Hit270 = .TRUE. 11553 END IF 11554 END DO 11555 FullCircle = Hit0 .AND. Hit90 .AND. Hit180 .AND. Hit270 11556 11557 ! Eliminate the problematic discontinuity in case we have no full circle 11558 ! The discontinuity will be moved to some of angles (-90,0,90). 11559 IF( FullCircle ) THEN 11560 CALL Info('RotationalInterfaceMeshes','Cylindrical interface seems to be a full circle',& 11561 Level=6) 11562 ELSE IF( Hit180 ) THEN 11563 MoveAngle = .TRUE. 11564 IF( .NOT. Hit0 ) THEN 11565 Fii = 0.0_dp 11566 ELSE IF( .NOT. Hit270 ) THEN 11567 Fii = -90.0_dp 11568 ELSE IF( .NOT. Hit90 ) THEN 11569 Fii = 90.0_dp 11570 END IF 11571 11572 DO j=1,PMesh % NumberOfNodes 11573 IF( PMesh % Nodes % x(j) < Fii ) PMesh % Nodes % x(j) = & 11574 PMesh % Nodes % x(j) + 360.0_dp 11575 END DO 11576 WRITE( Message,'(A,F8.3)') 'Moving discontinuity of angle to: ',Fii 11577 Fii0 = Fii 11578 CALL Info('RotationalInterfaceMesh',Message,Level=6) 11579 END IF 11580 END IF 11581 11582 11583 ! Check the transformed bounding boxes 11584 !--------------------------------------------------------------------------- 11585 x2r_min(1) = MINVAL( PMesh % Nodes % x ) 11586 x2r_min(2) = MINVAL( PMesh % Nodes % y ) 11587 x2r_min(3) = MINVAL( PMesh % Nodes % z ) 11588 11589 x2r_max(1) = MAXVAL( PMesh % Nodes % x ) 11590 x2r_max(2) = MAXVAL( PMesh % Nodes % y ) 11591 x2r_max(3) = MAXVAL( PMesh % Nodes % z ) 11592 11593 IF( k == 1 ) THEN 11594 CALL Info('RotationalInterfaceMeshes',& 11595 'Transformed extrema for this boundary (phi,z,r)',Level=8) 11596 ELSE IF( k == 2 ) THEN 11597 CALL Info('RotationalInterfaceMeshes',& 11598 'Transformed extrema for target boundary (phi,z,r)',Level=8) 11599 END IF 11600 DO i=1,3 11601 WRITE(Message,'(A,I0,A,2ES12.3)') 'Coordinate ',i,': ',x2r_min(i),x2r_max(i) 11602 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11603 END DO 11604 11605 IF( x2r_min(3) < EPSILON( Radius ) ) THEN 11606 CALL Fatal('RotationalInterfaceMeshes','Radius cannot be almost zero!') 11607 END IF 11608 11609 ! Memorize the bounding box for the 1st mesh 11610 IF( k == 1 ) THEN 11611 x1r_min = x2r_min 11612 x1r_max = x2r_max 11613 END IF 11614 END DO 11615 11616 eps_rad = 1.0d-3 11617 11618 ! Choose radius to be max radius of this boundary 11619 Radius = x1r_max(3) 11620 11621 err1 = ( x1r_max(3) - x1r_min(3) ) / Radius 11622 err2 = ( x2r_max(3) - x2r_min(3) ) / Radius 11623 11624 WRITE(Message,'(A,ES12.3)') 'Discrepancy from constant radius:',err1 11625 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11626 11627 WRITE(Message,'(A,ES12.3)') 'Discrepancy from constant radius:',err2 11628 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11629 11630 IF( err1 > eps_rad .OR. err2 > eps_rad ) THEN 11631 CALL Warn('RotationalInterfaceMeshes','Discrepancy of radius is rather large!') 11632 END IF 11633 11634 ! Ok, so we have concluded that the interface has constant radius 11635 ! therefore the constant radius may be removed from the mesh description. 11636 ! Or perhaps we don't remove to allow more intelligent projector building 11637 ! for contact mechanics. 11638 !--------------------------------------------------------------------------- 11639 !Bmesh1 % Nodes % z = 0.0_dp 11640 !BMesh2 % Nodes % z = 0.0_dp 11641 11642 ! Check whether the z-coordinate is constant or not. 11643 ! Constant z-coordinate implies 1D system, otherwise 2D system. 11644 !--------------------------------------------------------------------------- 11645 err1 = ( x1r_max(2) - x1r_min(2) ) / Radius 11646 err2 = ( x2r_max(2) - x2r_min(2) ) / Radius 11647 11648 IF( err1 < eps_rad .AND. err2 < eps_rad ) THEN 11649 CALL Info('RotationalInterfaceMeshes','The effective interface meshes are 1D') 11650 Bmesh1 % Nodes % y = 0.0_dp 11651 Bmesh2 % Nodes % y = 0.0_dp 11652 ELSE 11653 CALL Info('RotationalInterfaceMeshes','The effective interface meshes are 2D') 11654 END IF 11655 11656 ! Some pieces of the code cannot work with 1D meshes, this choice is ok for all steps 11657 Bmesh1 % MeshDim = 2 11658 Bmesh2 % MeshDim = 2 11659 11660 ! Cylindrical interface does not have symmetry as does the rotational! 11661 IF( Cylindrical .OR. FullCircle ) RETURN 11662 11663 ! If were are studying a symmetric segment then anylyze further the angle 11664 !------------------------------------------------------------------------- 11665 dFii1 = x1r_max(1)-x1r_min(1) 11666 dFii2 = x2r_max(1)-x2r_min(1) 11667 11668 WRITE(Message,'(A,ES12.3)') 'This boundary dfii: ',dFii1 11669 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11670 11671 WRITE(Message,'(A,ES12.3)') 'Target boundary dfii: ',dFii2 11672 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11673 11674 err1 = 2 * ABS( dFii1 - dFii2 ) / ( dFii1 + dFii2 ) 11675 WRITE(Message,'(A,ES12.3)') 'Discrepancy in dfii:',err1 11676 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11677 11678 i = ListGetInteger(BParams,'Rotational Projector Periods',Found ) 11679 IF( .NOT. Found ) THEN 11680 Nsymmetry = 360.0_dp / dFii2 11681 WRITE(Message,'(A,ES12.3)') 'Suggested sections in target:',Nsymmetry 11682 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11683 IF( ABS( Nsymmetry - NINT( Nsymmetry ) ) < 0.01 .OR. Nsymmetry < 1.5 ) THEN 11684 CALL Info('RotationalINterfaceMeshes','Assuming number of periods: '& 11685 //TRIM(I2S(NINT(Nsymmetry))),Level=8) 11686 ELSE 11687 IF( dFii1 < dFii2 ) THEN 11688 CALL Info('RotationalInterfaceMeshes','You might try to switch master and target!',Level=3) 11689 END IF 11690 CALL Fatal('RotationalInterfaceMeshes','Check your settings, this cannot be periodic!') 11691 END IF 11692 CALL ListAddInteger(BParams,'Rotational Projector Periods', NINT( Nsymmetry ) ) 11693 ELSE 11694 WRITE(Message,'(A,I0)') 'Using enforced number of periods: ',i 11695 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11696 Nsymmetry = 360.0_dp / dFii2 11697 WRITE(Message,'(A,ES12.3)') 'Suggested number of periods:',Nsymmetry 11698 CALL Info('RotationalInterfaceMeshes',Message,Level=8) 11699 END IF 11700 11701 END SUBROUTINE RotationalInterfaceMeshes 11702!------------------------------------------------------------------------------ 11703 11704 11705 11706 !--------------------------------------------------------------------------- 11707 !> Given axial projectors compute the number of cycles. 11708 !--------------------------------------------------------------------------- 11709 SUBROUTINE AxialInterfaceMeshes(BMesh1, BMesh2, BParams ) 11710 !--------------------------------------------------------------------------- 11711 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 11712 TYPE(Valuelist_t), POINTER :: BParams 11713 !-------------------------------------------------------------------------- 11714 TYPE(Mesh_t), POINTER :: PMesh 11715 TYPE(Element_t), POINTER :: Element 11716 REAL(KIND=dp) :: minalpha, maxalpha, minalpha2, maxalpha2 11717 REAL(KIND=dp) :: x(3), xcyl(3),rad2deg,F1min,F1max,F2min,F2max,dFii, dFii1,dFii2,eps_rad,& 11718 err1,err2,dF,Nsymmetry,rad,alpha,x0(3),xtmp(3), maxrad, & 11719 Normal(3), Tangent1(3), Tangent2(3) 11720 REAL(KIND=dp), POINTER :: TmpCoord(:) 11721 REAL(KIND=dp),ALLOCATABLE :: Angles(:) 11722 INTEGER, POINTER :: NodeIndexes(:) 11723 INTEGER :: i,j,k,n,ind,Nmax,Nmin,Nfii,Nnodes,MaxElemNodes,sweep 11724 LOGICAL :: Found, Hit0, Hit90, Hit180, Hit270 11725 LOGICAL :: GotNormal, GotCenter, FullCircle 11726 11727 ! We choose degrees as they are more intuitive 11728 rad2deg = 180.0_dp / PI 11729 MaxElemNodes = BMesh2 % MaxElementNodes 11730 11731 x0(1) = ListGetCReal( BParams,'Axial Projector Center X',GotCenter ) 11732 x0(2) = ListGetCReal( BParams,'Axial Projector Center Y',Found ) 11733 GotCenter = GotCenter .OR. Found 11734 x0(3) = ListGetCReal( BParams,'Axial Projector Center Z',Found ) 11735 GotCenter = GotCenter .OR. Found 11736 11737 Normal(1) = ListGetCReal( BParams,'Axial Projector Normal X',GotNormal ) 11738 Normal(2) = ListGetCReal( BParams,'Axial Projector Normal Y',Found ) 11739 GotNormal = GotNormal .OR. Found 11740 Normal(3) = ListGetCReal( BParams,'Axial Projector Normal Z',Found ) 11741 GotNormal = GotNormal .OR. Found 11742 11743 IF( GotNormal ) THEN 11744 CALL TangentDirections( Normal,Tangent1,Tangent2 ) 11745 ELSE 11746 CALL Info('AxialInterfaceMeshes',& 11747 'Assuming axial interface to have z-axis the normal!',Level=8) 11748 END IF 11749 11750 ! Go through master (k=1) and target mesh (k=2) 11751 !-------------------------------------------- 11752 FullCircle = .FALSE. 11753 11754 DO k=1,2 11755 11756 IF( k == 1 ) THEN 11757 PMesh => BMesh1 11758 ELSE 11759 PMesh => BMesh2 11760 END IF 11761 11762 ! Do the actual coordinate transformation 11763 !--------------------------------------------------------------------------- 11764 n = PMesh % NumberOfNodes 11765 11766 ! Register the hit in basic quadrants 11767 Hit0 = .FALSE.; Hit90 = .FALSE.; Hit180 = .FALSE.; Hit270 = .FALSE. 11768 maxrad = 0.0_dp 11769 minalpha = HUGE( minalpha ); maxalpha = -HUGE(maxalpha) 11770 minalpha2 = HUGE( minalpha2 ); maxalpha2 = -HUGE(maxalpha2) 11771 11772 ! 1st sweep only find max radius, 2nd sweep register the angle range 11773 DO sweep = 1, 2 11774 DO i=1,n 11775 x(1) = PMesh % Nodes % x(i) 11776 x(2) = PMesh % Nodes % y(i) 11777 x(3) = PMesh % Nodes % z(i) 11778 11779 ! Subtract the center of axis 11780 IF( GotCenter ) x = x - x0 11781 11782 IF( GotNormal ) THEN 11783 xtmp = x 11784 x(1) = SUM( Tangent1 * xtmp ) 11785 x(2) = SUM( Tangent2 * xtmp ) 11786 x(3) = SUM( Normal * xtmp ) 11787 END IF 11788 11789 ! Compute the angle 11790 !------------------------------------------------------------------------ 11791 rad = SQRT( x(1)**2 + x(2)**2) 11792 11793 IF( sweep == 1 ) THEN 11794 maxrad = MAX( maxrad, rad ) 11795 CYCLE 11796 END IF 11797 11798 ! Do the logic for large enough radius 11799 IF( rad < 0.5_dp * maxrad ) CYCLE 11800 11801 IF( x(1) > 0.0 .AND. ABS(x(2)) < ABS(x(1)) ) Hit0 = .TRUE. 11802 IF( x(2) > 0.0 .AND. ABS(x(1)) < ABS(x(2)) ) Hit90 = .TRUE. 11803 IF( x(1) < 0.0 .AND. ABS(x(2)) < ABS(x(1)) ) Hit180 = .TRUE. 11804 IF( x(2) < 0.0 .AND. ABS(x(1)) < ABS(x(2)) ) Hit270 = .TRUE. 11805 11806 ! This can compute the range if there is no nodes close to discontinuity at 180 degs 11807 alpha = rad2deg * ATAN2( x(2), x(1) ) 11808 minalpha = MIN( alpha, minalpha ) 11809 maxalpha = MAX( alpha, maxalpha ) 11810 11811 ! This eliminates the discontinuity and moves it to 0 degs 11812 IF( alpha < 0.0_dp ) alpha = alpha + 360.0_dp 11813 minalpha2 = MIN( alpha, minalpha2 ) 11814 maxalpha2 = MAX( alpha, maxalpha2 ) 11815 END DO 11816 END DO 11817 11818 FullCircle = Hit0 .AND. Hit90 .AND. Hit180 .AND. Hit270 11819 IF( FullCircle ) THEN 11820 CALL Info('AxialInterfaceMeshes','Axial interface seems to be a full circle',& 11821 Level=6) 11822 EXIT 11823 END IF 11824 11825 dFii = MIN( maxalpha2 - minalpha2, maxalpha - minalpha ) 11826 11827 ! memorize the max angle for 1st boundary mesh 11828 IF( k == 1 ) THEN 11829 WRITE(Message,'(A,ES12.3)') 'This boundary dfii: ',dFii 11830 dFii1 = dFii 11831 ELSE 11832 WRITE(Message,'(A,ES12.3)') 'Target boundary dfii: ',dFii 11833 dFii2 = dFii 11834 END IF 11835 CALL Info('AxialInterfaceMeshes',Message,Level=8) 11836 END DO 11837 11838 IF( FullCircle ) THEN 11839 Nsymmetry = 1.0_dp 11840 ELSE 11841 err1 = 2 * ABS( dFii1 - dFii2 ) / ( dFii1 + dFii2 ) 11842 WRITE(Message,'(A,ES12.3)') 'Discrepancy in dfii:',err1 11843 CALL Info('AxialInterfaceMeshes',Message,Level=8) 11844 Nsymmetry = 360.0_dp / ( MIN( dfii1, dfii2 ) ) 11845 END IF 11846 11847 WRITE(Message,'(A,ES12.3)') 'Suggested number of periods:',Nsymmetry 11848 CALL Info('AxialInterfaceMeshes',Message,Level=8) 11849 11850 i = ListGetInteger(BParams,'Axial Projector Periods',Found ) 11851 IF( .NOT. Found ) THEN 11852 CALL ListAddInteger(BParams,'Axial Projector Periods', NINT( Nsymmetry ) ) 11853 ELSE 11854 WRITE(Message,'(A,I0)') 'Using enforced number of periods: ',i 11855 CALL Info('AxialInterfaceMeshes',Message,Level=8) 11856 END IF 11857 11858 END SUBROUTINE AxialInterfaceMeshes 11859!------------------------------------------------------------------------------ 11860 11861 11862 !--------------------------------------------------------------------------- 11863 !> Given two interface meshes for nonconforming radial boundaries make 11864 !> a coordinate transformation to (r,z) level. 11865 !> This is always a symmetry condition and can not be a contact condition. 11866 !--------------------------------------------------------------------------- 11867 SUBROUTINE RadialInterfaceMeshes(BMesh1, BMesh2, BParams ) 11868 !--------------------------------------------------------------------------- 11869 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 11870 TYPE(Valuelist_t), POINTER :: BParams 11871 !-------------------------------------------------------------------------- 11872 TYPE(Mesh_t), POINTER :: PMesh 11873 REAL(KIND=dp) :: x1_min(3),x1_max(3),x2_min(3),x2_max(3), x(3), r, phi, z, & 11874 err1, err2, phierr, eps_rad, rad, rad2deg 11875 INTEGER :: i,j,k 11876 11877 ! We choose degrees as they are more intuitive 11878 rad2deg = 180.0_dp / PI 11879 11880 ! Go through master (k=1) and target mesh (k=2) 11881 !-------------------------------------------- 11882 DO k=1,2 11883 11884 IF( k == 1 ) THEN 11885 PMesh => BMesh1 11886 ELSE 11887 PMesh => BMesh2 11888 END IF 11889 11890 x2_min = HUGE( x2_min ) 11891 x2_max = -HUGE( x2_max ) 11892 11893 ! Loop over all nodes 11894 !---------------------------------------------------------------------------- 11895 DO i=1,PMesh % NumberOfNodes 11896 x(1) = PMesh % Nodes % x(i) 11897 x(2) = PMesh % Nodes % y(i) 11898 x(3) = PMesh % Nodes % z(i) 11899 11900 ! Do the actual coordinate transformation 11901 !--------------------------------------------------------------------------- 11902 r = SQRT( x(1)**2 + x(2)**2 ) 11903 phi = rad2deg * ATAN2( x(2), x(1) ) 11904 z = x(3) 11905 11906 !PRINT *,'interface node:',k,i,r,phi,x(1:2) 11907 11908 PMesh % Nodes % x(i) = r 11909 PMesh % Nodes % y(i) = z 11910 PMesh % Nodes % z(i) = 0.0_dp 11911 11912 ! This is just to check a posteriori that the ranges are ok 11913 x2_min(1) = MIN(r,x2_min(1)) 11914 IF( r > EPSILON( r ) ) THEN 11915 x2_min(2) = MIN(phi,x2_min(2)) 11916 END IF 11917 x2_min(3) = MIN(z,x2_min(3)) 11918 11919 x2_max(1) = MAX(r,x2_max(1)) 11920 IF( r > EPSILON(r) ) THEN 11921 x2_max(2) = MAX(phi,x2_max(2)) 11922 END IF 11923 x2_max(3) = MAX(z,x2_max(3)) 11924 END DO 11925 11926 ! Memorize the bounding box of the master mesh 11927 !-------------------------------------------------------------------------- 11928 IF( k == 1 ) THEN 11929 x1_min = x2_min 11930 x1_max = x2_max 11931 END IF 11932 11933 IF( k == 1 ) THEN 11934 CALL Info('RadialInterfaceMeshes',& 11935 'Transformed extrema for this boundary (r,phi,z)',Level=8) 11936 ELSE IF( k == 2 ) THEN 11937 CALL Info('RadialInterfaceMeshes',& 11938 'Transformed extrema for target boundary (r,phi,z)',Level=8) 11939 END IF 11940 11941 DO i=1,3 11942 WRITE(Message,'(A,I0,A,2ES12.3)') 'Coordinate ',i,': ',x2_min(i),x2_max(i) 11943 CALL Info('RadialInterfaceMeshes',Message,Level=8) 11944 END DO 11945 11946 phierr = x2_max(2) - x2_min(2) 11947 WRITE(Message,'(A,ES12.3)') 'Discrepancy from constant angle (degs):',phierr 11948 CALL Info('RadialInterfaceMeshes',Message,Level=8) 11949 END DO 11950 11951 ! Error in radius 11952 ! Choose radius to be max radius of either boundary 11953 rad = MAX( x1_max(1), x2_max(1) ) 11954 err1 = ABS( x1_max(1) - x2_max(1) ) / rad 11955 err2 = ABS( x1_min(1) - x2_min(1) ) / rad 11956 11957 WRITE(Message,'(A,ES12.3)') 'Discrepancy in maximum radius:',err1 11958 CALL Info('RadialInterfaceMeshes',Message,Level=8) 11959 11960 WRITE(Message,'(A,ES12.3)') 'Discrepancy in minimum radius:',err2 11961 CALL Info('RadialInterfaceMeshes',Message,Level=8) 11962 11963 eps_rad = 1.0d-3 11964 IF( err1 > eps_rad .OR. err2 > eps_rad ) THEN 11965 CALL Warn('RadialInterfaceMeshes','Discrepancy of radius may be too large!') 11966 END IF 11967 11968 ! Some pieces of the code cannot work with 1D meshes, this choice is ok for all steps 11969 Bmesh1 % MeshDim = 2 11970 Bmesh2 % MeshDim = 2 11971 11972 END SUBROUTINE RadialInterfaceMeshes 11973!------------------------------------------------------------------------------ 11974 11975 !--------------------------------------------------------------------------- 11976 !> Given two interface meshes flatten them to (x,y) plane. 11977 !--------------------------------------------------------------------------- 11978 SUBROUTINE FlatInterfaceMeshes(BMesh1, BMesh2, BParams ) 11979 !--------------------------------------------------------------------------- 11980 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 11981 TYPE(Valuelist_t), POINTER :: BParams 11982 !-------------------------------------------------------------------------- 11983 TYPE(Mesh_t), POINTER :: Bmesh 11984 INTEGER :: FlatDim, MeshDim, MinDiffI, i, j 11985 REAL(KIND=dp), POINTER CONTIG :: Coord(:) 11986 REAL(KIND=dp) :: Diff, MaxDiff, MinDiff, RelDiff, RelDiff1 11987 LOGICAL :: Found, ReduceDim 11988 11989 CALL Info('FlatInterfaceMeshes','Flattening interface meshes to 2D',Level=8) 11990 11991 MeshDim = CurrentModel % Dimension 11992 FlatDim = ListGetInteger( BParams,'Flat Projector Coordinate',Found,minv=1,maxv=3) 11993 ReduceDim = ListGetLogical( BParams,'Flat Projector Reduce Dimension',Found ) 11994 11995 IF(.NOT. Found ) THEN 11996 DO j=1, 2 11997 IF( j == 1 ) THEN 11998 Bmesh => BMesh1 11999 ELSE 12000 BMesh => BMesh2 12001 END IF 12002 12003 MaxDiff = 0.0 12004 MinDiff = HUGE( MinDiff ) 12005 12006 DO i = 1, MeshDim 12007 IF( i == 1 ) THEN 12008 Coord => BMesh % Nodes % x 12009 ELSE IF( i == 2 ) THEN 12010 Coord => Bmesh % Nodes % y 12011 ELSE 12012 Coord => Bmesh % Nodes % z 12013 END IF 12014 12015 Diff = MAXVAL( Coord ) - MINVAL( Coord ) 12016 MaxDiff = MAX( Diff, MaxDiff ) 12017 IF( Diff < MinDiff ) THEN 12018 MinDiff = Diff 12019 MinDiffI = i 12020 END IF 12021 END DO 12022 12023 RelDiff = MinDiff / MaxDiff 12024 IF( j == 1 ) THEN 12025 FlatDim = MinDiffI 12026 RelDiff1 = RelDiff 12027 ELSE IF( j == 2 ) THEN 12028 IF( RelDiff < RelDiff1 ) FlatDim = MinDiffI 12029 END IF 12030 END DO 12031 12032 CALL Info('FlatInterfaceMeshes','> Flat Projector Coordinate < set to: '//TRIM(I2S(FlatDim))) 12033 CALL ListAddInteger( BParams,'Flat Projector Coordinate',FlatDim ) 12034 END IF 12035 12036 12037 DO j=1,2 12038 ! Some pieces of the code cannot work with 1D meshes, this choice is ok for all steps 12039 IF( j == 1 ) THEN 12040 Bmesh => BMesh1 12041 ELSE 12042 BMesh => BMesh2 12043 END IF 12044 12045 ! Set the 3rd component to be the "distance" in the flat interface 12046 IF( FlatDim == 3 ) THEN 12047 CONTINUE 12048 ELSE IF( FlatDim == 2 ) THEN 12049 Coord => BMesh % Nodes % y 12050 BMesh % Nodes % y => BMesh % Nodes % z 12051 BMesh % Nodes % z => Coord 12052 IF( MeshDim == 2 ) BMesh % Nodes % y = 0.0_dp 12053 ELSE IF( FlatDim == 1 ) THEN 12054 Coord => BMesh % Nodes % x 12055 BMesh % Nodes % x => BMesh % Nodes % y 12056 BMesh % Nodes % y => BMesh % Nodes % z 12057 Bmesh % Nodes % z => Coord 12058 IF( MeshDim == 2 ) BMesh % Nodes % y = 0.0_dp 12059 END IF 12060 12061 IF( ReduceDim ) BMesh % Nodes % z = 0.0_dp 12062 12063 Bmesh % MeshDim = 2 12064 END DO 12065 12066 END SUBROUTINE FlatInterfaceMeshes 12067!------------------------------------------------------------------------------ 12068 12069 12070 !--------------------------------------------------------------------------- 12071 !> Given two interface meshes flatten them into the plane that 12072 !> best fits either of the meshes. 12073 !--------------------------------------------------------------------------- 12074 SUBROUTINE PlaneInterfaceMeshes(BMesh1, BMesh2, BParams ) 12075 !--------------------------------------------------------------------------- 12076 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 12077 TYPE(Valuelist_t), POINTER :: BParams 12078 !-------------------------------------------------------------------------- 12079 TYPE(Mesh_t), POINTER :: Bmesh 12080 INTEGER :: i, j, n, nip, MeshDim 12081 REAL(KIND=dp) :: Normal(3), NormalSum(3), RefSum, Length, Planeness, & 12082 PlaneNormal(3,1), PlaneNormal1(3,1), Planeness1, Normal1(3), & 12083 Tangent(3), Tangent2(3), Coord(3), detJ, Normal0(3) 12084 REAL(KIND=dp), POINTER :: PNormal(:,:), Basis(:) 12085 TYPE(Element_t), POINTER :: Element 12086 TYPE(GaussIntegrationPoints_t) :: IP 12087 TYPE(Nodes_t) :: ElementNodes 12088 INTEGER, POINTER :: NodeIndexes(:) 12089 LOGICAL :: Found, Stat, Normal0Set 12090 12091 CALL Info('PlaneInterfaceMeshes','Flattening interface meshes to a plane',Level=8) 12092 12093 MeshDim = CurrentModel % Dimension 12094 PNormal => ListGetConstRealArray( BParams,'Plane Projector Normal',Found) 12095 12096 ! If the projector normal is not given determine it first 12097 IF(.NOT. Found ) THEN 12098 CALL Info('PlaneInterfaceMeshes','Could not find > Plane Projector Normal < so determining it now',Level=12) 12099 12100 n = MAX_ELEMENT_NODES 12101 ALLOCATE( ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n), Basis(n) ) 12102 ElementNodes % x = 0; ElementNodes % y = 0; ElementNodes % z = 0 12103 12104 ! Fit a plane to both datasets 12105 DO j=1, 2 12106 IF( j == 1 ) THEN 12107 Bmesh => BMesh1 12108 ELSE 12109 BMesh => BMesh2 12110 END IF 12111 12112 NormalSum = 0.0_dp 12113 RefSum = 0.0_dp 12114 Normal0Set = .FALSE. 12115 12116 ! we use the Dot2Min and Normal2 temporarily also for first mesh, with k=1 12117 !------------------------------------------------------------------------- 12118 DO i=1, BMesh % NumberOfBulkElements 12119 Element => BMesh % Elements(i) 12120 n = Element % TYPE % NumberOfNodes 12121 NodeIndexes => Element % NodeIndexes 12122 IP = GaussPoints( Element ) 12123 12124 ElementNodes % x(1:n) = BMesh % Nodes % x(NodeIndexes(1:n)) 12125 ElementNodes % y(1:n) = BMesh % Nodes % y(NodeIndexes(1:n)) 12126 ElementNodes % z(1:n) = BMesh % Nodes % z(NodeIndexes(1:n)) 12127 12128 DO nip=1, IP % n 12129 stat = ElementInfo( Element,ElementNodes,& 12130 IP % u(nip),IP % v(nip),IP % w(nip),detJ,Basis) 12131 12132 Normal = NormalVector( Element, ElementNodes, & 12133 IP % u(nip), IP % v(nip), .FALSE. ) 12134 IF( .NOT. Normal0Set ) THEN 12135 Normal0 = Normal 12136 Normal0Set = .TRUE. 12137 END IF 12138 12139 IF( SUM( Normal * Normal0 ) < 0.0 ) Normal = -Normal 12140 12141 NormalSum = NormalSum + IP % S(nip) * DetJ * Normal 12142 RefSum = RefSum + IP % S(nip) * DetJ 12143 END DO 12144 END DO 12145 12146 ! Normalize the normal to unity length 12147 Length = SQRT( SUM( NormalSum ** 2 ) ) 12148 PlaneNormal(:,1) = NormalSum / Length 12149 12150 ! Planeness is one if all the normals have the same direction 12151 Planeness = Length / RefSum 12152 12153 ! Save the key parameters of the first mesh 12154 IF( j == 1 ) THEN 12155 PlaneNormal1 = PlaneNormal 12156 Planeness1 = Planeness 12157 END IF 12158 END DO 12159 12160 ! Choose the mesh for which is close to a plane 12161 IF( Planeness1 > Planeness ) THEN 12162 PRINT *,'PlaneNormal: Selecting slave normal' 12163 PlaneNormal = PlaneNormal1 12164 ELSE 12165 PRINT *,'PlaneNormal: Selecting master normal' 12166 PlaneNormal = -PlaneNormal 12167 END IF 12168 12169 PRINT *,'PlaneNormal selected:',PlaneNormal(:,1) 12170 12171 CALL ListAddConstRealArray( BParams,'Plane Projector Normal',& 12172 3,1,PlaneNormal ) 12173 DEALLOCATE( ElementNodes % x, ElementNodes % y, ElementNodes % z, Basis ) 12174 12175 PNormal => ListGetConstRealArray( BParams,'Plane Projector Normal',Found) 12176 END IF 12177 12178 Normal = Pnormal(1:3,1) 12179 CALL TangentDirections( Normal, Tangent, Tangent2 ) 12180 12181 IF(.FALSE.) THEN 12182 PRINT *,'Normal:',Normal 12183 PRINT *,'Tangent1:',Tangent 12184 PRINT *,'Tangent2:',Tangent2 12185 END IF 12186 12187 DO j=1,2 12188 IF( j == 1 ) THEN 12189 Bmesh => BMesh1 12190 ELSE 12191 BMesh => BMesh2 12192 END IF 12193 12194 DO i=1,BMesh % NumberOfNodes 12195 Coord(1) = BMesh % Nodes % x(i) 12196 Coord(2) = BMesh % Nodes % y(i) 12197 Coord(3) = BMesh % Nodes % z(i) 12198 12199 BMesh % Nodes % x(i) = SUM( Coord * Tangent ) 12200 IF( MeshDim == 3 ) THEN 12201 BMesh % Nodes % y(i) = SUM( Coord * Tangent2 ) 12202 ELSE 12203 BMesh % Nodes % y(i) = 0.0_dp 12204 END IF 12205 BMesh % Nodes % z(i) = SUM( Coord * Normal ) 12206 END DO 12207 12208 IF(.FALSE.) THEN 12209 PRINT *,'Range for mesh:',j 12210 PRINT *,'X:',MINVAL(BMesh % Nodes % x),MAXVAL(BMesh % Nodes % x) 12211 PRINT *,'Y:',MINVAL(BMesh % Nodes % y),MAXVAL(BMesh % Nodes % y) 12212 PRINT *,'Z:',MINVAL(BMesh % Nodes % z),MAXVAL(BMesh % Nodes % z) 12213 END IF 12214 END DO 12215 12216 Bmesh % MeshDim = 2 12217 12218 END SUBROUTINE PlaneInterfaceMeshes 12219 !------------------------------------------------------------------------------ 12220 12221 12222 12223 !--------------------------------------------------------------------------- 12224 !> Given a permutation map the (x,y,z) such that the projector can better 12225 !> be applied. E.g. if boundary has constant x, take that as the last coordinate. 12226 !--------------------------------------------------------------------------- 12227 SUBROUTINE MapInterfaceCoordinate(BMesh1, BMesh2, BParams ) 12228 !--------------------------------------------------------------------------- 12229 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 12230 TYPE(Valuelist_t), POINTER :: BParams 12231 !-------------------------------------------------------------------------- 12232 LOGICAL :: Found 12233 REAL(KIND=dp), POINTER CONTIG:: NodesX(:), NodesY(:), NodesZ(:), Wrk(:,:) 12234 INTEGER, POINTER :: CoordMap(:) 12235 INTEGER :: MeshNo 12236 TYPE(Mesh_t), POINTER :: BMesh 12237 12238 ! Perform coordinate mapping 12239 !------------------------------------------------------------ 12240 CoordMap => ListGetIntegerArray( BParams, & 12241 'Projector Coordinate Mapping',Found ) 12242 IF( .NOT. Found ) RETURN 12243 12244 CALL Info('MapInterfaceCoordinates','Performing coordinate mapping',Level=8) 12245 12246 IF ( SIZE( CoordMap ) /= 3 ) THEN 12247 WRITE( Message, * ) 'Inconsistent Coordinate Mapping: ', CoordMap 12248 CALL Error( 'MapInterfaceCoordinates', Message ) 12249 WRITE( Message, * ) 'Coordinate mapping should be a permutation of 1,2 and 3' 12250 CALL Fatal( 'MapInterfaceCoordinates', Message ) 12251 END IF 12252 12253 IF ( ALL( CoordMap(1:3) /= 1 ) .OR. ALL( CoordMap(1:3) /= 2 ) .OR. ALL( CoordMap(1:3) /= 3 ) ) THEN 12254 WRITE( Message, * ) 'Inconsistent Coordinate Mapping: ', CoordMap 12255 CALL Error( 'MapInterfaceCoordinates', Message ) 12256 WRITE( Message, * ) 'Coordinate mapping should be a permutation of 1,2 and 3' 12257 CALL Fatal( 'MapInterfaceCoordinates', Message ) 12258 END IF 12259 12260 DO MeshNo = 1,2 12261 IF( MeshNo == 1 ) THEN 12262 BMesh => BMesh1 12263 ELSE 12264 BMesh => BMesh2 12265 END IF 12266 12267 IF( CoordMap(1) == 1 ) THEN 12268 NodesX => BMesh % Nodes % x 12269 ELSE IF( CoordMap(1) == 2 ) THEN 12270 NodesX => BMesh % Nodes % y 12271 ELSE 12272 NodesX => BMesh % Nodes % z 12273 END IF 12274 12275 IF( CoordMap(2) == 1 ) THEN 12276 NodesY => BMesh % Nodes % x 12277 ELSE IF( CoordMap(2) == 2 ) THEN 12278 NodesY => BMesh % Nodes % y 12279 ELSE 12280 NodesY => BMesh % Nodes % z 12281 END IF 12282 12283 IF( CoordMap(3) == 1 ) THEN 12284 NodesZ => BMesh % Nodes % x 12285 ELSE IF( CoordMap(3) == 2 ) THEN 12286 NodesZ => BMesh % Nodes % y 12287 ELSE 12288 NodesZ => BMesh % Nodes % z 12289 END IF 12290 12291 BMesh % Nodes % x => NodesX 12292 BMesh % Nodes % y => NodesY 12293 BMesh % Nodes % z => NodesZ 12294 END DO 12295 12296 END SUBROUTINE MapInterfaceCoordinate 12297 12298 12299 ! Save projector, mainly a utility for debugging purposes 12300 !-------------------------------------------------------- 12301 SUBROUTINE SaveProjector(Projector,SaveRowSum,Prefix,InvPerm,Parallel) 12302 TYPE(Matrix_t), POINTER :: Projector 12303 LOGICAL :: SaveRowSum 12304 CHARACTER(LEN=*) :: Prefix 12305 INTEGER, POINTER, OPTIONAL :: InvPerm(:) 12306 LOGICAL, OPTIONAL :: Parallel 12307 12308 CHARACTER(LEN=MAX_NAME_LEN) :: Filename 12309 INTEGER :: i,j,ii,jj 12310 REAL(KIND=dp) :: rowsum, dia, val 12311 INTEGER, POINTER :: IntInvPerm(:) 12312 LOGICAL :: GlobalInds 12313 INTEGER, POINTER :: GlobalDofs(:) 12314 12315 IF(.NOT.ASSOCIATED(Projector)) RETURN 12316 12317 IF( PRESENT( InvPerm ) ) THEN 12318 IntInvPerm => InvPerm 12319 ELSE 12320 IntInvPerm => Projector % InvPerm 12321 END IF 12322 12323 GlobalInds = .FALSE. 12324 IF(ParEnv % PEs == 1 ) THEN 12325 FileName = TRIM(Prefix)//'.dat' 12326 ELSE 12327 FileName = TRIM(Prefix)//'_part'//& 12328 TRIM(I2S(ParEnv % MyPe))//'.dat' 12329 IF( PRESENT( Parallel ) ) GlobalInds = Parallel 12330 END IF 12331 12332 IF( GlobalInds ) THEN 12333 NULLIFY( GlobalDofs ) 12334 IF( ASSOCIATED( CurrentModel % Solver % Matrix ) ) THEN 12335 GlobalDofs => CurrentModel % Solver % Matrix % ParallelInfo % GlobalDofs 12336 END IF 12337 IF(.NOT. ASSOCIATED( GlobalDofs ) ) THEN 12338 CALL Info('SaveProjector','Cannot find GlobalDofs for Solver matrix') 12339 GlobalDofs => CurrentModel % Mesh % ParallelInfo % GlobalDofs 12340 END IF 12341 END IF 12342 12343 OPEN(1,FILE=FileName,STATUS='Unknown') 12344 DO i=1,projector % numberofrows 12345 IF( ASSOCIATED( IntInvPerm ) ) THEN 12346 ii = intinvperm(i) 12347 IF( ii == 0) THEN 12348 PRINT *,'Projector InvPerm is zero:',ParEnv % MyPe, i, ii 12349 CYCLE 12350 END IF 12351 ELSE 12352 ii = i 12353 END IF 12354 IF( GlobalInds ) THEN 12355 IF( ii > SIZE( GlobalDofs ) ) THEN 12356 PRINT *,'ParEnv % MyPe, Projecor invperm is larger than globaldofs',& 12357 ii, SIZE( GlobalDofs ), i, Projector % NumberOfRows 12358 CYCLE 12359 END IF 12360 ii = GlobalDofs(ii) 12361 END IF 12362 IF( ii == 0) THEN 12363 PRINT *,'Projector global InvPerm is zero:',ParEnv % MyPe, i, ii 12364 CYCLE 12365 END IF 12366 DO j=projector % rows(i), projector % rows(i+1)-1 12367 jj = projector % cols(j) 12368 IF( jj == 0) THEN 12369 PRINT *,'Projector col is zero:',ParEnv % MyPe, i, ii, j, jj 12370 CYCLE 12371 END IF 12372 val = projector % values(j) 12373 IF( GlobalInds ) THEN 12374 IF( jj > SIZE( GlobalDofs ) ) THEN 12375 PRINT *,'Projecor invperm is larger than globaldofs',& 12376 jj, SIZE( GlobalDofs ) 12377 CYCLE 12378 END IF 12379 jj = GlobalDofs(jj) 12380 IF( jj == 0) THEN 12381 PRINT *,'Projector global col is zero:',ParEnv % MyPe, i, ii, j, jj 12382 CYCLE 12383 END IF 12384 WRITE(1,*) ii,jj,ParEnv % MyPe, val 12385 ELSE 12386 WRITE(1,*) ii,jj,val 12387 END IF 12388 END DO 12389 END DO 12390 CLOSE(1) 12391 12392 IF( SaveRowSum ) THEN 12393 IF(ParEnv % PEs == 1 ) THEN 12394 FileName = TRIM(Prefix)//'_rsum.dat' 12395 ELSE 12396 FileName = TRIM(Prefix)//'_rsum_part'//& 12397 TRIM(I2S(ParEnv % MyPe))//'.dat' 12398 END IF 12399 12400 OPEN(1,FILE=FileName,STATUS='Unknown') 12401 DO i=1,projector % numberofrows 12402 IF( ASSOCIATED( IntInvPerm ) ) THEN 12403 ii = intinvperm(i) 12404 IF( ii == 0 ) CYCLE 12405 ELSE 12406 ii = i 12407 END IF 12408 rowsum = 0.0_dp 12409 dia = 0.0_dp 12410 12411 DO j=projector % rows(i), projector % rows(i+1)-1 12412 jj = projector % cols(j) 12413 val = projector % values(j) 12414 IF( ii == jj ) THEN 12415 dia = val 12416 END IF 12417 rowsum = rowsum + val 12418 END DO 12419 12420 IF( GlobalInds ) THEN 12421 ii = GlobalDofs(ii) 12422 WRITE(1,*) ii, i, & 12423 projector % rows(i+1)-projector % rows(i), ParEnv % MyPe, dia, rowsum 12424 ELSE 12425 WRITE(1,*) ii, i, & 12426 projector % rows(i+1)-projector % rows(i),dia, rowsum 12427 END IF 12428 12429 END DO 12430 CLOSE(1) 12431 END IF 12432 12433 END SUBROUTINE SaveProjector 12434 12435 12436 12437 ! Set projector abs(rowsum) to unity 12438 !-------------------------------------------------------- 12439 SUBROUTINE SetProjectorRowsum( Projector ) 12440 TYPE(Matrix_t), POINTER :: Projector 12441 12442 INTEGER :: i,j 12443 REAL(KIND=dp) :: rowsum 12444 12445 DO i=1,projector % numberofrows 12446 rowsum = 0.0_dp 12447 DO j=projector % rows(i), projector % rows(i+1)-1 12448 rowsum = rowsum + ABS( projector % values(j) ) 12449 END DO 12450 DO j=projector % rows(i), projector % rows(i+1)-1 12451 projector % values(j) = projector % values(j) / rowsum 12452 END DO 12453 END DO 12454 12455 END SUBROUTINE SetProjectorRowsum 12456 12457 12458!------------------------------------------------------------------------------ 12459!> Create a projector between Master and Target boundaries. 12460!> The projector may be a nodal projector x=Px or a weigted 12461!> Galerking projector such that Qx=Px. In the first case the projector 12462!> will be P and in the second case [Q-P]. 12463!------------------------------------------------------------------------------ 12464 FUNCTION PeriodicProjector( Model, Mesh, This, Trgt, cdim, & 12465 Galerkin ) RESULT(Projector) 12466!------------------------------------------------------------------------------ 12467 TYPE(Model_t) :: Model 12468 INTEGER :: This, Trgt 12469 INTEGER, OPTIONAL :: cdim 12470 TYPE(Mesh_t), TARGET :: Mesh 12471 TYPE(Matrix_t), POINTER :: Projector 12472 LOGICAL, OPTIONAL :: Galerkin 12473!------------------------------------------------------------------------------ 12474 INTEGER :: i,j,k,n,dim 12475 LOGICAL :: GotIt, UseQuadrantTree, Success, WeakProjector, & 12476 Rotational, AntiRotational, Sliding, AntiSliding, Repeating, AntiRepeating, & 12477 Discontinuous, NodalJump, Radial, AntiRadial, DoNodes, DoEdges, Axial, AntiAxial, & 12478 Flat, Plane, AntiPlane, LevelProj, FullCircle, Cylindrical, & 12479 ParallelNumbering, TimestepNumbering, EnforceOverlay, NormalProj 12480 LOGICAL, ALLOCATABLE :: MirrorNode(:) 12481 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2, PMesh 12482 TYPE(Nodes_t), POINTER :: MeshNodes, GaussNodes 12483 REAL(KIND=dp) :: NodeScale, EdgeScale, Radius, Coeff 12484 TYPE(ValueList_t), POINTER :: BC 12485 CHARACTER(LEN=MAX_NAME_LEN) :: FilePrefix 12486 TYPE(Variable_t), POINTER :: v 12487 12488 INTERFACE 12489 FUNCTION WeightedProjector(BMesh2, BMesh1, InvPerm2, InvPerm1, & 12490 UseQuadrantTree, Repeating, AntiRepeating, PeriodicScale, & 12491 NodalJump ) & 12492 RESULT ( Projector ) 12493 USE Types 12494 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2 12495 REAL(KIND=dp) :: PeriodicScale 12496 INTEGER, POINTER :: InvPerm1(:), InvPerm2(:) 12497 LOGICAL :: UseQuadrantTree, Repeating, AntiRepeating 12498 TYPE(Matrix_t), POINTER :: Projector 12499 LOGICAL :: NodalJump 12500 END FUNCTION WeightedProjector 12501 12502 12503 12504 END INTERFACE 12505!------------------------------------------------------------------------------ 12506 Projector => NULL() 12507 IF ( This <= 0 ) RETURN 12508 CALL Info('PeriodicProjector','Starting projector creation',Level=12) 12509 12510 DIM = CoordinateSystemDimension() 12511 12512 CALL ResetTimer('PeriodicProjector') 12513 12514 Projector => NULL() 12515 BC => Model % BCs(This) % Values 12516 PMesh => Mesh 12517 12518 12519 ! Whether to choose nodal or Galerkin projector is determined by an optional 12520 ! flag. The default is the nodal projector. 12521 !-------------------------------------------------------------------------- 12522 IF( PRESENT( Galerkin) ) THEN 12523 WeakProjector = Galerkin 12524 ELSE 12525 WeakProjector = ListGetLogical( BC, 'Galerkin Projector', GotIt ) 12526 END IF 12527 12528 ! If the boundary is discontinuous then we have the luxury of creating the projector 12529 ! very cheaply using the permutation vector. This does not need the target as the 12530 ! boundary is self-contained. 12531 !------------------------------------------------------------------------------------ 12532 IF( ListGetLogical( BC, 'Discontinuous Boundary', GotIt ) .AND. Mesh % DisContMesh )THEN 12533 IF( WeakProjector ) THEN 12534 Projector => WeightedProjectorDiscont( PMesh, This ) 12535 ELSE 12536 Projector => NodalProjectorDiscont( PMesh, This ) 12537 END IF 12538 12539 IF ( .NOT. ASSOCIATED( Projector ) ) RETURN 12540 GOTO 100 12541 END IF 12542 12543 IF ( Trgt <= 0 ) RETURN 12544 12545 ! Create the mesh projector, and if needed, also eliminate the ghost nodes 12546 ! There are two choices of projector: a nodal projector P in x=Px, and a 12547 ! Galerkin projector [Q-P] in Qx=Px. 12548 ! The projector is assumed to be either a rotational projector with no translation 12549 ! and rotation, or then generic one with possible coordinate mapping. 12550 !--------------------------------------------------------------------------------- 12551 CALL Info('PeriodicProjector','-----------------------------------------------------',Level=8) 12552 WRITE( Message,'(A,I0,A,I0)') 'Creating projector between BCs ',This,' and ',Trgt 12553 CALL Info('PeriodicProjector',Message,Level=8) 12554 12555 ! Create temporal mesh structures that are utilized when making the 12556 ! projector between "This" and "Trgt" boundary. 12557 !-------------------------------------------------------------------------- 12558 BMesh1 => AllocateMesh() 12559 BMesh2 => AllocateMesh() 12560 12561 CALL CreateInterfaceMeshes( Model, Mesh, This, Trgt, Bmesh1, BMesh2, & 12562 Success ) 12563 12564 IF(.NOT. Success) THEN 12565 CALL ReleaseMesh(BMesh1) 12566 CALL ReleaseMesh(BMesh2) 12567 RETURN 12568 END IF 12569 12570 ! If requested map the interface coordinate from (x,y,z) to any permutation of these. 12571 CALL MapInterfaceCoordinate( BMesh1, BMesh2, Model % BCs(This) % Values ) 12572 12573 NormalProj = ListGetLogical( BC,'Normal Projector',GotIt ) 12574 12575 ! Check whether to use (anti)rotational projector. 12576 ! We don't really know on which side the projector was called so 12577 ! let's check both sides. 12578 !-------------------------------------------------------------------------- 12579 Rotational = ListGetLogical( BC,'Rotational Projector',GotIt ) 12580 AntiRotational = ListGetLogical( BC,'Anti Rotational Projector',GotIt ) 12581 IF( AntiRotational ) Rotational = .TRUE. 12582 12583 Cylindrical = ListGetLogical( BC,'Cylindrical Projector',GotIt ) 12584 12585 Radial = ListGetLogical( BC,'Radial Projector',GotIt ) 12586 AntiRadial = ListGetLogical( BC,'Anti Radial Projector',GotIt ) 12587 IF( AntiRadial ) Radial = .TRUE. 12588 12589 Axial = ListGetLogical( BC,'Axial Projector',GotIt ) 12590 AntiAxial = ListGetLogical( BC,'Anti Axial Projector',GotIt ) 12591 IF( AntiAxial ) Axial = .TRUE. 12592 12593 Sliding = ListGetLogical( BC,'Sliding Projector',GotIt ) 12594 AntiSliding = ListGetLogical( BC,'Anti Sliding Projector',GotIt ) 12595 IF( AntiSliding ) Sliding = .TRUE. 12596 12597 Flat = ListGetLogical( BC,'Flat Projector',GotIt ) 12598 Plane = ListGetLogical( BC, 'Plane Projector',GotIt ) 12599 AntiPlane = ListGetLogical( BC,'Anti Plane Projector',GotIt ) 12600 IF( AntiPlane ) Plane = .TRUE. 12601 12602 IF( Radial ) CALL Info('PeriodicProjector','Enforcing > Radial Projector <',Level=12) 12603 IF( Axial ) CALL Info('PeriodicProjector','Enforcing > Axial Projector <',Level=12) 12604 IF( Sliding ) CALL Info('PeriodicProjector','Enforcing > Sliding Projector <',Level=12) 12605 IF( Cylindrical ) CALL Info('PeriodicProjector','Enforcing > Cylindrical Projector <',Level=12) 12606 IF( Rotational ) CALL Info('PeriodicProjector','Enforcing > Rotational Projector <',Level=12) 12607 IF( Flat ) CALL Info('PeriodicProjector','Enforcing > Flat Projector <',Level=12) 12608 IF( Plane ) CALL Info('PeriodicProjector','Enforcing > Plane Projector <',Level=12) 12609 12610 NodeScale = ListGetConstReal( BC, 'Mortar BC Scaling',GotIt) 12611 IF(.NOT.Gotit ) THEN 12612 IF( AntiRadial .OR. AntiPlane ) THEN 12613 NodeScale = -1._dp 12614 ELSE 12615 NodeScale = 1.0_dp 12616 END IF 12617 END IF 12618 EdgeScale = NodeScale 12619 12620 NodalJump = ListCheckPrefix( BC,'Mortar BC Coefficient') 12621 IF(.NOT. NodalJump ) THEN 12622 NodalJump = ListCheckPrefix( BC,'Mortar BC Resistivity') 12623 END IF 12624 12625 ! There are tailored projectors for simplified interfaces 12626 !------------------------------------------------------------- 12627 12628 ! Stride projector is obsolete and has been eliminated. 12629 IF( ListGetLogical( BC,'Stride Projector',GotIt) ) THEN 12630 CALL ListAddLogical( BC,'Level Projector',.TRUE.) 12631 CALL ListAddLogical( BC,'Level Projector Strong',.TRUE.) 12632 CALL Warn('PeriodicProjector','Enforcing > Level Projector < instead of old > Stride Projector <') 12633 END IF 12634 12635 LevelProj = ListGetLogical( BC,'Level Projector',GotIt) 12636 IF( Rotational .OR. Cylindrical .OR. Radial .OR. Flat .OR. Plane .OR. Axial ) THEN 12637 IF(.NOT. GotIt ) THEN 12638 CALL Info('PeriodicProjector','Enforcing > Level Projector = True < with dimensional reduction',& 12639 Level = 7 ) 12640 LevelProj = .TRUE. 12641 ELSE IF(.NOT. LevelProj ) THEN 12642 ! If we have dimensionally reduced projector but don't use LevelProjector 12643 ! to integrate over it, then ensure that the 3rd coordinate is set to zero. 12644 BMesh1 % Nodes % z = 0.0_dp 12645 BMesh2 % Nodes % z = 0.0_dp 12646 END IF 12647 END IF 12648 12649 12650 IF( LevelProj ) THEN 12651 IF( ListGetLogical( Model % Solver % Values,'Projector Skip Nodes',GotIt ) ) THEN 12652 DoNodes = .FALSE. 12653 ELSE 12654 IF( ListGetLogical( BC,'Projector Skip Nodes',GotIt) ) THEN 12655 DoNodes = .FALSE. 12656 ELSE 12657 DoNodes = ( Mesh % NumberOfNodes > 0 ) 12658 END IF 12659 END IF 12660 12661 IF( ListGetLogical( Model % Solver % Values,'Projector Skip Edges',GotIt ) ) THEN 12662 DoEdges = .FALSE. 12663 ELSE 12664 IF( ListGetLogical( BC,'Projector Skip Edges',GotIt) ) THEN 12665 DoEdges = .FALSE. 12666 ELSE 12667 ! We are conservative here since there may be edges in 2D which 12668 ! still cannot be used for creating the projector 12669 DoEdges = ( Mesh % NumberOfEdges > 0 .AND. & 12670 Mesh % MeshDim == 3 .AND. Dim == 3 ) 12671 12672 ! Ensure that there is no p-elements that made us think that we have edges 12673 ! Here we assume that if there is any p-element then also the 1st element is such 12674 IF( DoEdges ) THEN 12675 IF(isPelement(Mesh % Elements(1))) THEN 12676 DoEdges = .FALSE. 12677 CALL Info('PeriodicProjector','Edge projector will not be created for p-element mesh',Level=10) 12678 END IF 12679 END IF 12680 END IF 12681 END IF 12682 END IF 12683 12684 12685 ! If the interface is rotational move to (phi,z) plane and alter the phi coordinate 12686 ! so that the meshes coincide. 12687 ! Otherwise make the two meshes to coincide using rotation, translation & 12688 ! scaling. 12689 !--------------------------------------------------------------------------------- 12690 Radius = 1.0_dp 12691 FullCircle = .FALSE. 12692 EnforceOverlay = ListGetLogical( BC, 'Mortar BC enforce overlay', GotIt ) 12693 12694 IF( Rotational .OR. Cylindrical ) THEN 12695 CALL RotationalInterfaceMeshes( BMesh1, BMesh2, BC, Cylindrical, & 12696 Radius, FullCircle ) 12697 ELSE IF( Radial ) THEN 12698 CALL RadialInterfaceMeshes( BMesh1, BMesh2, BC ) 12699 ELSE IF( Flat ) THEN 12700 CALL FlatInterfaceMeshes( BMesh1, BMesh2, BC ) 12701 ELSE IF( Axial ) THEN 12702 CALL FlatInterfaceMeshes( BMesh1, BMesh2, BC ) 12703 CALL AxialInterfaceMeshes( BMesh1, BMesh2, BC ) 12704 ELSE IF( Plane ) THEN 12705 CALL PlaneInterfaceMeshes( BMesh1, BMesh2, BC ) 12706 ELSE IF( .NOT. ( Sliding .OR. NormalProj ) ) THEN 12707 IF( .NOT. GotIt ) EnforceOverlay = .TRUE. 12708 END IF 12709 12710 IF( EnforceOverlay ) THEN 12711 CALL OverlayIntefaceMeshes( BMesh1, BMesh2, BC ) 12712 END IF 12713 12714 Repeating = ( Rotational .OR. Sliding .OR. Axial ) .AND. .NOT. FullCircle 12715 AntiRepeating = .FALSE. 12716 IF( Repeating ) THEN 12717 AntiRepeating = ListGetLogical( BC,'Antisymmetric BC',GotIt ) 12718 IF( .NOT. GotIt ) THEN 12719 AntiRepeating = ( AntiRotational .OR. AntiSliding .OR. AntiAxial ) .AND. .NOT. FullCircle 12720 END IF 12721 END IF 12722 12723 IF( LevelProj ) THEN 12724 Projector => LevelProjector( BMesh1, BMesh2, Repeating, AntiRepeating, & 12725 FullCircle, Radius, DoNodes, DoEdges, & 12726 NodeScale, EdgeScale, BC ) 12727 ELSE 12728 IF( FullCircle ) THEN 12729 CALL Fatal('PeriodicProjector','A full circle cannot be dealt with the generic projector!') 12730 END IF 12731 12732 UseQuadrantTree = ListGetLogical(Model % Simulation,'Use Quadrant Tree',GotIt) 12733 IF( .NOT. GotIt ) UseQuadrantTree = .TRUE. 12734 12735 IF( NormalProj ) THEN 12736 Projector => NormalProjector( BMesh2, BMesh1, BC ) 12737 ELSE IF( WeakProjector ) THEN 12738 Projector => WeightedProjector( BMesh2, BMesh1, BMesh2 % InvPerm, BMesh1 % InvPerm, & 12739 UseQuadrantTree, Repeating, AntiRepeating, NodeScale, NodalJump ) 12740 ELSE 12741 Projector => NodalProjector( BMesh2, BMesh1, & 12742 UseQuadrantTree, Repeating, AntiRepeating ) 12743 END IF 12744 END IF 12745 12746 12747 ! Deallocate mesh structures: 12748 !--------------------------------------------------------------- 12749 BMesh1 % Projector => NULL() 12750 BMesh1 % Parent => NULL() 12751 !DEALLOCATE( BMesh1 % InvPerm ) 12752 CALL ReleaseMesh(BMesh1) 12753 12754 BMesh2 % Projector => NULL() 12755 BMesh2 % Parent => NULL() 12756 !DEALLOCATE( BMesh2 % InvPerm ) 12757 CALL ReleaseMesh(BMesh2) 12758 12759100 Projector % ProjectorBC = This 12760 12761 IF( ListGetLogical( BC,'Projector Set Rowsum',GotIt ) ) THEN 12762 CALL SetProjectorRowsum( Projector ) 12763 END IF 12764 12765 Coeff = ListGetConstReal( BC,'Projector Multiplier',GotIt) 12766 IF(.NOT. GotIt) Coeff = ListGetConstReal( Model % Simulation,& 12767 'Projector Multiplier',GotIt) 12768 IF( GotIt ) Projector % Values = Coeff * Projector % Values 12769 12770 IF( ListGetLogical( BC,'Save Projector',GotIt ) ) THEN 12771 ParallelNumbering = ListGetLogical( BC,'Save Projector Global Numbering',GotIt ) 12772 12773 FilePrefix = 'p'//TRIM(I2S(This)) 12774 12775 TimestepNumbering = ListGetLogical( BC,'Save Projector Timestep Numbering',GotIt ) 12776 IF( TimestepNumberIng ) THEN 12777 i = 0 12778 v => VariableGet( Mesh % Variables, 'timestep' ) 12779 IF( ASSOCIATED( v ) ) i = NINT( v % Values(1) ) 12780 WRITE( FilePrefix,'(A,I4.4)') TRIM(FilePrefix)//'_',i 12781 END IF 12782 12783 CALL SaveProjector( Projector, .TRUE.,TRIM(FilePrefix), & 12784 Parallel = ParallelNumbering) 12785 12786 ! Dual projector if it exists 12787 IF( ASSOCIATED( Projector % Ematrix ) ) THEN 12788 CALL SaveProjector( Projector % Ematrix, .TRUE.,'dual_'//TRIM(FilePrefix),& 12789 Projector % InvPerm, Parallel = ParallelNumbering) 12790 END IF 12791 12792 ! Biorthogonal projector if it exists 12793 IF( ASSOCIATED( Projector % Child ) ) THEN 12794 CALL SaveProjector( Projector % Child, .TRUE.,'biortho_'//TRIM(FilePrefix), & 12795 Projector % InvPerm, Parallel = ParallelNumbering ) 12796 END IF 12797 12798 IF( ListGetLogical( BC,'Save Projector And Stop',GotIt ) ) STOP EXIT_OK 12799 END IF 12800 12801 CALL CheckTimer('PeriodicProjector',Delete=.TRUE.) 12802 CALL Info('PeriodicProjector','Projector created, now exiting...',Level=8) 12803 12804!------------------------------------------------------------------------------ 12805 END FUNCTION PeriodicProjector 12806!------------------------------------------------------------------------------ 12807 12808 12809 12810 12811!------------------------------------------------------------------------------ 12812!> Create a permutation between two meshes such that we can solve a smaller system. 12813!------------------------------------------------------------------------------ 12814 SUBROUTINE PeriodicPermutation( Model, Mesh, This, Trgt, PerPerm, PerFlip ) 12815!------------------------------------------------------------------------------ 12816 TYPE(Model_t) :: Model 12817 INTEGER :: This, Trgt 12818 TYPE(Mesh_t), TARGET :: Mesh 12819 INTEGER, POINTER :: PerPerm(:) 12820 LOGICAL, POINTER :: PerFlip(:) 12821!------------------------------------------------------------------------------ 12822 INTEGER :: i,j,k,n,dim 12823 LOGICAL :: GotIt, Success, Rotational, AntiRotational, Sliding, AntiSliding, Repeating, & 12824 Radial, AntiRadial, DoNodes, DoEdges, Axial, AntiAxial, & 12825 Flat, Plane, AntiPlane, Cylindrical, ParallelNumbering, EnforceOverlay, & 12826 FullCircle, AntiPeriodic 12827 REAL(KIND=dp) :: Radius 12828 TYPE(Mesh_t), POINTER :: BMesh1, BMesh2, PMesh 12829 TYPE(ValueList_t), POINTER :: BC 12830 12831!------------------------------------------------------------------------------ 12832 IF ( This <= 0 .OR. Trgt <= 0 ) RETURN 12833 CALL Info('PeriodicPermutation','Starting periodic permutation creation',Level=12) 12834 12835 CALL ResetTimer('PeriodicPermutation') 12836 12837 DIM = CoordinateSystemDimension() 12838 BC => Model % BCs(This) % Values 12839 PMesh => Mesh 12840 12841 CALL Info('PeriodicPermutation','-----------------------------------------------------',Level=8) 12842 WRITE( Message,'(A,I0,A,I0)') 'Creating mapping between BCs ',This,' and ',Trgt 12843 CALL Info('PeriodicPermutation',Message,Level=8) 12844 12845 BMesh1 => AllocateMesh() 12846 BMesh2 => AllocateMesh() 12847 12848 CALL CreateInterfaceMeshes( Model, Mesh, This, Trgt, Bmesh1, BMesh2, Success ) 12849 12850 IF(.NOT. Success) THEN 12851 CALL ReleaseMesh(BMesh1) 12852 CALL ReleaseMesh(BMesh2) 12853 RETURN 12854 END IF 12855 12856 ! If requested map the interface coordinate from (x,y,z) to any permutation of these. 12857 CALL MapInterfaceCoordinate( BMesh1, BMesh2, Model % BCs(This) % Values ) 12858 12859 ! Lets check what kind of symmetry we have. 12860 Rotational = ListGetLogical( BC,'Rotational Projector',GotIt ) 12861 AntiRotational = ListGetLogical( BC,'Anti Rotational Projector',GotIt ) 12862 12863 Cylindrical = ListGetLogical( BC,'Cylindrical Projector',GotIt ) 12864 12865 Radial = ListGetLogical( BC,'Radial Projector',GotIt ) 12866 AntiRadial = ListGetLogical( BC,'Anti Radial Projector',GotIt ) 12867 IF( AntiRadial ) Radial = .TRUE. 12868 12869 Axial = ListGetLogical( BC,'Axial Projector',GotIt ) 12870 AntiAxial = ListGetLogical( BC,'Anti Axial Projector',GotIt ) 12871 IF( AntiAxial ) Axial = .TRUE. 12872 12873 Sliding = ListGetLogical( BC, 'Sliding Projector',GotIt ) 12874 AntiSliding = ListGetLogical( BC, 'Anti Sliding Projector',GotIt ) 12875 IF( AntiSliding ) Sliding = .TRUE. 12876 12877 Flat = ListGetLogical( BC, 'Flat Projector',GotIt ) 12878 Plane = ListGetLogical( BC, 'Plane Projector',GotIt ) 12879 AntiPlane = ListGetLogical( BC,'Anti Plane Projector',GotIt ) 12880 IF( AntiPlane ) Plane = .TRUE. 12881 12882 AntiPeriodic = ListGetLogical( BC,'Antisymmetric BC',GotIt ) 12883 IF( .NOT. GotIt ) THEN 12884 AntiPeriodic = ( AntiRotational .OR. AntiRadial .OR. AntiAxial .OR. AntiPlane ) 12885 END IF 12886 12887 IF( AntiPeriodic ) CALL Info('PeriodicPermutation','Assuming antiperiodic conforming projector',Level=8) 12888 12889 IF( Radial ) CALL Info('PeriodicPermutation','Enforcing > Radial Projector <',Level=12) 12890 IF( Axial ) CALL Info('PeriodicPermutation','Enforcing > Axial Projector <',Level=12) 12891 IF( Sliding ) CALL Info('PeriodicPermutation','Enforcing > Sliding Projector <',Level=12) 12892 IF( Cylindrical ) CALL Info('PeriodicPermutation','Enforcing > Cylindrical Projector <',Level=12) 12893 IF( Rotational ) CALL Info('PeriodicPermutation','Enforcing > Rotational Projector <',Level=12) 12894 IF( Flat ) CALL Info('PeriodicPermutation','Enforcing > Flat Projector <',Level=12) 12895 IF( Plane ) CALL Info('PeriodicPermutation','Enforcing > Plane Projector <',Level=12) 12896 12897 DoNodes = .TRUE. 12898 IF( ListGetLogical( Model % Solver % Values,'Projector Skip Nodes',GotIt ) ) DoNodes = .FALSE. 12899 IF( ListGetLogical( BC,'Projector Skip Nodes',GotIt) ) DoNodes = .FALSE. 12900 12901 ! We are conservative here since there may be edges in 2D which 12902 ! still cannot be used for creating the projector 12903 DoEdges = ( Mesh % NumberOfEdges > 0 .AND. Mesh % MeshDim == 3 .AND. Dim == 3 ) 12904 12905 ! Ensure that there is no p-elements that made us think that we have edges 12906 ! Here we assume that if there is any p-element then also the 1st element is such 12907 IF( DoEdges ) THEN 12908 IF(isPelement(Mesh % Elements(1))) THEN 12909 DoEdges = .FALSE. 12910 CALL Info('PeriodicPermutation','Edge projector will not be created for p-element mesh',Level=10) 12911 END IF 12912 END IF 12913 12914 IF( ListGetLogical( Model % Solver % Values,'Projector Skip Edges',GotIt ) ) DoEdges = .FALSE. 12915 IF( ListGetLogical( BC,'Projector Skip Edges',GotIt) ) DoEdges = .FALSE. 12916 12917 ! Make the two meshes to coincide using rotation, translation scaling. 12918 !--------------------------------------------------------------------------------- 12919 Radius = 1.0_dp 12920 EnforceOverlay = ListGetLogical( BC, 'Mortar BC enforce overlay', GotIt ) 12921 12922 IF( Rotational .OR. Cylindrical ) THEN 12923 CALL RotationalInterfaceMeshes( BMesh1, BMesh2, BC, Cylindrical, & 12924 Radius, FullCircle ) 12925 IF( FullCircle ) CALL Fatal('PeriodicPermutation','Cannot deal full circle with permutation') 12926 ELSE IF( Radial ) THEN 12927 CALL RadialInterfaceMeshes( BMesh1, BMesh2, BC ) 12928 ELSE IF( Flat ) THEN 12929 CALL FlatInterfaceMeshes( BMesh1, BMesh2, BC ) 12930 ELSE IF( Axial ) THEN 12931 CALL FlatInterfaceMeshes( BMesh1, BMesh2, BC ) 12932 CALL AxialInterfaceMeshes( BMesh1, BMesh2, BC ) 12933 ELSE IF( Plane ) THEN 12934 CALL PlaneInterfaceMeshes( BMesh1, BMesh2, BC ) 12935 ELSE IF( .NOT. Sliding ) THEN 12936 IF( .NOT. GotIt ) EnforceOverlay = .TRUE. 12937 END IF 12938 12939 IF( EnforceOverlay ) THEN 12940 CALL OverlayIntefaceMeshes( BMesh1, BMesh2, BC ) 12941 END IF 12942 12943 IF( DoNodes ) CALL ConformingNodePerm(PMesh, BMesh1, BMesh2, PerPerm, PerFlip, AntiPeriodic ) 12944 IF( DoEdges ) CALL ConformingEdgePerm(PMesh, BMesh1, BMesh2, PerPerm, PerFlip, AntiPeriodic ) 12945 12946 ! Deallocate mesh structures: 12947 !--------------------------------------------------------------- 12948 BMesh1 % Projector => NULL() 12949 BMesh1 % Parent => NULL() 12950 !DEALLOCATE( BMesh1 % InvPerm ) 12951 CALL ReleaseMesh(BMesh1) 12952 12953 BMesh2 % Projector => NULL() 12954 BMesh2 % Parent => NULL() 12955 !DEALLOCATE( BMesh2 % InvPerm ) 12956 CALL ReleaseMesh(BMesh2) 12957 12958 CALL CheckTimer('PeriodicPermutation',Delete=.TRUE.) 12959 12960 CALL Info('PeriodicPermutation','Periodic permutation created, now exiting...',Level=8) 12961 12962 12963!------------------------------------------------------------------------------ 12964 END SUBROUTINE PeriodicPermutation 12965!------------------------------------------------------------------------------ 12966 12967 12968 12969 !> If periodic BCs given, compute boundary mesh projector. 12970 !> If conforming BCs given, create permutation for elimination. 12971 !------------------------------------------------------ 12972 SUBROUTINE GeneratePeriodicProjectors( Model, Mesh ) 12973 TYPE(Model_t) :: Model 12974 TYPE(Mesh_t), POINTER :: Mesh 12975 INTEGER :: i,j,k,n,nocyclic,noconf,noflip,mini,maxi 12976 LOGICAL :: Found 12977 INTEGER, POINTER :: PerPerm(:) 12978 LOGICAL, POINTER :: PerFlip(:) 12979 12980 DO i = 1,Model % NumberOfBCs 12981 k = ListGetInteger( Model % BCs(i) % Values, 'Periodic BC', Found ) 12982 IF( Found ) THEN 12983 Model % BCs(i) % PMatrix => PeriodicProjector( Model, Mesh, i, k ) 12984 END IF 12985 END DO 12986 12987 IF( ListCheckPresentAnyBC( Model,'Conforming BC' ) ) THEN 12988 IF(.NOT. ASSOCIATED( Mesh % PeriodicPerm ) ) THEN 12989 n = Mesh % NumberOfNodes + Mesh % NumberOfEdges 12990 ALLOCATE( Mesh % PeriodicPerm(n) ) 12991 ALLOCATE( Mesh % PeriodicFlip(n) ) 12992 END IF 12993 PerPerm => Mesh % PeriodicPerm 12994 PerPerm = 0 12995 PerFlip => Mesh % PeriodicFlip 12996 PerFlip = .FALSE. 12997 DO i = 1,Model % NumberOfBCs 12998 k = ListGetInteger( Model % BCs(i) % Values, 'Conforming BC', Found ) 12999 IF( Found ) THEN 13000 CALL PeriodicPermutation( Model, Mesh, i, k, PerPerm, PerFlip ) 13001 END IF 13002 END DO 13003 nocyclic = 0 13004 noconf = 0 13005 mini = HUGE(mini) 13006 maxi = 0 13007 13008 DO i = 1,n 13009 j = PerPerm(i) 13010 IF( j > 0 ) THEN 13011 mini = MIN( mini, i ) 13012 maxi = MAX( maxi, i ) 13013 noconf = noconf + 1 13014 IF( PerPerm(j) > 0 ) THEN 13015 PerPerm(i) = PerPerm(j) 13016 IF( PerFlip(i) ) THEN 13017 PerFlip(i) = .NOT. PerFlip(j) 13018 ELSE 13019 PerFlip(i) = PerFlip(j) 13020 END IF 13021 nocyclic = nocyclic + 1 13022 END IF 13023 END IF 13024 END DO 13025 noflip = COUNT( PerFlip ) 13026 13027 CALL Info('GeneratePeriodicProjectors','Number of conforming maps: '//TRIM(I2S(noconf)),Level=8) 13028 IF(nocyclic>0) CALL Info('GeneratePeriodicProjectors','Number of cyclic maps: '//TRIM(I2S(nocyclic)),Level=8) 13029 IF(noflip>0) CALL Info('GeneratePeriodicProjectors','Number of periodic flips: '//TRIM(I2S(noflip)),Level=8) 13030 END IF 13031 13032 13033 END SUBROUTINE GeneratePeriodicProjectors 13034 13035 13036!------------------------------------------------------------------------------ 13037!> Create node distribution for a unit segment x \in [0,1] with n elements 13038!> i.e. n+1 nodes. There are different options for the type of distribution. 13039!> 1) Even distribution 13040!> 2) Geometric distribution 13041!> 3) Arbitrary distribution determined by a functional dependence 13042!> Note that the 3rd algorithm involves iterative solution of the nodal 13043!> positions and is therefore not bullet-proof. 13044!------------------------------------------------------------------------------ 13045 SUBROUTINE UnitSegmentDivision( w, n, ExtList ) 13046 REAL(KIND=dp), ALLOCATABLE :: w(:) 13047 INTEGER :: n 13048 TYPE(ValueList_t), POINTER, OPTIONAL :: ExtList 13049 !--------------------------------------------------------------- 13050 INTEGER :: i,J,iter,maxiter 13051 REAL(KIND=dp) :: q,r,h1,hn,minhn,err_eps,err,xn 13052 REAL(KIND=dp), ALLOCATABLE :: wold(:),h(:) 13053 LOGICAL :: Found, GotRatio, FunExtruded, Fun1D 13054 TYPE(Nodes_t) :: Nodes 13055 TYPE(ValueList_t), POINTER :: ParList 13056 13057 IF( PRESENT( ExtList ) ) THEN 13058 ParList => ExtList 13059 ELSE 13060 ParList => CurrentModel % Simulation 13061 END IF 13062 13063 FunExtruded = ListCheckPresent( ParList,'Extruded Mesh Density') 13064 Fun1D = ListCheckPresent( ParList,'1D Mesh Density') 13065 13066 ! Geometric division 13067 !--------------------------------------------------------------- 13068 q = ListGetConstReal( ParList,'Extruded Mesh Ratio',GotRatio) 13069 IF(.NOT. GotRatio) q = ListGetConstReal( ParList,'1D Mesh Ratio',GotRatio) 13070 IF( GotRatio ) THEN 13071 IF( ( ABS(ABS(q)-1.0_dp) < 1.0d-6 ) .OR. (q < 0.0_dp .AND. n <= 2) ) THEN 13072 CALL Info('UnitSegmentDivision','Assuming linear division as mesh ratio is close to one!') 13073 GotRatio = .FALSE. 13074 END IF 13075 END IF 13076 13077 IF( GotRatio ) THEN 13078 CALL Info('UnitSegmentDivision','Creating geometric division',Level=5) 13079 13080 IF( q > 0.0_dp ) THEN 13081 r = q**(1.0_dp/(n-1)) 13082 h1 = (1-r)/(1-r**n) 13083 w(0) = 0.0_dp 13084 DO i=1,n-1 13085 w(i) = h1 * (1-r**i)/(1-r) 13086 END DO 13087 w(n) = 1.0_dp 13088 ELSE 13089 q = -q 13090 IF(MODULO(n,2) == 0) THEN 13091 r = q**(1.0_dp/(n/2-1)) 13092 h1 = 0.5_dp*(1-r)/(1-r**(n/2)) 13093 ELSE 13094 r = q**(1.0_dp/((n-1)/2)) 13095 h1 = 0.5_dp / ( (1-r**((n+1)/2))/(1-r) - 0.5_dp * r**((n-1)/2)) 13096 END IF 13097 13098 w(0) = 0.0_dp 13099 DO i=1,n 13100 IF( i <= n/2 ) THEN 13101 w(i) = h1 * (1-r**i)/(1-r) 13102 ELSE 13103 w(i) = 1.0_dp - h1 * (1-r**(n-i))/(1-r) 13104 END IF 13105 END DO 13106 w(n) = 1.0_dp 13107 END IF 13108 13109 ! Generic division given by a function 13110 !----------------------------------------------------------------------- 13111 ELSE IF( FunExtruded .OR. Fun1D ) THEN 13112 13113 CALL Info('UnitSegmentDivision','Creating functional division',Level=5) 13114 13115 ! Initial guess is an even distribution 13116 DO i=0,n 13117 w(i) = i/(1._dp * n) 13118 END DO 13119 13120 ALLOCATE( wold(0:n),h(1:n)) 13121 wold = w 13122 13123 ! parameters that determine the accuracy of the iteration 13124 maxiter = 10000 13125 err_eps = 1.0d-6 13126 13127 ! Iterate to have a density distribution 13128 !--------------------------------------- 13129 DO iter=1,maxiter 13130 13131 minhn = HUGE(minhn) 13132 wold = w 13133 13134 ! Compute the point in the local mesh xn \in [0,1] 13135 ! and get the mesh parameter for that element from 13136 ! external function. 13137 !--------------------------------------------------- 13138 DO i=1,n 13139 xn = (w(i)+w(i-1))/2.0_dp 13140 minhn = MIN( minhn, w(i)-w(i-1) ) 13141 IF( FunExtruded ) THEN 13142 h(i) = ListGetFun( ParList,'Extruded Mesh Density', xn ) 13143 ELSE 13144 h(i) = ListGetFun( ParList,'1D Mesh Density', xn ) 13145 END IF 13146 IF( h(i) < EPSILON( h(i) ) ) THEN 13147 CALL Fatal('UnitSegmentDivision','Given value for h(i) was negative!') 13148 END IF 13149 END DO 13150 13151 ! Utilize symmetric Gauss-Seidel to compute the new positions, w(i). 13152 ! from a weigted mean of the desired elemental densities, h(i). 13153 ! Note that something more clever could be applied here. 13154 ! This was just a first implementation... 13155 !------------------------------------------------------------- 13156 DO i=1,n-1 13157 w(i) = (w(i-1)*h(i+1)+w(i+1)*h(i))/(h(i)+h(i+1)) 13158 END DO 13159 DO i=n-1,1,-1 13160 w(i) = (w(i-1)*h(i+1)+w(i+1)*h(i))/(h(i)+h(i+1)) 13161 END DO 13162 13163 ! If the maximum error is small compared to the minimum elementsize then exit 13164 !----------------------------------------------------------------------------- 13165 err = MAXVAL( ABS(w-wold))/minhn 13166 13167 IF( err < err_eps ) THEN 13168 WRITE( Message, '(A,I0,A)') 'Convergence obtained in ',iter,' iterations' 13169 CALL Info('UnitSegmentDivision', Message, Level=9 ) 13170 EXIT 13171 END IF 13172 END DO 13173 13174 IF( iter > maxiter ) THEN 13175 CALL Warn('UnitSegmentDivision','No convergence obtained for the unit mesh division!') 13176 END IF 13177 13178 ! Uniform division 13179 !-------------------------------------------------------------- 13180 ELSE 13181 CALL Info('UnitSegmentDivision','Creating linear division',Level=5) 13182 DO i=0,n 13183 w(i) = i/(1._dp * n) 13184 END DO 13185 END IF 13186 13187 CALL Info('UnitSegmentDivision','Mesh division ready',Level=9) 13188 DO i=0,n 13189 WRITE( Message, '(A,I0,A,ES12.4)') 'w(',i,') : ',w(i) 13190 CALL Info('UnitSegmentDivision', Message, Level=9 ) 13191 END DO 13192 13193 END SUBROUTINE UnitSegmentDivision 13194!------------------------------------------------------------------------------ 13195 13196 13197 13198!------------------------------------------------------------------------------ 13199!> Given a 2D mesh extrude it to be 3D. The 3rd coordinate will always 13200!> be at the interval [0,1]. Therefore the adaptation for different shapes 13201!> must be done with StructuredMeshMapper, or some similar utility. 13202!> The top and bottom surface will be assigned Boundary Condition tags 13203!> with indexes one larger than the maximum used on by the 2D mesh. 13204!------------------------------------------------------------------------------ 13205 FUNCTION MeshExtrude(Mesh_in, in_levels, ExtrudedMeshName) RESULT(Mesh_out) 13206!------------------------------------------------------------------------------ 13207 TYPE(Mesh_t), POINTER :: Mesh_in, Mesh_out 13208 INTEGER :: in_levels 13209 CHARACTER(LEN=MAX_NAME_LEN),INTENT(IN),OPTIONAL :: ExtrudedMeshName 13210 13211!------------------------------------------------------------------------------ 13212 INTEGER :: i,j,k,l,n,cnt,cnt101,ind(8),max_baseline_bid,max_bid,l_n,max_body,bcid,& 13213 ExtrudedCoord,dg_n,totalnumberofelements 13214 TYPE(ParallelInfo_t), POINTER :: PI_in, PI_out 13215 INTEGER :: nnodes,gnodes,gelements,ierr 13216 LOGICAL :: isParallel, Found, NeedEdges, PreserveBaseline, PreserveEdges, & 13217 Rotational, Rotate2Pi 13218 REAL(KIND=dp)::w,MinCoord,MaxCoord,CurrCoord 13219 REAL(KIND=dp), POINTER :: ActiveCoord(:) 13220 REAL(KIND=dp), ALLOCATABLE :: Wtable(:) 13221!------------------------------------------------------------------------------ 13222 13223 CALL Info('MeshExtrude','Creating '//TRIM(I2S(in_levels+1))//' extruded element layers',Level=10) 13224 13225 Mesh_out => AllocateMesh() 13226 13227 isParallel = ParEnv % PEs>1 13228 13229 ! Generate volume nodal points: 13230 ! ----------------------------- 13231 n=Mesh_in % NumberOfNodes 13232 nnodes=(in_levels+2)*n 13233 gnodes = nnodes 13234 13235 ALLOCATE( Mesh_out % Nodes % x(nnodes) ) 13236 ALLOCATE( Mesh_out % Nodes % y(nnodes) ) 13237 ALLOCATE( Mesh_out % Nodes % z(nnodes) ) 13238 13239 gelements = Mesh_in % NumberOfBulkElements 13240 13241 IF (isParallel) THEN 13242 PI_in => Mesh_in % ParallelInfo 13243 PI_out => Mesh_out % ParallelInfo 13244 13245 IF(.NOT. ASSOCIATED( PI_in ) ) CALL Fatal('MeshExtrude','PI_in not associated!') 13246 IF(.NOT. ASSOCIATED( PI_out ) ) CALL Fatal('MeshExtrude','PI_out not associated!') 13247 13248 ALLOCATE(PI_out % NeighbourList(nnodes)) 13249 ALLOCATE(PI_out % INTERFACE(nnodes)) 13250 ALLOCATE(PI_out % GlobalDOFs(nnodes)) 13251 13252 IF(.NOT. ASSOCIATED( PI_in % NeighbourList ) ) THEN 13253 CALL Fatal('MeshExtrude','Neighnours not associated!') 13254 END IF 13255 13256 ! For unset neighbours just set the this partition to be the only owner 13257 DO i=1,Mesh_in % NumberOfNodes 13258 IF (.NOT.ASSOCIATED(PI_in % NeighbourList(i) % Neighbours)) THEN 13259 CALL AllocateVector(PI_in % NeighbourList(i) % Neighbours,1) 13260 PI_in % NeighbourList(i) % Neighbours(1) = ParEnv % Mype 13261 END IF 13262 END DO 13263 13264 j=0 13265 DO i=1,Mesh_in % NumberOfNodes 13266 IF (PI_in % NeighbourList(i) % & 13267 Neighbours(1) == ParEnv % MyPE ) j=j+1 13268 END DO 13269 13270 CALL MPI_ALLREDUCE(j,gnodes,1, & 13271 MPI_INTEGER,MPI_SUM,ELMER_COMM_WORLD,ierr) 13272 13273 j=0 13274 DO i=1,Mesh_in % NumberOfBulkElements 13275 IF (Mesh_in % Elements(i) % PartIndex == ParEnv % MyPE) j=j+1 13276 END DO 13277 13278 CALL MPI_ALLREDUCE(j,gelements,1, & 13279 MPI_INTEGER,MPI_SUM,ELMER_COMM_WORLD,ierr) 13280 END IF 13281 13282 CALL Info('MeshExtrude','Number of extruded nodes: '//TRIM(I2S(nnodes)),Level=12) 13283 CALL Info('MeshExtrude','Number of extruded elements: '//TRIM(I2S(gelements)),Level=12) 13284 13285 13286 ! Create the division for the 1D unit mesh 13287 !-------------------------------------------- 13288 ALLOCATE( Wtable( 0: in_levels + 1 ) ) 13289 CALL UnitSegmentDivision( Wtable, in_levels + 1 ) 13290 13291 ExtrudedCoord = ListGetInteger( CurrentModel % Simulation,'Extruded Coordinate Index', & 13292 Found, minv=1,maxv=3 ) 13293 IF(.NOT. Found) ExtrudedCoord = 3 13294 13295 IF( ExtrudedCoord == 1 ) THEN 13296 ActiveCoord => Mesh_out % Nodes % x 13297 ELSE IF( ExtrudedCoord == 2 ) THEN 13298 ActiveCoord => Mesh_out % Nodes % y 13299 ELSE IF( ExtrudedCoord == 3 ) THEN 13300 ActiveCoord => Mesh_out % Nodes % z 13301 END IF 13302 13303 13304 PreserveBaseline = ListGetLogical( CurrentModel % Simulation,'Preserve Baseline',Found ) 13305 IF(.NOT. Found) PreserveBaseline = .FALSE. 13306 13307 PreserveEdges = ListGetLogical( CurrentModel % Simulation,'Preserve Edges',Found ) 13308 IF(.NOT. Found) PreserveEdges = .FALSE. 13309 13310 MinCoord = ListGetConstReal( CurrentModel % Simulation,'Extruded Min Coordinate',Found ) 13311 IF(.NOT. Found) MinCoord = 0.0_dp 13312 13313 MaxCoord = ListGetConstReal( CurrentModel % Simulation,'Extruded Max Coordinate',Found ) 13314 IF(.NOT. Found) MaxCoord = 1.0_dp 13315 13316 Rotate2Pi = .FALSE. 13317 Rotational = ListGetLogical( CurrentModel % Simulation,'Extruded Mesh Rotational',Found ) 13318 IF( Rotational ) THEN 13319 Rotate2Pi = ( ABS(ABS( MaxCoord-MinCoord ) - 2*PI) < 1.0d-3*PI ) 13320 IF( Rotate2Pi ) CALL Info('MeshExtrude','Perfoming full 2Pi rotation',Level=6) 13321 END IF 13322 13323 13324 cnt=0 13325 DO i=0,in_levels+1 13326 13327 ! If we rotate full 2Pi then we have natural closure! 13328 IF( Rotate2Pi ) THEN 13329 IF( i == in_levels+1) EXIT 13330 END IF 13331 13332 w = Wtable( i ) 13333 CurrCoord = w * MaxCoord + (1-w) * MinCoord 13334 13335 DO j=1,Mesh_in % NumberOfNodes 13336 13337 cnt = cnt + 1 13338 13339 Mesh_out % Nodes % x(cnt) = Mesh_in % Nodes % x(j) 13340 Mesh_out % Nodes % y(cnt) = Mesh_in % Nodes % y(j) 13341 Mesh_out % Nodes % z(cnt) = Mesh_in % Nodes % z(j) 13342 13343 ! Override the coordinate in the extruded direction by the value on the layer. 13344 ActiveCoord(cnt) = CurrCoord 13345 13346 IF (isParallel) THEN 13347 PI_out % INTERFACE(cnt) = PI_in % INTERFACE(j) 13348 13349 ALLOCATE(PI_out % NeighbourList(cnt) % Neighbours(& 13350 SIZE(PI_in % NeighbourList(j) % Neighbours))) 13351 PI_out % NeighbourList(cnt) % Neighbours = & 13352 PI_in % NeighbourList(j) % Neighbours 13353 13354 PI_out % GlobalDOFs(cnt) = PI_in % GlobalDOFs(j)+i*gnodes 13355 END IF 13356 13357 END DO 13358 END DO 13359 Mesh_out % NumberOfNodes=cnt 13360 13361 13362 IF( Rotational ) THEN 13363 BLOCK 13364 REAL(KIND=DP) :: x,y,z,r 13365 DO i=1,cnt 13366 x = Mesh_out % Nodes % x(i) 13367 y = Mesh_out % Nodes % y(i) 13368 z = Mesh_out % Nodes % z(i) 13369 13370 Mesh_out % Nodes % x(i) = COS(z) * x 13371 Mesh_out % Nodes % y(i) = SIN(z) * x 13372 Mesh_out % Nodes % z(i) = y 13373 END DO 13374 END BLOCK 13375 END IF 13376 13377 13378 ! Count 101 elements: 13379 ! (these require an extra layer) 13380 ! ------------------- 13381 13382 cnt101 = 0 13383 DO i=Mesh_in % NumberOfBulkElements+1, & 13384 Mesh_in % NumberOfBulkElements+Mesh_in % NumberOfBoundaryElements 13385 IF(Mesh_in % Elements(i) % TYPE % ElementCode == 101) cnt101 = cnt101+1 13386 END DO 13387 13388 n=SIZE(Mesh_in % Elements) 13389 13390 ! inquire total number of needed 13391 IF( Rotate2Pi ) THEN 13392 totalnumberofelements = n*(in_levels+1) + cnt101 13393 ELSE 13394 totalnumberofelements = n*(in_levels+3) + cnt101 13395 END IF 13396 13397 IF (PreserveBaseline) & 13398 totalnumberofelements = totalnumberofelements + Mesh_in % NumberOfBoundaryElements 13399 ALLOCATE(Mesh_out % Elements(totalnumberofelements)) 13400 13401 ! Generate volume bulk elements: 13402 ! ------------------------------ 13403 13404 Mesh_out % MaxElementNodes = 0 13405 13406 NeedEdges=.FALSE. 13407 n=Mesh_in % NumberOfNodes 13408 cnt=0; dg_n = 0 13409 DO i=0,in_levels 13410 DO j=1,Mesh_in % NumberOfBulkElements 13411 13412 cnt=cnt+1 13413 Mesh_out % Elements(cnt) = Mesh_in % Elements(j) 13414 13415 l_n=0 13416 DO k=1,Mesh_in % Elements(j) % TYPE % NumberOfNodes 13417 l_n=l_n+1 13418 ind(l_n) = Mesh_in % Elements(j) % NodeIndexes(k)+i*n 13419 END DO 13420 DO k=1,Mesh_in % Elements(j) % TYPE % NumberOfNodes 13421 l_n=l_n+1 13422 IF( Rotate2Pi .AND. i==in_levels ) THEN 13423 ind(l_n) = Mesh_in % Elements(j) % NodeIndexes(k) 13424 ELSE 13425 ind(l_n) = Mesh_in % Elements(j) % NodeIndexes(k)+(i+1)*n 13426 END IF 13427 END DO 13428 Mesh_out % Elements(cnt) % NDOFs = l_n 13429 Mesh_out % MaxElementNodes=MAX(Mesh_out % MaxElementNodes,l_n) 13430 13431 SELECT CASE(l_n) 13432 CASE(6) 13433 Mesh_out % Elements(cnt) % TYPE => GetElementType(706) 13434 CASE(8) 13435 Mesh_out % Elements(cnt) % TYPE => GetElementType(808) 13436 END SELECT 13437 13438 Mesh_out % Elements(cnt) % GElementIndex = & 13439 Mesh_in % Elements(j) % GelementIndex + gelements*i 13440 13441 Mesh_out % Elements(cnt) % ElementIndex = cnt 13442 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(l_n)) 13443 Mesh_out % Elements(cnt) % DGIndexes => NULL() 13444 Mesh_out % Elements(cnt) % NodeIndexes = ind(1:l_n) 13445 Mesh_out % Elements(cnt) % EdgeIndexes => NULL() 13446 Mesh_out % Elements(cnt) % FaceIndexes => NULL() 13447 Mesh_out % Elements(cnt) % BubbleIndexes => NULL() 13448 END DO 13449 END DO 13450 Mesh_out % NumberOfBulkElements=cnt 13451 13452 max_bid=0 13453 max_baseline_bid=0 13454 13455 ! include edges (see below) 13456 NeedEdges = (NeedEdges .OR. PreserveEdges) 13457 13458 ! ------------------------------------------------------- 13459 IF (PreserveBaseline) THEN 13460 DO j=1,Mesh_in % NumberOfBoundaryElements 13461 k = j + Mesh_in % NumberOfBulkElements 13462 13463 cnt=cnt+1 13464 13465 Mesh_out % Elements(cnt) = Mesh_in % Elements(k) 13466 13467 ALLOCATE(Mesh_out % Elements(cnt) % BoundaryInfo) 13468 Mesh_out % Elements(cnt) % BoundaryInfo = & 13469 Mesh_in % Elements(k) % BoundaryInfo 13470 13471 max_bid = MAX(max_bid, Mesh_in % Elements(k) % & 13472 BoundaryInfo % Constraint) 13473 13474 IF(ASSOCIATED(Mesh_in % Elements(k) % BoundaryInfo % Left)) THEN 13475 l=Mesh_in % Elements(k) % BoundaryInfo % Left % ElementIndex 13476 Mesh_out % Elements(cnt) % BoundaryInfo % Left => & 13477 Mesh_out % Elements(Mesh_in % NumberOfBulkElements*(in_levels+1)+ & 13478 (in_levels+2)*Mesh_in % NumberOfBoundaryElements+l) 13479 END IF 13480 IF(ASSOCIATED(Mesh_in % Elements(k) % BoundaryInfo % Right)) THEN 13481 l=Mesh_in % Elements(k) % BoundaryInfo % Right % ElementIndex 13482 Mesh_out % Elements(cnt) % BoundaryInfo % Right => & 13483 Mesh_out % Elements(Mesh_in % NumberOfBulkElements*(in_levels+1)+ & 13484 (in_levels+2)*Mesh_in % NumberOfBoundaryElements+l) 13485 END IF 13486 13487 IF(Mesh_in % Elements(k) % TYPE % ElementCode>=200) THEN 13488 Mesh_out % Elements(cnt) % NDOFs = 2 13489 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(2)) 13490 ind(1) = Mesh_in % Elements(k) % NodeIndexes(1) 13491 ind(2) = Mesh_in % Elements(k) % NodeIndexes(2) 13492 Mesh_out % Elements(cnt) % NodeIndexes = ind(1:2) 13493 Mesh_out % Elements(cnt) % TYPE => GetElementType(202) 13494 ELSE 13495 Mesh_out % Elements(cnt) % NDOFs = 1 13496 l=SIZE(Mesh_in % Elements(k) % NodeIndexes) 13497 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(l)) 13498 Mesh_out % Elements(cnt) % NodeIndexes = & 13499 Mesh_in % Elements(k) % NodeIndexes 13500 Mesh_out % Elements(cnt) % TYPE => & 13501 Mesh_in % Elements(k) % TYPE 13502 END IF 13503 Mesh_out % Elements(cnt) % DGDOFs = 0 13504 Mesh_out % Elements(cnt) % DGIndexes => NULL() 13505 Mesh_out % Elements(cnt) % ElementIndex = cnt 13506 Mesh_out % Elements(cnt) % PDefs => NULL() 13507 Mesh_out % Elements(cnt) % EdgeIndexes => NULL() 13508 Mesh_out % Elements(cnt) % FaceIndexes => NULL() 13509 Mesh_out % Elements(cnt) % BubbleIndexes => NULL() 13510 END DO 13511 13512 IF(isParallel) THEN 13513 j=max_bid 13514 CALL MPI_ALLREDUCE(j,max_bid,1, & 13515 MPI_INTEGER,MPI_MAX,ELMER_COMM_WORLD,ierr) 13516 END IF 13517 13518 max_baseline_bid = max_bid 13519 13520 END IF 13521 13522 13523 ! Add side boundaries with the bottom mesh boundary id's: 13524 ! (or shift ids if preserving the baseline boundary) 13525 ! ------------------------------------------------------- 13526 DO i=0,in_levels 13527 DO j=1,Mesh_in % NumberOfBoundaryElements 13528 k = j + Mesh_in % NumberOfBulkElements 13529 13530 cnt=cnt+1 13531 13532 Mesh_out % Elements(cnt) = Mesh_in % Elements(k) 13533 13534 ALLOCATE(Mesh_out % Elements(cnt) % BoundaryInfo) 13535 Mesh_out % Elements(cnt) % BoundaryInfo = & 13536 Mesh_in % Elements(k) % BoundaryInfo 13537 13538 Mesh_out % Elements(cnt) % BoundaryInfo % constraint = & 13539 Mesh_out % Elements(cnt) % BoundaryInfo % constraint + max_baseline_bid 13540 13541 max_bid = MAX(max_bid, max_baseline_bid + & 13542 Mesh_in % Elements(k) % BoundaryInfo % Constraint) 13543 13544 IF(ASSOCIATED(Mesh_in % Elements(k) % BoundaryInfo % Left)) THEN 13545 l=Mesh_in % Elements(k) % BoundaryInfo % Left % ElementIndex 13546 Mesh_out % Elements(cnt) % BoundaryInfo % Left => & 13547 Mesh_out % Elements(Mesh_in % NumberOfBulkElements*i+l) 13548 END IF 13549 IF(ASSOCIATED(Mesh_in % Elements(k) % BoundaryInfo % Right)) THEN 13550 l=Mesh_in % Elements(k) % BoundaryInfo % Right % ElementIndex 13551 Mesh_out % Elements(cnt) % BoundaryInfo % Right => & 13552 Mesh_out % Elements(Mesh_in % NumberOfBulkElements*i+l) 13553 END IF 13554 13555 IF(Mesh_in % Elements(k) % TYPE % ElementCode>=200) THEN 13556 Mesh_out % Elements(cnt) % NDOFs = 4 13557 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(4)) 13558 13559 ind(1) = Mesh_in % Elements(k) % NodeIndexes(1)+i*n 13560 ind(2) = Mesh_in % Elements(k) % NodeIndexes(2)+i*n 13561 13562 IF( Rotate2Pi .AND. i==in_levels ) THEN 13563 ind(3) = Mesh_in % Elements(k) % NodeIndexes(2) 13564 ind(4) = Mesh_in % Elements(k) % NodeIndexes(1) 13565 ELSE 13566 ind(3) = Mesh_in % Elements(k) % NodeIndexes(2)+(i+1)*n 13567 ind(4) = Mesh_in % Elements(k) % NodeIndexes(1)+(i+1)*n 13568 END IF 13569 Mesh_out % Elements(cnt) % NodeIndexes = ind(1:4) 13570 Mesh_out % Elements(cnt) % TYPE => GetElementType(404) 13571 ELSE 13572 Mesh_out % Elements(cnt) % NDOFs = 1 13573 l=SIZE(Mesh_in % Elements(k) % NodeIndexes) 13574 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(l)) 13575 Mesh_out % Elements(cnt) % NodeIndexes = & 13576 Mesh_in % Elements(k) % NodeIndexes+i*n 13577 Mesh_out % Elements(cnt) % TYPE => & 13578 Mesh_in % Elements(k) % TYPE 13579 END IF 13580 Mesh_out % Elements(cnt) % ElementIndex = cnt 13581 Mesh_out % Elements(cnt) % DGDOFs = 0 13582 Mesh_out % Elements(cnt) % DGIndexes => NULL() 13583 Mesh_out % Elements(cnt) % PDefs => NULL() 13584 Mesh_out % Elements(cnt) % EdgeIndexes => NULL() 13585 Mesh_out % Elements(cnt) % FaceIndexes => NULL() 13586 Mesh_out % Elements(cnt) % BubbleIndexes => NULL() 13587 END DO 13588 END DO 13589 13590 !Take care of extra 101 elements 13591 !------------------------------- 13592 13593 IF(cnt101 > 0) THEN 13594 DO j=1,Mesh_in % NumberOfBoundaryElements 13595 k = j + Mesh_in % NumberOfBulkElements 13596 13597 IF(Mesh_in % Elements(k) % TYPE % ElementCode /= 101) CYCLE 13598 cnt=cnt+1 13599 13600 Mesh_out % Elements(cnt) = Mesh_in % Elements(k) 13601 13602 ALLOCATE(Mesh_out % Elements(cnt) % BoundaryInfo) 13603 Mesh_out % Elements(cnt) % BoundaryInfo = & 13604 Mesh_in % Elements(k) % BoundaryInfo 13605 13606 Mesh_out % Elements(cnt) % BoundaryInfo % constraint = & 13607 Mesh_out % Elements(cnt) % BoundaryInfo % constraint + max_baseline_bid 13608 13609 max_bid = MAX(max_bid, max_baseline_bid + & 13610 Mesh_in % Elements(k) % BoundaryInfo % Constraint) 13611 13612 Mesh_out % Elements(cnt) % NDOFs = 1 13613 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(1)) 13614 Mesh_out % Elements(cnt) % NodeIndexes = & 13615 Mesh_in % Elements(k) % NodeIndexes+(in_levels+1)*n 13616 Mesh_out % Elements(cnt) % TYPE => & 13617 Mesh_in % Elements(k) % TYPE 13618 13619 Mesh_out % Elements(cnt) % ElementIndex = cnt 13620 Mesh_out % Elements(cnt) % DGDOFs = 0 13621 Mesh_out % Elements(cnt) % DGIndexes => NULL() 13622 Mesh_out % Elements(cnt) % PDefs => NULL() 13623 Mesh_out % Elements(cnt) % EdgeIndexes => NULL() 13624 Mesh_out % Elements(cnt) % FaceIndexes => NULL() 13625 Mesh_out % Elements(cnt) % BubbleIndexes => NULL() 13626 END DO 13627 END IF 13628 13629 IF(isParallel) THEN 13630 j=max_bid 13631 CALL MPI_ALLREDUCE(j,max_bid,1, & 13632 MPI_INTEGER,MPI_MAX,ELMER_COMM_WORLD,ierr) 13633 END IF 13634 13635 WRITE( Message,'(A,I0)') 'First Extruded BC set to: ',max_bid+1 13636 CALL Info('MeshExtrude',Message,Level=8) 13637 13638 max_body=0 13639 DO i=1,Mesh_in % NumberOfBulkElements 13640 max_body = MAX(max_body,Mesh_in % Elements(i) % Bodyid) 13641 END DO 13642 IF(isParallel) THEN 13643 j=max_body 13644 CALL MPI_ALLREDUCE(j,max_body,1, & 13645 MPI_INTEGER,MPI_MAX,ELMER_COMM_WORLD,ierr) 13646 END IF 13647 13648 WRITE( Message,'(A,I0)') 'Number of new BCs for layers: ',max_body 13649 CALL Info('MeshExtrude',Message,Level=8) 13650 13651 13652 ! Add start and finish planes except if we have a full rotational symmetry 13653 IF( .NOT. Rotate2Pi ) THEN 13654 13655 ! Add bottom boundary: 13656 ! -------------------- 13657 DO i=1,Mesh_in % NumberOfBulkElements 13658 cnt=cnt+1 13659 13660 Mesh_out % Elements(cnt) = Mesh_in % Elements(i) 13661 13662 l_n=Mesh_in % Elements(i) % TYPE % NumberOfNodes 13663 Mesh_out % Elements(cnt) % NDOFs = l_n 13664 13665 ALLOCATE(Mesh_out % Elements(cnt) % BoundaryInfo) 13666 Mesh_out % Elements(cnt) % BoundaryInfo % Left => & 13667 Mesh_out % Elements(i) 13668 Mesh_out % Elements(cnt) % BoundaryInfo % Right => NULL() 13669 13670 bcid = max_bid + Mesh_out % Elements(cnt) % BodyId 13671 Mesh_out % Elements(cnt) % BoundaryInfo % Constraint = bcid 13672 13673 Mesh_out % Elements(cnt) % BodyId = 0 13674 IF( bcid<=CurrentModel % NumberOfBCs) THEN 13675 j=ListGetInteger(CurrentModel % BCs(bcid) % Values,'Body Id',Found) 13676 IF(Found) Mesh_out % Elements(cnt) % BodyId=j 13677 END IF 13678 13679 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(l_n)) 13680 Mesh_out % Elements(cnt) % NodeIndexes = & 13681 Mesh_in % Elements(i) % NodeIndexes 13682 Mesh_out % Elements(cnt) % ElementIndex = cnt 13683 Mesh_out % Elements(cnt) % TYPE => & 13684 Mesh_in % Elements(i) % TYPE 13685 Mesh_out % Elements(cnt) % DGDOFs = 0 13686 Mesh_out % Elements(cnt) % DGIndexes => NULL() 13687 Mesh_out % Elements(cnt) % PDefs => NULL() 13688 Mesh_out % Elements(cnt) % EdgeIndexes => NULL() 13689 Mesh_out % Elements(cnt) % FaceIndexes => NULL() 13690 Mesh_out % Elements(cnt) % BubbleIndexes => NULL() 13691 END DO 13692 13693 ! Add top boundary: 13694 ! ----------------- 13695 DO i=1,Mesh_in % NumberOfBulkElements 13696 cnt=cnt+1 13697 13698 Mesh_out % Elements(cnt) = Mesh_in % Elements(i) 13699 13700 l_n=Mesh_in % Elements(i) % TYPE % NumberOfNodes 13701 Mesh_out % Elements(cnt) % NDOFs = l_n 13702 13703 ALLOCATE(Mesh_out % Elements(cnt) % BoundaryInfo) 13704 Mesh_out % Elements(cnt) % BoundaryInfo % Left => & 13705 Mesh_out % Elements(in_levels*Mesh_in % NumberOfBulkElements+i) 13706 Mesh_out % Elements(cnt) % BoundaryInfo % Right => NULL() 13707 13708 bcid = max_bid + Mesh_out % Elements(cnt) % BodyId + max_body 13709 Mesh_out % Elements(cnt) % BoundaryInfo % Constraint = bcid 13710 13711 Mesh_out % Elements(cnt) % BodyId = 0 13712 IF( bcid<=CurrentModel % NumberOfBCs) THEN 13713 j=ListGetInteger(CurrentModel % BCs(bcid) % Values,'Body Id',Found) 13714 IF(Found) Mesh_out % Elements(cnt) % BodyId=j 13715 END IF 13716 13717 ALLOCATE(Mesh_out % Elements(cnt) % NodeIndexes(l_n)) 13718 Mesh_out % Elements(cnt) % NodeIndexes = & 13719 Mesh_in % Elements(i) % NodeIndexes+(in_Levels+1)*n 13720 Mesh_out % Elements(cnt) % ElementIndex = cnt 13721 Mesh_out % Elements(cnt) % TYPE => & 13722 Mesh_in % Elements(i) % TYPE 13723 Mesh_out % Elements(cnt) % DGDOFs = 0 13724 Mesh_out % Elements(cnt) % DGIndexes => NULL() 13725 Mesh_out % Elements(cnt) % PDefs => NULL() 13726 Mesh_out % Elements(cnt) % EdgeIndexes => NULL() 13727 Mesh_out % Elements(cnt) % FaceIndexes => NULL() 13728 Mesh_out % Elements(cnt) % BubbleIndexes => NULL() 13729 END DO 13730 13731 END IF ! .NOT. Rotate2Pi 13732 13733 13734 Mesh_out % NumberOfBoundaryElements=cnt-Mesh_out % NumberOfBulkElements 13735 13736 Mesh_out % Name=Mesh_in % Name 13737 Mesh_out % DiscontMesh = Mesh_in % DiscontMesh 13738 Mesh_out % MaxElementDOFs = Mesh_out % MaxElementNodes 13739 Mesh_out % Stabilize = Mesh_in % Stabilize 13740 Mesh_out % MeshDim = 3 13741 CurrentModel % Dimension = 3 13742 13743 CALL PrepareMesh( CurrentModel, Mesh_out, isParallel ) 13744 13745 IF (PRESENT(ExtrudedMeshName)) THEN 13746 CALL WriteMeshToDisk(Mesh_out, ExtrudedMeshName) 13747 END IF 13748 13749 !------------------------------------------------------------------------------ 13750 END FUNCTION MeshExtrude 13751!------------------------------------------------------------------------------ 13752 13753 13754 13755!------------------------------------------------------------------------------ 13756!> Writes the mesh to disk. Note that this does not include the information 13757!> of shared nodes needed in parallel computation. This may be used for 13758!> debugging purposes and for adaptive solution, for example. 13759!------------------------------------------------------------------------------ 13760 SUBROUTINE WriteMeshToDisk( NewMesh, Path ) 13761!------------------------------------------------------------------------------ 13762 CHARACTER(LEN=*) :: Path 13763 TYPE(Mesh_t), POINTER :: NewMesh 13764!------------------------------------------------------------------------------ 13765 INTEGER :: i,j,k,MaxNodes,ElmCode,Parent1,Parent2 13766!------------------------------------------------------------------------------ 13767 13768 OPEN( 1,FILE=TRIM(Path) // '/mesh.header',STATUS='UNKNOWN' ) 13769 WRITE( 1,'(i0,x,i0,x,i0)' ) NewMesh % NumberOfNodes, & 13770 NewMesh % NumberOfBulkElements, NewMesh % NumberOfBoundaryElements 13771 13772 WRITE( 1,'(i0)' ) 2 13773 MaxNodes = 0 13774 ElmCode = 0 13775 DO i=1,NewMesh % NumberOfBoundaryElements 13776 k = i + NewMesh % NumberOfBulkElements 13777 IF ( NewMesh % Elements(k) % TYPE % NumberOfNodes > MaxNodes ) THEN 13778 ElmCode = NewMesh % Elements(k) % TYPE % ElementCode 13779 MaxNodes = NewMesh % Elements(k) % TYPE % NumberOfNodes 13780 END IF 13781 END DO 13782 WRITE( 1,'(i0,x,i0)' ) ElmCode,NewMesh % NumberOfBoundaryElements 13783 13784 MaxNodes = 0 13785 ElmCode = 0 13786 DO i=1,NewMesh % NumberOfBulkElements 13787 IF ( NewMesh % Elements(i) % TYPE % NumberOfNodes > MaxNodes ) THEN 13788 ElmCode = NewMesh % Elements(i) % TYPE % ElementCode 13789 MaxNodes = NewMesh % Elements(i) % TYPE % NumberOfNodes 13790 END IF 13791 END DO 13792 WRITE( 1,'(i0,x,i0)' ) ElmCode,NewMesh % NumberOfBulkElements 13793 CLOSE(1) 13794 13795 OPEN( 1,FILE=TRIM(Path) // '/mesh.nodes', STATUS='UNKNOWN' ) 13796 DO i=1,NewMesh % NumberOfNodes 13797 WRITE(1,'(i0,a,3e23.15)',ADVANCE='NO') i,' -1 ', & 13798 NewMesh % Nodes % x(i), & 13799 NewMesh % Nodes % y(i), NewMesh % Nodes % z(i) 13800 WRITE( 1,* ) '' 13801 END DO 13802 CLOSE(1) 13803 13804 OPEN( 1,FILE=TRIM(Path) // '/mesh.elements', STATUS='UNKNOWN' ) 13805 DO i=1,NewMesh % NumberOfBulkElements 13806 WRITE(1,'(3(i0,x))',ADVANCE='NO') i, & 13807 NewMesh % Elements(i) % BodyId, & 13808 NewMesh % Elements(i) % TYPE % ElementCode 13809 DO j=1,NewMesh % Elements(i) % TYPE % NumberOfNodes 13810 WRITE(1,'(i0,x)', ADVANCE='NO') & 13811 NewMesh % Elements(i) % NodeIndexes(j) 13812 END DO 13813 WRITE(1,*) '' 13814 END DO 13815 CLOSE(1) 13816 13817 OPEN( 1,FILE=TRIM(Path) // '/mesh.boundary', STATUS='UNKNOWN' ) 13818 DO i=1,NewMesh % NumberOfBoundaryElements 13819 k = i + NewMesh % NumberOfBulkElements 13820 parent1 = 0 13821 IF ( ASSOCIATED( NewMesh % Elements(k) % BoundaryInfo % Left ) ) & 13822 parent1 = NewMesh % Elements(k) % BoundaryInfo % Left % ElementIndex 13823 parent2 = 0 13824 IF ( ASSOCIATED( NewMesh % Elements(k) % BoundaryInfo % Right ) ) & 13825 parent2 = NewMesh % Elements(k) % BoundaryInfo % Right % ElementIndex 13826 WRITE(1,'(5(i0,x))',ADVANCE='NO') i, & 13827 NewMesh % Elements(k) % BoundaryInfo % Constraint, Parent1,Parent2,& 13828 NewMesh % Elements(k) % TYPE % ElementCode 13829 DO j=1,NewMesh % Elements(k) % TYPE % NumberOfNodes 13830 WRITE(1,'(i0,x)', ADVANCE='NO') & 13831 NewMesh % Elements(k) % NodeIndexes(j) 13832 END DO 13833 WRITE(1,*) '' 13834 END DO 13835 CLOSE(1) 13836!------------------------------------------------------------------------------ 13837 END SUBROUTINE WriteMeshToDisk 13838!------------------------------------------------------------------------------ 13839 13840!------------------------------------------------------------------------------ 13841!> Writes the mesh to disk, including detection of elementcodes and shared node 13842!> info necessary for parallel meshes. 13843!------------------------------------------------------------------------------ 13844 SUBROUTINE WriteMeshToDisk2(Model, NewMesh, Path, Partition ) 13845!------------------------------------------------------------------------------ 13846 USE Types 13847!------------------------------------------------------------------------------ 13848 TYPE(Model_t) :: Model 13849 TYPE(Mesh_t), POINTER :: NewMesh 13850 CHARACTER(LEN=*) :: Path 13851 INTEGER, OPTIONAL :: Partition 13852!------------------------------------------------------------------------------ 13853 INTEGER :: i,j,k,m,MaxNodes,ElmCode,NumElmCodes,ElmCodeList(100),ElmCodeCounts(100),& 13854 Parent1,Parent2, ElemID, nneigh, Constraint, meshBC, NumElements, NoShared 13855 INTEGER, POINTER :: BList(:) 13856 INTEGER, ALLOCATABLE :: ElementCodes(:) 13857 LOGICAL :: Parallel, WarnNoTarget, Found 13858 CHARACTER(LEN=MAX_NAME_LEN) :: headerFN, elementFN, nodeFN,& 13859 boundFN, sharedFN 13860!------------------------------------------------------------------------------ 13861 13862 IF(PRESENT(Partition)) THEN 13863 Parallel = .TRUE. 13864 WRITE(headerFN, '(A,I0,A)') '/part.',Partition+1,'.header' 13865 WRITE(elementFN, '(A,I0,A)') '/part.',Partition+1,'.elements' 13866 WRITE(nodeFN, '(A,I0,A)') '/part.',Partition+1,'.nodes' 13867 WRITE(boundFN, '(A,I0,A)') '/part.',Partition+1,'.boundary' 13868 WRITE(sharedFN, '(A,I0,A)') '/part.',Partition+1,'.shared' 13869 ELSE 13870 Parallel = .FALSE. 13871 headerFN = '/mesh.header' 13872 elementFN = '/mesh.elements' 13873 nodeFN = '/mesh.nodes' 13874 boundFN = '/mesh.boundary' 13875 END IF 13876 13877 !Info for header file 13878 13879 ElmCodeList = 0 !init array 13880 NumElmCodes = 0 13881 NumElements = NewMesh % NumberOfBoundaryElements + & 13882 NewMesh % NumberOfBulkElements 13883 ALLOCATE(ElementCodes(NumElements)) 13884 13885 !cycle to bring element code list into array-inquirable form 13886 DO i=1,NumElements 13887 ElementCodes(i) = NewMesh % Elements(i) % TYPE % ElementCode 13888 END DO 13889 13890 DO i=NumElements,1,-1 !this should give element codes increasing value, which appears to be 13891 !'standard' though I doubt it matters 13892 IF(ANY(ElmCodeList == ElementCodes(i))) CYCLE 13893 NumElmCodes = NumElmCodes + 1 13894 ElmCodeList(NumElmCodes) = ElementCodes(i) 13895 END DO 13896 13897 DO j=1,NumElmCodes 13898 ElmCodeCounts(j) = COUNT(ElementCodes == ElmCodeList(j)) 13899 END DO 13900 13901 !Write header file 13902 OPEN( 1,FILE=TRIM(Path) // headerFN,STATUS='UNKNOWN' ) 13903 WRITE( 1,'(i0,x,i0,x,i0)' ) NewMesh % NumberOfNodes, & 13904 NewMesh % NumberOfBulkElements, & 13905 NewMesh % NumberOfBoundaryElements 13906 13907 WRITE( 1,'(i0)' ) NumElmCodes 13908 DO j=1,NumElmCodes 13909 WRITE( 1,'(i0,x,i0,x)' ) ElmCodeList(j),ElmCodeCounts(j) 13910 END DO 13911 IF(Parallel) THEN !need number of shared nodes 13912 NoShared = 0 13913 DO i=1,NewMesh % NumberOfNodes 13914 IF(SIZE(NewMesh % ParallelInfo % NeighbourList(i) % & 13915 Neighbours) > 1) THEN 13916 NoShared = NoShared + 1 13917 END IF 13918 END DO 13919 WRITE( 1,'(i0,x,i0)') NoShared, 0 13920 END IF 13921 CLOSE(1) 13922 13923 !Write nodes file 13924 OPEN( 1,FILE=TRIM(Path) // nodeFN, STATUS='UNKNOWN' ) 13925 DO i=1,NewMesh % NumberOfNodes 13926 IF (Parallel) THEN 13927 WRITE(1,'(i0,x)', ADVANCE='NO') & 13928 NewMesh % ParallelInfo % GlobalDOFs(i) 13929 ELSE 13930 WRITE(1,'(i0,x)', ADVANCE='NO') i 13931 END IF 13932 WRITE(1,'(a,x,ES17.10,x,ES17.10,x,ES17.10)',ADVANCE='NO') & 13933 ' -1 ', NewMesh % Nodes % x(i), & 13934 NewMesh % Nodes % y(i), NewMesh % Nodes % z(i) 13935 WRITE( 1,* ) '' 13936 END DO 13937 CLOSE(1) 13938 13939 !Write elements file 13940 OPEN( 1,FILE=TRIM(Path) // elementFN, STATUS='UNKNOWN' ) 13941 DO i=1,NewMesh % NumberOfBulkElements 13942 IF(Parallel) THEN 13943 ElemID = NewMesh % Elements(i) % GElementIndex 13944 ELSE 13945 ElemID = i 13946 END IF 13947 WRITE(1,'(i0,x,i0,x,i0,x)',ADVANCE='NO') ElemID, & 13948 NewMesh % Elements(i) % BodyId, & 13949 NewMesh % Elements(i) % TYPE % ElementCode 13950 DO j=1,NewMesh % Elements(i) % TYPE % NumberOfNodes 13951 IF(Parallel) THEN 13952 m = NewMesh % ParallelInfo % GlobalDOFs(& 13953 NewMesh % Elements(i) % NodeIndexes(j)) 13954 ELSE 13955 m = NewMesh % Elements(i) % NodeIndexes(j) 13956 END IF 13957 WRITE(1,'(i0,x)', ADVANCE='NO') m 13958 END DO 13959 WRITE(1,*) '' 13960 END DO 13961 CLOSE(1) 13962 13963 !Write boundary file 13964 WarnNoTarget = .FALSE. 13965 OPEN( 1,FILE=TRIM(Path) // boundFN, STATUS='UNKNOWN' ) 13966 DO i=1,NewMesh % NumberOfBoundaryElements 13967 k = i + NewMesh % NumberOfBulkElements 13968 parent1 = 0 13969 IF ( ASSOCIATED( NewMesh % Elements(k) % BoundaryInfo % Left ) ) & 13970 parent1 = NewMesh % Elements(k) % BoundaryInfo % Left % ElementIndex 13971 parent2 = 0 13972 IF ( ASSOCIATED( NewMesh % Elements(k) % BoundaryInfo % Right ) ) & 13973 parent2 = NewMesh % Elements(k) % BoundaryInfo % Right % ElementIndex 13974 13975 IF(Parallel) THEN 13976 IF(parent1 /= 0) parent1 = NewMesh % Elements(parent1) % GElementIndex 13977 IF(parent2 /= 0) parent2 = NewMesh % Elements(parent2) % GElementIndex 13978 END IF 13979 13980 Constraint = NewMesh % Elements(k) % BoundaryInfo % Constraint 13981 BList => ListGetIntegerArray( Model % BCs(Constraint) % Values, & 13982 'Target Boundaries', Found ) 13983 IF(Found) THEN 13984 IF(SIZE(BList) > 1) THEN 13985 CALL WARN("WriteMeshToDisk2",& 13986 "A BC has more than one Target Boundary, SaveMesh output will not match input!") 13987 END IF 13988 meshBC = BList(1) 13989 ELSE 13990 WarnNoTarget = .TRUE. 13991 meshBC = Constraint 13992 END IF 13993 13994 !This meshBC stuff will *only* work if each BC has only 1 target boundary 13995 WRITE(1,'(i0,x,i0,x,i0,x,i0,x,i0)',ADVANCE='NO') i, & 13996 meshBC, Parent1,Parent2,& 13997 NewMesh % Elements(k) % TYPE % ElementCode 13998 DO j=1,NewMesh % Elements(k) % TYPE % NumberOfNodes 13999 IF(Parallel) THEN 14000 m = NewMesh % ParallelInfo % GlobalDOFs(& 14001 NewMesh % Elements(k) % NodeIndexes(j)) 14002 ELSE 14003 m = NewMesh % Elements(k) % NodeIndexes(j) 14004 END IF 14005 WRITE(1,'(x,i0)', ADVANCE='NO') m 14006 END DO 14007 WRITE(1,*) !blank write statement to create new line without extra space. 14008 END DO 14009 CLOSE(1) 14010 14011 IF(WarnNoTarget) THEN 14012 CALL WARN("WriteMeshToDisk2","Couldn't find a Target Boundary, assuming mapping to self") 14013 END IF 14014 14015 IF(.NOT. Parallel) RETURN 14016 14017 !Write .shared file 14018 !Need to create part.n.shared from Mesh % ParallelInfo % 14019 !NeighbourList % Neighbours. 14020 OPEN( 1,FILE=TRIM(Path) // sharedFN, STATUS='UNKNOWN' ) 14021 DO i=1,NewMesh % NumberOfNodes 14022 nneigh = SIZE(NewMesh % ParallelInfo % NeighbourList(i) % & 14023 Neighbours) 14024 IF(nneigh < 2) CYCLE 14025 WRITE(1,'(i0, x, i0, x)',ADVANCE='NO') & 14026 NewMesh % ParallelInfo % GlobalDOFs(i),nneigh 14027 DO j=1,nneigh 14028 WRITE(1,'(I0, x)',ADVANCE='NO') NewMesh % ParallelInfo %& 14029 NeighbourList(i) % Neighbours(j) + 1 14030 END DO 14031 WRITE( 1,* ) '' 14032 END DO 14033 CLOSE(1) 14034 14035 14036!------------------------------------------------------------------------------ 14037 END SUBROUTINE WriteMeshToDisk2 14038!------------------------------------------------------------------------------ 14039 14040 14041!------------------------------------------------------------------------------ 14042!> Writes the mesh to disk, including detection of elementcodes and shared node 14043!> info necessary for parallel meshes. 14044!------------------------------------------------------------------------------ 14045 SUBROUTINE WriteMeshToDiskPartitioned(Model, Mesh, Path, & 14046 ElementPart, NeighbourList ) 14047!------------------------------------------------------------------------------ 14048 USE Types 14049!------------------------------------------------------------------------------ 14050 TYPE(Model_t) :: Model 14051 TYPE(Mesh_t), POINTER :: Mesh 14052 CHARACTER(LEN=*) :: Path 14053 INTEGER, POINTER :: ElementPart(:) 14054 TYPE(NeighbourList_t),POINTER :: NeighbourList(:) 14055!------------------------------------------------------------------------------ 14056 TYPE(Element_t), POINTER :: Element 14057 INTEGER :: NoBoundaryElements, NoBulkElements, NoNodes, NoPartitions, Partition 14058 INTEGER :: i,j,k,m,MaxNodes,ElmCode,NumElmCodes,ElmCodeCounts(827),& 14059 Parent1,Parent2, ElemID, nneigh, Constraint, meshBC, NumElements, NoShared 14060 LOGICAL :: Found, Hit 14061 CHARACTER(LEN=MAX_NAME_LEN) :: DirectoryName, PrefixName 14062!------------------------------------------------------------------------------ 14063 14064 NoPartitions = MAXVAL( ElementPart ) 14065 NumElmCodes = 0 14066 NumElements = Mesh % NumberOfBoundaryElements + Mesh % NumberOfBulkElements 14067 14068 WRITE(DirectoryName, '(A,A,I0)') TRIM(PATH),'/partitioning.',NoPartitions 14069 CALL MakeDirectory( TRIM(DirectoryName) // CHAR(0) ) 14070 CALL Info('WriteMeshToDiskPartitioned','Writing parallel mesh to disk: '//TRIM(DirectoryName)) 14071 14072 14073 DO Partition = 1, NoPartitions 14074 14075 CALL Info('WriteMeshToDiskPartitioned','Writing piece to file: '//TRIM(I2S(Partition)),Level=12) 14076 14077 WRITE( PrefixName,'(A,A,I0)') TRIM(DirectoryName),'/part.',Partition 14078 14079 CALL Info('WriteMeshToDiskPartitioned','Write nodes file',Level=12) 14080 OPEN( 1,FILE=TRIM(PrefixName) // '.nodes', STATUS='UNKNOWN' ) 14081 NoNodes = 0 14082 DO i=1,Mesh % NumberOfNodes 14083 IF( ANY( NeighbourList(i) % Neighbours == Partition ) ) THEN 14084 WRITE(1,'(I0,x,I0,x,3ES17.10)') i,-1, & 14085 Mesh % Nodes % x(i), Mesh % Nodes % y(i), Mesh % Nodes % z(i) 14086 NoNodes = NoNodes + 1 14087 END IF 14088 END DO 14089 CLOSE(1) 14090 14091 14092 CALL Info('WriteMeshToDiskPartitioned','Write shared nodes file',Level=12) 14093 OPEN( 1,FILE=TRIM(PrefixName) // '.shared', STATUS='UNKNOWN' ) 14094 NoShared = 0 14095 DO i=1,Mesh % NumberOfNodes 14096 nneigh = SIZE( NeighbourList(i) % Neighbours ) 14097 IF( nneigh <= 1 ) CYCLE 14098 14099 IF( ANY( NeighbourList(i) % Neighbours == Partition ) ) THEN 14100 NoShared = NoShared + 1 14101 WRITE(1,'(i0, x, i0, x)',ADVANCE='NO') i,nneigh 14102 DO j=1,nneigh 14103 WRITE(1,'(I0, x)',ADVANCE='NO') NeighbourList(i) % Neighbours(j) 14104 END DO 14105 WRITE( 1,* ) '' 14106 END IF 14107 END DO 14108 CLOSE(1) 14109 14110 14111 CALL Info('WriteMeshToDiskPartitioned','Write elements file',Level=12) 14112 OPEN( 1,FILE=TRIM(PrefixName) // '.elements', STATUS='UNKNOWN' ) 14113 NoBulkElements = 0 14114 ElmCodeCounts = 0 14115 DO i=1,Mesh % NumberOfBulkElements 14116 IF( ElementPart(i) /= Partition ) CYCLE 14117 14118 Element => Mesh % Elements(i) 14119 WRITE(1,'(i0,x,i0,x,i0,x)',ADVANCE='NO') i, & 14120 Element % BodyId, Element % TYPE % ElementCode 14121 DO j=1,Element % TYPE % NumberOfNodes 14122 WRITE(1,'(i0,x)', ADVANCE='NO') Element % NodeIndexes(j) 14123 END DO 14124 WRITE(1,*) '' 14125 14126 ElmCode = Element % TYPE % ElementCode 14127 ElmCodeCounts( ElmCode ) = ElmCodeCounts( ElmCode ) + 1 14128 NoBulkElements = NoBulkElements + 1 14129 END DO 14130 CLOSE(1) 14131 14132 14133 CALL Info('WriteMeshToDiskPartitioned','Write boundary file',Level=12) 14134 OPEN( 1,FILE=TRIM(PrefixName) // '.boundary', STATUS='UNKNOWN' ) 14135 NoBoundaryElements = 0 14136 DO i=Mesh % NumberOfBulkElements +1 ,& 14137 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 14138 Element => Mesh % Elements(i) 14139 14140 parent1 = 0 14141 parent2 = 0 14142 Constraint = 0 14143 14144 IF( ASSOCIATED( Element % BoundaryInfo ) ) THEN 14145 IF ( ASSOCIATED( Element % BoundaryInfo % Left ) ) & 14146 parent1 = Element % BoundaryInfo % Left % ElementIndex 14147 IF ( ASSOCIATED( Element % BoundaryInfo % Right ) ) & 14148 parent2 = Element % BoundaryInfo % Right % ElementIndex 14149 Constraint = Element % BoundaryInfo % Constraint 14150 END IF 14151 14152 Hit = .FALSE. 14153 IF( parent1 > 0 ) THEN 14154 IF( ElementPart( parent1 ) == Partition ) Hit = .TRUE. 14155 END IF 14156 IF( parent2 > 0 ) THEN 14157 IF( ElementPart( parent2 ) == Partition ) Hit = .TRUE. 14158 END IF 14159 14160 IF( .NOT. Hit ) CYCLE 14161 14162 WRITE(1,'(i0,x,i0,x,i0,x,i0,x,i0)',ADVANCE='NO') i, & 14163 Constraint, Parent1, Parent2,& 14164 Element % TYPE % ElementCode 14165 DO j=1,Element % TYPE % NumberOfNodes 14166 WRITE(1,'(x,i0)', ADVANCE='NO') Element % NodeIndexes(j) 14167 END DO 14168 WRITE(1,*) 14169 14170 ElmCode = Element % TYPE % ElementCode 14171 ElmCodeCounts( ElmCode ) = ElmCodeCounts( ElmCode ) + 1 14172 NoBoundaryElements = NoBoundaryElements + 1 14173 END DO 14174 CLOSE(1) 14175 14176 14177 CALL Info('WriteMeshToDiskPartitioned','Write header file',Level=12) 14178 OPEN( 1,FILE=TRIM(PrefixName) // '.header',STATUS='UNKNOWN' ) 14179 NumElmCodes = COUNT( ElmCodeCounts > 0 ) 14180 WRITE( 1,'(i0,x,i0,x,i0)' ) NoNodes, & 14181 NoBulkElements, NoBoundaryElements 14182 WRITE( 1,'(i0)' ) NumElmCodes 14183 DO i=SIZE(ElmCodeCounts),1,-1 14184 IF( ElmCodeCounts(i) == 0 ) CYCLE 14185 WRITE( 1,'(i0,x,i0,x)' ) i,ElmCodeCounts(i) 14186 END DO 14187 WRITE( 1,'(i0,x,i0)') NoShared, 0 14188 CLOSE(1) 14189 14190 CALL Info('WriteMeshToDiskPartitioned','Done writing partition',Level=12) 14191 END DO 14192 14193 CALL Info('WriteMeshToDiskPartitioned','Done writing parallel mesh',Level=8) 14194 14195!------------------------------------------------------------------------------ 14196 END SUBROUTINE WriteMeshToDiskPartitioned 14197!------------------------------------------------------------------------------ 14198 14199 14200 14201 14202!------------------------------------------------------------------------------ 14203!> Generate element edge (faces in 3D) tables for given mesh. 14204!> Currently only for triangles and tetras. If mesh already 14205!> has edges do nothing. 14206!------------------------------------------------------------------------------ 14207 SUBROUTINE FindMeshEdges( Mesh, FindEdges) 14208!------------------------------------------------------------------------------ 14209 TYPE(Mesh_t) :: Mesh 14210 LOGICAL, OPTIONAL :: FindEdges 14211 14212 LOGICAL :: FindEdges3D 14213 INTEGER :: MeshDim, SpaceDim, MaxElemDim 14214 14215 IF(PRESENT(FindEdges)) THEN 14216 FindEdges3D = FindEdges 14217 ELSE 14218 FindEdges3D = .TRUE. 14219 END IF 14220 14221!------------------------------------------------------------------------------ 14222 14223 SpaceDim = CoordinateSystemDimension() 14224 MeshDim = Mesh % MeshDim 14225 14226 IF( MeshDim == 0 ) THEN 14227 CALL Fatal('FindMeshEdges','Mesh dimension is zero!') 14228 END IF 14229 IF( SpaceDim > MeshDim ) THEN 14230 CALL Warn('FindMeshEdges','Mesh dimension and space dimension differ: '& 14231 // TRIM(I2S(MeshDim))//' vs. '//TRIM(I2S(SpaceDim))) 14232 END IF 14233 14234 MaxElemDim = EnsureElemDim( MeshDim ) 14235 IF( MaxElemDim < MeshDim ) THEN 14236 CALL Warn('FindMeshEdges','Element dimension smaller than mesh dimension: '//& 14237 TRIM(I2S(MaxElemDim))//' vs '//TRIM(I2S(MeshDim))) 14238 END IF 14239 14240 14241 SELECT CASE( MaxElemDim ) 14242 14243 CASE(2) 14244 IF ( .NOT.ASSOCIATED( Mesh % Edges ) ) THEN 14245 CALL Info('FindMeshEdges','Determining edges in 2D mesh',Level=8) 14246 CALL FindMeshEdges2D( Mesh ) 14247 END IF 14248 14249 CASE(3) 14250 IF ( .NOT.ASSOCIATED( Mesh % Faces) ) THEN 14251 CALL Info('FindMeshEdges','Determining faces in 3D mesh',Level=8) 14252 CALL FindMeshFaces3D( Mesh ) 14253 END IF 14254 IF(FindEdges3D) THEN 14255 IF ( .NOT.ASSOCIATED( Mesh % Edges) ) THEN 14256 CALL Info('FindMeshEdges','Determining edges in 3D mesh',Level=8) 14257 CALL FindMeshEdges3D( Mesh ) 14258 END IF 14259 END IF 14260 END SELECT 14261 14262 CALL AssignConstraints() 14263 14264CONTAINS 14265 14266 ! Check that the element dimension really follows the mesh dimension 14267 ! The default is the MeshDim so we return immediately after that is 14268 ! confirmed. 14269 !-------------------------------------------------------------------- 14270 FUNCTION EnsureElemDim(MeshDim) RESULT (MaxElemDim) 14271 14272 INTEGER :: MeshDim, MaxElemDim 14273 INTEGER :: i,ElemDim, ElemCode 14274 14275 MaxElemDim = 0 14276 14277 DO i=1,Mesh % NumberOfBulkElements 14278 ElemCode = Mesh % Elements(i) % Type % ElementCode 14279 IF( ElemCode > 500 ) THEN 14280 ElemDim = 3 14281 ELSE IF( ElemCode > 300 ) THEN 14282 ElemDim = 2 14283 ELSE IF( ElemCode > 200 ) THEN 14284 ElemDim = 1 14285 END IF 14286 MaxElemDim = MAX( MaxElemDim, ElemDim ) 14287 IF( MaxElemDim == MeshDim ) EXIT 14288 END DO 14289 14290 END FUNCTION EnsureElemDim 14291 14292 14293 SUBROUTINE AssignConstraints() 14294 14295 INTEGER, POINTER :: FaceInd(:) 14296 INTEGER :: i,j,k,l,n,nd,nfound 14297 TYPE(Element_t), POINTER :: Element, Boundary, Face, Faces(:) 14298 14299 DO i=1,Mesh % NumberOfBoundaryElements 14300 Boundary => Mesh % Elements(Mesh % NumberOfBulkElements+i) 14301 14302 Element => Boundary % BoundaryInfo % Left 14303 IF (.NOT.ASSOCIATED(Element) ) & 14304 Element => Boundary % BoundaryInfo % Right 14305 IF (.NOT.ASSOCIATED(Element) ) CYCLE 14306 14307 SELECT CASE(Boundary % TYPE % DIMENSION) 14308 CASE(1) 14309 nd = Element % TYPE % NumberOfEdges 14310 Faces => Mesh % Edges 14311 FaceInd => Element % EdgeIndexes 14312 CASE(2) 14313 nd = Element % TYPE % NumberOfFaces 14314 Faces => Mesh % Faces 14315 FaceInd => Element % FaceIndexes 14316 CASE DEFAULT 14317 Faces => NULL() 14318 FaceInd => NULL() 14319 END SELECT 14320 14321 IF ( .NOT. ASSOCIATED(Faces) .OR. .NOT. ASSOCIATED(FaceInd) ) CYCLE 14322 14323 DO j=1,nd 14324 Face => Faces(FaceInd(j)) 14325 IF ( .NOT.ASSOCIATED(Face % TYPE,Boundary % TYPE) ) CYCLE 14326 14327 n = Boundary % TYPE % NumberOfNodes 14328 nfound = 0 14329 DO k=1,n 14330 DO l=1,n 14331 IF ( Boundary % NodeIndexes(k)==Face % NodeIndexes(l) ) & 14332 nfound = nfound+1 14333 END DO 14334 END DO 14335 IF ( nfound==n ) THEN 14336 Face % BoundaryInfo % Constraint = Boundary % BoundaryInfo % Constraint; EXIT 14337 END IF 14338 END DO 14339 END DO 14340 END SUBROUTINE AssignConstraints 14341!------------------------------------------------------------------------------ 14342 END SUBROUTINE FindMeshEdges 14343!------------------------------------------------------------------------------ 14344 14345!------------------------------------------------------------------------------ 14346!> Find 2D mesh edges. 14347!------------------------------------------------------------------------------ 14348 SUBROUTINE FindMeshEdges2D( Mesh, BulkMask ) 14349!------------------------------------------------------------------------------ 14350 TYPE(Mesh_t) :: Mesh 14351 LOGICAL, OPTIONAL :: BulkMask(:) 14352!------------------------------------------------------------------------------ 14353 TYPE HashEntry_t 14354 INTEGER :: Node,Edge 14355 TYPE(HashEntry_t), POINTER :: Next 14356 END TYPE HashEntry_t 14357 14358 TYPE HashTable_t 14359 TYPE(HashEntry_t), POINTER :: Head 14360 END TYPE HashTable_t 14361 14362 TYPE(HashTable_t), ALLOCATABLE :: HashTable(:) 14363 TYPE(HashEntry_t), POINTER :: HashPtr, HashPtr1 14364 14365 TYPE(Element_t), POINTER :: Element, Edges(:) 14366 14367 LOGICAL :: Found,Masked 14368 INTEGER :: i,j,k,n,NofEdges,Edge,Swap,Node1,Node2,istat,Degree,allocstat 14369!------------------------------------------------------------------------------ 14370! 14371! Initialize: 14372! ----------- 14373 CALL Info('FindMeshEdges2D','Allocating edge table of size: '& 14374 //TRIM(I2S(4*Mesh % NumberOfBulkElements)),Level=12) 14375 14376 Masked = PRESENT(BulkMask) 14377 14378 CALL AllocateVector( Mesh % Edges, 4*Mesh % NumberOfBulkElements ) 14379 Edges => Mesh % Edges 14380 14381 DO i=1,Mesh % NumberOfBulkElements 14382 IF(Masked) THEN 14383 IF(.NOT. BulkMask(i)) CYCLE 14384 END IF 14385 Element => Mesh % Elements(i) 14386 14387 IF ( .NOT. ASSOCIATED( Element % EdgeIndexes ) ) & 14388 CALL AllocateVector( Element % EdgeIndexes, Element % TYPE % NumberOfEdges ) 14389 Element % EdgeIndexes = 0 14390 END DO 14391 14392 CALL Info('FindMeshEdges2D','Creating hash table of size '& 14393 //TRIM(I2S(Mesh % NumberOfNodes))//' for node-to-node connectivity',Level=12) 14394 ALLOCATE( HashTable( Mesh % NumberOfNodes ) ) 14395 DO i=1,Mesh % NumberOfNodes 14396 NULLIFY( HashTable(i) % Head ) 14397 END DO 14398!------------------------------------------------------------------------------ 14399 14400! Loop over elements: 14401! ------------------- 14402 NofEdges = 0 14403 DO i=1,Mesh % NumberOfBulkElements 14404 14405 IF(Masked) THEN 14406 IF(.NOT. BulkMask(i)) CYCLE 14407 END IF 14408 14409 Element => Mesh % Elements(i) 14410 14411 SELECT CASE( Element % TYPE % ElementCode / 100 ) 14412 CASE(3) 14413 n = 3 14414 CASE(4) 14415 n = 4 14416 END SELECT 14417 14418! Loop over every edge of every element: 14419! -------------------------------------- 14420 DO k=1,n 14421! We use MIN(Node1,Node2) as the hash table key: 14422! ---------------------------------------------- 14423 Node1 = Element % NodeIndexes(k) 14424 IF ( k<n ) THEN 14425 Node2 = Element % NodeIndexes(k+1) 14426 ELSE 14427 Node2 = Element % NodeIndexes(1) 14428 END IF 14429 14430 IF ( Node2 < Node1 ) THEN 14431 Swap = Node1 14432 Node1 = Node2 14433 Node2 = Swap 14434 END IF 14435 14436! Look the edge from the hash table: 14437! ---------------------------------- 14438 HashPtr => HashTable(Node1) % Head 14439 Found = .FALSE. 14440 DO WHILE( ASSOCIATED( HashPtr ) ) 14441 IF ( HashPtr % Node == Node2 ) THEN 14442 Found = .TRUE. 14443 Edge = HashPtr % Edge 14444 EXIT 14445 END IF 14446 HashPtr => HashPtr % Next 14447 END DO 14448 14449! Existing edge, update structures: 14450! ---------------------------------- 14451 IF ( Found ) THEN 14452 Element % EdgeIndexes(k) = Edge 14453 Edges(Edge) % BoundaryInfo % Right => Element 14454 ELSE 14455 14456! Edge not yet there, create: 14457! --------------------------- 14458 NofEdges = NofEdges + 1 14459 Edge = NofEdges 14460 14461 Degree = Element % TYPE % BasisFunctionDegree 14462 14463 Edges(Edge) % ElementIndex = Edge 14464 CALL AllocateVector( Edges(Edge) % NodeIndexes, Degree+1) 14465 ALLOCATE( Edges(Edge) % BoundaryInfo, STAT=allocstat ) 14466 IF( allocstat /= 0 ) THEN 14467 CALL Fatal('FindMeshEdges2D','Allocation error for BoyndaryInfo alloction') 14468 END IF 14469 14470 Edges(Edge) % TYPE => GetElementType( 201+Degree, .FALSE. ) 14471 14472 Edges(Edge) % NodeIndexes(1) = Element % NodeIndexes(k) 14473 IF ( k < n ) THEN 14474 Edges(Edge) % NodeIndexes(2) = Element % NodeIndexes(k+1) 14475 ELSE 14476 Edges(Edge) % NodeIndexes(2) = Element % NodeIndexes(1) 14477 END IF 14478 14479 DO j=2,Degree 14480 Edges(Edge) % NodeIndexes(j+1) = Element % NodeIndexes(k+n+j-2) 14481 END DO 14482 14483 ! Create P element definitions if needed 14484 IF ( ASSOCIATED( Element % PDefs ) ) THEN 14485 CALL AllocatePDefinitions(Edges(Edge)) 14486 Edges(Edge) % PDefs % P = 0 14487 ELSE 14488 NULLIFY( Edges(Edge) % PDefs ) 14489 END IF 14490 14491 Edges(Edge) % NDofs = 0 14492 IF (Element % NDOFs /= 0 ) & 14493 Edges(Edge) % NDOFs = Edges(Edge) % TYPE % NumberOfNodes 14494 Edges(Edge) % BDOFs = 0 14495 Edges(Edge) % DGDOFs = 0 14496 NULLIFY( Edges(Edge) % EdgeIndexes ) 14497 NULLIFY( Edges(Edge) % FaceIndexes ) 14498 14499 Element % EdgeIndexes(k) = Edge 14500 14501 Edges(Edge) % BoundaryInfo % Left => Element 14502 NULLIFY( Edges(Edge) % BoundaryInfo % Right ) 14503 14504! Update the hash table: 14505! ---------------------- 14506 ALLOCATE( HashPtr, STAT=allocstat ) 14507 IF( allocstat /= 0 ) THEN 14508 CALL Fatal('FindMeshEdges2D','Allocation error for HashPtr alloction') 14509 END IF 14510 14511 HashPtr % Edge = Edge 14512 HashPtr % Node = Node2 14513 HashPtr % Next => HashTable(Node1) % Head 14514 HashTable(Node1) % Head => HashPtr 14515 END IF 14516 END DO 14517 END DO 14518 14519 Mesh % NumberOfEdges = NofEdges 14520 CALL Info('FindMeshEdges2D','Number of edges found: '//TRIM(I2S(NofEdges)),Level=10) 14521 14522! Delete the hash table: 14523! ---------------------- 14524 DO i=1,Mesh % NumberOfNodes 14525 HashPtr => HashTable(i) % Head 14526 DO WHILE( ASSOCIATED(HashPtr) ) 14527 HashPtr1 => HashPtr % Next 14528 DEALLOCATE( HashPtr ) 14529 HashPtr => HashPtr1 14530 END DO 14531 END DO 14532 DEALLOCATE( HashTable ) 14533 14534 CALL Info('FindMeshEdges2D','All done',Level=12) 14535 14536!------------------------------------------------------------------------------ 14537 END SUBROUTINE FindMeshEdges2D 14538!------------------------------------------------------------------------------ 14539 14540 14541!------------------------------------------------------------------------------ 14542!> Find 3D mesh faces. 14543!------------------------------------------------------------------------------ 14544 SUBROUTINE FindMeshFaces3D( Mesh, BulkMask) 14545 USE PElementMaps, ONLY : GetElementFaceMap 14546 USE PElementBase, ONLY : isPTetra 14547 14548 IMPLICIT NONE 14549!------------------------------------------------------------------------------ 14550 TYPE(Mesh_t) :: Mesh 14551 LOGICAL, OPTIONAL :: BulkMask(:) 14552!------------------------------------------------------------------------------ 14553 TYPE HashEntry_t 14554 INTEGER :: Node1,Node2,Face 14555 TYPE(HashEntry_t), POINTER :: Next 14556 END TYPE HashEntry_t 14557 14558 TYPE HashTable_t 14559 TYPE(HashEntry_t), POINTER :: Head 14560 END TYPE HashTable_t 14561 14562 TYPE(HashTable_t), ALLOCATABLE :: HashTable(:) 14563 TYPE(HashEntry_t), POINTER :: HashPtr, HashPtr1 14564 14565 LOGICAL :: Found,Masked 14566 INTEGER :: n1,n2,n3,n4 14567 INTEGER :: i,j,k,n,NofFaces,Face,Swap,Node1,Node2,Node3,istat,Degree 14568 14569 TYPE(Element_t), POINTER :: Element, Faces(:) 14570 14571 INTEGER, POINTER :: FaceMap(:,:) 14572 INTEGER, TARGET :: TetraFaceMap(4,6), BrickFaceMap(6,9), & 14573 WedgeFaceMap(5,8), PyramidFaceMap(5,8) 14574 14575 INTEGER :: nf(4) 14576!------------------------------------------------------------------------------ 14577 14578 CALL Info('FindMeshFaces3D','Finding mesh faces in 3D mesh',Level=12) 14579 14580 Masked = PRESENT(BulkMask) 14581 14582 TetraFaceMap(1,:) = [ 1, 2, 3, 5, 6, 7 ] 14583 TetraFaceMap(2,:) = [ 1, 2, 4, 5, 9, 8 ] 14584 TetraFaceMap(3,:) = [ 2, 3, 4, 6, 10, 9 ] 14585 TetraFaceMap(4,:) = [ 3, 1, 4, 7, 8,10 ] 14586 14587 WedgeFaceMap(1,:) = [ 1, 2, 3, 7, 8, 9, -1, -1 ] 14588 WedgeFaceMap(2,:) = [ 4, 5, 6, 10, 11, 12, -1, -1 ] 14589 WedgeFaceMap(3,:) = [ 1, 2, 5, 4, 7, 14, 10, 13 ] 14590 WedgeFaceMap(4,:) = [ 3, 2, 5, 6, 8, 14, 11, 15 ] 14591 WedgeFaceMap(5,:) = [ 3, 1, 4, 6, 9, 13, 12, 15 ] 14592 14593 PyramidFaceMap(1,:) = [ 1, 2, 3, 4, 6, 7, 8, 9 ] 14594 PyramidFaceMap(2,:) = [ 1, 2, 5, 6, 11, 10, -1, -1 ] 14595 PyramidFaceMap(3,:) = [ 2, 3, 5, 7, 12, 11, -1, -1 ] 14596 PyramidFaceMap(4,:) = [ 3, 4, 5, 8, 13, 12, -1, -1 ] 14597 PyramidFaceMap(5,:) = [ 4, 1, 5, 9, 10, 13, -1, -1 ] 14598 14599 BrickFaceMap(1,:) = [ 1, 2, 3, 4, 9, 10, 11, 12, 25 ] 14600 BrickFaceMap(2,:) = [ 5, 6, 7, 8, 17, 18, 19, 20, 26 ] 14601 BrickFaceMap(3,:) = [ 1, 2, 6, 5, 9, 14, 17, 13, 21 ] 14602 BrickFaceMap(4,:) = [ 2, 3, 7, 6, 10, 15, 18, 14, 22 ] 14603 BrickFaceMap(5,:) = [ 3, 4, 8, 7, 11, 16, 19, 15, 23 ] 14604 BrickFaceMap(6,:) = [ 4, 1, 5, 8, 12, 13, 20, 16, 24 ] 14605 14606! 14607! Initialize: 14608! ----------- 14609 IF(Masked) THEN 14610 CALL AllocateVector( Mesh % Faces, 6*COUNT(BulkMask), 'FindMeshFaces3D' ) 14611 ELSE 14612 CALL AllocateVector( Mesh % Faces, 6*Mesh % NumberOfBulkElements, 'FindMeshFaces3D' ) 14613 END IF 14614 Faces => Mesh % Faces 14615 14616 DO i=1,Mesh % NumberOfBulkElements 14617 IF(Masked) THEN 14618 IF(.NOT. BulkMask(i)) CYCLE 14619 END IF 14620 Element => Mesh % Elements(i) 14621 IF ( .NOT. ASSOCIATED( Element % FaceIndexes ) ) & 14622 CALL AllocateVector(Element % FaceIndexes, Element % TYPE % NumberOfFaces ) 14623 Element % FaceIndexes = 0 14624 END DO 14625 14626 ALLOCATE( HashTable( Mesh % NumberOfNodes ) ) 14627 DO i=1,Mesh % NumberOfNodes 14628 NULLIFY( HashTable(i) % Head ) 14629 END DO 14630!------------------------------------------------------------------------------ 14631 14632! Loop over elements: 14633! ------------------- 14634 NofFaces = 0 14635 DO i=1,Mesh % NumberOfBulkElements 14636 IF(Masked) THEN 14637 IF(.NOT. BulkMask(i)) CYCLE 14638 END IF 14639 14640 Element => Mesh % Elements(i) 14641 14642 ! For P elements mappings are different 14643 IF ( ASSOCIATED(Element % PDefs) ) THEN 14644 CALL GetElementFaceMap(Element, FaceMap) 14645 n = Element % TYPE % NumberOfFaces 14646 ELSE 14647 SELECT CASE( Element % TYPE % ElementCode / 100 ) 14648 CASE(5) 14649 n = 4 14650 FaceMap => TetraFaceMap 14651 CASE(6) 14652 n = 5 14653 FaceMap => PyramidFaceMap 14654 CASE(7) 14655 n = 5 14656 FaceMap => WedgeFaceMap 14657 CASE(8) 14658 n = 6 14659 FaceMap => BrickFaceMap 14660 CASE DEFAULT 14661 CYCLE 14662 ! WRITE(Message,*) 'Element type',Element % Type % ElementCode,'not implemented.' 14663 ! CALL Fatal('FindMeshFaces',Message) 14664 END SELECT 14665 END IF 14666 14667! Loop over every face of every element: 14668! -------------------------------------- 14669 DO k=1,n 14670 14671 14672! We use MIN(Node1,Node2,Node3) as the hash table key: 14673! --------------------------------------------------- 14674 SELECT CASE( Element % TYPE % ElementCode / 100 ) 14675 CASE(5) 14676! 14677! Tetras: 14678! ======= 14679 nf(1:3) = Element % NodeIndexes(FaceMap(k,1:3)) 14680 CALL sort( 3, nf ) 14681 14682 CASE(6) 14683! 14684! Pyramids: 14685! ========= 14686 IF ( k == 1 ) THEN 14687 nf(1:4) = Element % NodeIndexes(FaceMap(k,1:4)) 14688 CALL sort( 4, nf ) 14689 ELSE 14690 nf(1:3) = Element % NodeIndexes(FaceMap(k,1:3)) 14691 CALL sort( 3, nf ) 14692 END IF 14693 14694 CASE(7) 14695! 14696! Wedges: 14697! ======= 14698 IF ( k <= 2 ) THEN 14699 nf(1:3) = Element % NodeIndexes(FaceMap(k,1:3)) 14700 CALL sort( 3, nf ) 14701 ELSE 14702 nf(1:4) = Element % NodeIndexes(FaceMap(k,1:4)) 14703 CALL sort( 4, nf ) 14704 END IF 14705 14706 CASE(8) 14707! 14708! Bricks: 14709! ======= 14710 nf(1:4) = Element % NodeIndexes(FaceMap(k,1:4)) 14711 CALL sort( 4, nf ) 14712 14713 CASE DEFAULT 14714 WRITE(Message,*) 'Element type',Element % TYPE % ElementCode,'not implemented.' 14715 CALL Fatal('FindMeshFaces',Message) 14716 END SELECT 14717 14718 Node1 = nf(1) 14719 Node2 = nf(2) 14720 Node3 = nf(3) 14721 14722! Look the face from the hash table: 14723! ---------------------------------- 14724 HashPtr => HashTable(Node1) % Head 14725 Found = .FALSE. 14726 DO WHILE( ASSOCIATED( HashPtr ) ) 14727 IF ( HashPtr % Node1 == Node2 .AND. HashPtr % Node2 == Node3) THEN 14728 Found = .TRUE. 14729 Face = HashPtr % Face 14730 EXIT 14731 END IF 14732 HashPtr => HashPtr % Next 14733 END DO 14734 14735! Existing face, update structures: 14736! ---------------------------------- 14737 IF ( Found ) THEN 14738 Element % FaceIndexes(k) = Face 14739 Faces(Face) % BoundaryInfo % Right => Element 14740 ELSE 14741 14742! Face not yet there, create: 14743! --------------------------- 14744 NofFaces = NofFaces + 1 14745 Face = NofFaces 14746 Faces(Face) % ElementIndex = Face 14747 14748 Degree = Element % TYPE % BasisFunctionDegree 14749 14750 14751 SELECT CASE( Element % TYPE % ElementCode / 100 ) 14752 CASE(5) 14753 ! 14754 ! for tetras: 14755 ! ----------- 14756 SELECT CASE( Degree ) 14757 CASE(1) 14758 n1 = 3 14759 CASE(2) 14760 n1 = 6 14761 CASE(3) 14762 n1 = 10 14763 END SELECT 14764 14765 Faces(Face) % TYPE => GetElementType( 300+n1, .FALSE. ) 14766 14767 CASE(6) 14768 14769 ! Pyramids ( 605 and 613 supported ) 14770 ! ------------------------------- 14771 IF ( k == 1 ) THEN 14772 n1 = Degree * 4 14773 Faces(Face) % TYPE => GetElementType( 400+n1, .FALSE. ) 14774 ELSE 14775 n1 = Degree * 3 14776 Faces(Face) % TYPE => GetElementType( 300+n1, .FALSE. ) 14777 END IF 14778 14779 CASE(7) 14780 14781 ! for wedges, 706 and 715 supported: 14782 ! ------------------------------- 14783 IF ( k <= 2 ) THEN 14784 n1 = Degree * 3 14785 Faces(Face) % TYPE => GetElementType( 300+n1, .FALSE. ) 14786 ELSE 14787 n1 = Degree * 4 14788 Faces(Face) % TYPE => GetElementType( 400+n1, .FALSE. ) 14789 END IF 14790 14791 14792 CASE(8) 14793 ! 14794 ! for bricks: 14795 ! ----------- 14796 SELECT CASE( Element % TYPE % NumberOfNodes ) 14797 CASE(8) 14798 n1 = 4 14799 CASE(20) 14800 n1 = 8 14801 CASE(27) 14802 n1 = 9 14803 END SELECT 14804 14805 Faces(Face) % TYPE => GetElementType( 400+n1, .FALSE.) 14806 14807 CASE DEFAULT 14808 WRITE(Message,*) 'Element type',Element % TYPE % ElementCode,'not implemented.' 14809 CALL Fatal('FindMeshFaces',Message) 14810 14811 END SELECT 14812 14813 ! Allocate p structures for p elements 14814 IF ( ASSOCIATED( Element % PDefs ) ) THEN 14815 CALL AllocatePDefinitions(Faces(Face)) 14816 Faces(Face) % PDefs % P = 0 14817 ELSE 14818 NULLIFY( Faces(Face) % PDefs ) 14819 END IF 14820 14821 Faces(Face) % NDOFs = 0 14822 IF (Element % NDOFs /= 0 ) & 14823 Faces(Face) % NDOFs = Faces(Face) % TYPE % NumberOfNodes 14824 Faces(Face) % BDOFs = 0 14825 Faces(Face) % DGDOFs = 0 14826 Faces(Face) % EdgeIndexes => NULL() 14827 Faces(Face) % FaceIndexes => NULL() 14828 14829 CALL AllocateVector( Faces(Face) % NodeIndexes,n1 ) 14830 DO n2=1,n1 14831 Faces(Face) % NodeIndexes(n2) = & 14832 Element % NodeIndexes(FaceMap(k,n2)) 14833 END DO 14834 14835 Element % FaceIndexes(k) = Face 14836 14837 ALLOCATE( Faces(Face) % BoundaryInfo ) 14838 Faces(Face) % BoundaryInfo % Left => Element 14839 NULLIFY( Faces(Face) % BoundaryInfo % Right ) 14840 14841! Update the hash table: 14842! ---------------------- 14843 ALLOCATE( HashPtr ) 14844 HashPtr % Face = Face 14845 HashPtr % Node1 = Node2 14846 HashPtr % Node2 = Node3 14847 HashPtr % Next => HashTable(Node1) % Head 14848 HashTable(Node1) % Head => HashPtr 14849 END IF 14850 END DO 14851 END DO 14852 14853 Mesh % NumberOfFaces = NofFaces 14854 CALL Info('FindMeshFaces3D','Number of faces found: '//TRIM(I2S(NofFaces)),Level=10) 14855 14856! Delete the hash table: 14857! ---------------------- 14858 DO i=1,Mesh % NumberOfNodes 14859 HashPtr => HashTable(i) % Head 14860 DO WHILE( ASSOCIATED(HashPtr) ) 14861 HashPtr1 => HashPtr % Next 14862 DEALLOCATE( HashPtr ) 14863 HashPtr => HashPtr1 14864 END DO 14865 END DO 14866 DEALLOCATE( HashTable ) 14867 14868 CALL Info('FindMeshFaces3D','All done',Level=12) 14869!------------------------------------------------------------------------------ 14870 END SUBROUTINE FindMeshFaces3D 14871!------------------------------------------------------------------------------ 14872 14873 14874!------------------------------------------------------------------------------ 14875!> Find 3D mesh edges. 14876!------------------------------------------------------------------------------ 14877 SUBROUTINE FindMeshEdges3D( Mesh ) 14878 USE PElementMaps, ONLY : GetElementEdgeMap, GetElementFaceEdgeMap 14879 USE PElementBase, ONLY : isPPyramid 14880 14881 IMPLICIT NONE 14882!------------------------------------------------------------------------------ 14883 TYPE(Mesh_t) :: Mesh 14884!------------------------------------------------------------------------------ 14885 TYPE HashEntry_t 14886 INTEGER :: Node1,Edge 14887 TYPE(HashEntry_t), POINTER :: Next 14888 END TYPE HashEntry_t 14889 14890 TYPE HashTable_t 14891 TYPE(HashEntry_t), POINTER :: Head 14892 END TYPE HashTable_t 14893 14894 TYPE(HashTable_t), ALLOCATABLE :: HashTable(:) 14895 TYPE(HashEntry_t), POINTER :: HashPtr, HashPtr1 14896 14897 LOGICAL :: Found 14898 INTEGER :: n1,n2 14899 INTEGER :: i,j,k,n,NofEdges,Edge,Node1,Node2,istat,Degree,ii,jj 14900 14901 TYPE(Element_t), POINTER :: Element, Edges(:), Face 14902 14903 INTEGER, POINTER :: EdgeMap(:,:), FaceEdgeMap(:,:) 14904 INTEGER, TARGET :: TetraEdgeMap(6,3), BrickEdgeMap(12,3), TetraFaceMap(4,6), & 14905 WedgeEdgeMap(9,3), PyramidEdgeMap(8,3), TetraFaceEdgeMap(4,3), & 14906 BrickFaceEdgeMap(8,4), WedgeFaceEdgeMap(6,4), PyramidFaceEdgeMap(5,4) 14907!------------------------------------------------------------------------------ 14908 14909 CALL Info('FindMeshEdges3D','Finding mesh edges in 3D mesh',Level=12) 14910 14911 TetraFaceMap(1,:) = [ 1, 2, 3, 5, 6, 7 ] 14912 TetraFaceMap(2,:) = [ 1, 2, 4, 5, 9, 8 ] 14913 TetraFaceMap(3,:) = [ 2, 3, 4, 6,10, 9 ] 14914 TetraFaceMap(4,:) = [ 3, 1, 4, 7, 8,10 ] 14915 14916 TetraFaceEdgeMap(1,:) = [ 1,2,3 ] 14917 TetraFaceEdgeMap(2,:) = [ 1,5,4 ] 14918 TetraFaceEdgeMap(3,:) = [ 2,6,5 ] 14919 TetraFaceEdgeMap(4,:) = [ 3,4,6 ] 14920 14921 TetraEdgeMap(1,:) = [ 1,2,5 ] 14922 TetraEdgeMap(2,:) = [ 2,3,6 ] 14923 TetraEdgeMap(3,:) = [ 3,1,7 ] 14924 TetraEdgeMap(4,:) = [ 1,4,8 ] 14925 TetraEdgeMap(5,:) = [ 2,4,9 ] 14926 TetraEdgeMap(6,:) = [ 3,4,10 ] 14927 14928 PyramidEdgeMap(1,:) = [ 1,2,1 ] 14929 PyramidEdgeMap(2,:) = [ 2,3,1 ] 14930 PyramidEdgeMap(3,:) = [ 3,4,1 ] 14931 PyramidEdgeMap(4,:) = [ 4,1,1 ] 14932 PyramidEdgeMap(5,:) = [ 1,5,1 ] 14933 PyramidEdgeMap(6,:) = [ 2,5,1 ] 14934 PyramidEdgeMap(7,:) = [ 3,5,1 ] 14935 PyramidEdgeMap(8,:) = [ 4,5,1 ] 14936 14937 PyramidFaceEdgeMap(1,:) = [ 1,2,3,4 ] 14938 PyramidFaceEdgeMap(2,:) = [ 1,6,5,0 ] 14939 PyramidFaceEdgeMap(3,:) = [ 2,7,6,0 ] 14940 PyramidFaceEdgeMap(4,:) = [ 3,8,7,0 ] 14941 PyramidFaceEdgeMap(5,:) = [ 4,5,8,0 ] 14942 14943 WedgeEdgeMap(1,:) = [ 1, 2, 1 ] 14944 WedgeEdgeMap(2,:) = [ 2, 3, 1 ] 14945 WedgeEdgeMap(3,:) = [ 1, 3, 1 ] 14946 WedgeEdgeMap(4,:) = [ 4, 5, 1 ] 14947 WedgeEdgeMap(5,:) = [ 5, 6, 1 ] 14948 WedgeEdgeMap(6,:) = [ 6, 4, 1 ] 14949 WedgeEdgeMap(7,:) = [ 1, 4, 1 ] 14950 WedgeEdgeMap(8,:) = [ 2, 5, 1 ] 14951 WedgeEdgeMap(9,:) = [ 3, 6, 1 ] 14952 14953 WedgeFaceEdgeMap(1,:) = [ 1,2,3,0 ] 14954 WedgeFaceEdgeMap(2,:) = [ 4,5,6,0 ] 14955 WedgeFaceEdgeMap(3,:) = [ 1,8,4,7 ] 14956 WedgeFaceEdgeMap(4,:) = [ 2,9,5,8 ] 14957 WedgeFaceEdgeMap(5,:) = [ 3,7,6,9 ] 14958 14959 BrickEdgeMap(1,:) = [ 1, 2, 9 ] 14960 BrickEdgeMap(2,:) = [ 2, 3, 10 ] 14961 BrickEdgeMap(3,:) = [ 4, 3, 11 ] 14962 BrickEdgeMap(4,:) = [ 1, 4, 12 ] 14963 BrickEdgeMap(5,:) = [ 5, 6, 13 ] 14964 BrickEdgeMap(6,:) = [ 6, 7, 14 ] 14965 BrickEdgeMap(7,:) = [ 8, 7, 15 ] 14966 BrickEdgeMap(8,:) = [ 5, 8, 16 ] 14967 BrickEdgeMap(9,:) = [ 1, 5, 17 ] 14968 BrickEdgeMap(10,:) = [ 2, 6, 18 ] 14969 BrickEdgeMap(11,:) = [ 3, 7, 19 ] 14970 BrickEdgeMap(12,:) = [ 4, 8, 20 ] 14971 14972 BrickFaceEdgeMap(1,:) = [ 1,2,3,4 ] 14973 BrickFaceEdgeMap(2,:) = [ 5,6,7,8 ] 14974 BrickFaceEdgeMap(3,:) = [ 1,10,5,9 ] 14975 BrickFaceEdgeMap(4,:) = [ 2,11,6,10 ] 14976 BrickFaceEdgeMap(5,:) = [ 3,12,7,11 ] 14977 BrickFaceEdgeMap(6,:) = [ 4,9,8,12 ] 14978 14979! 14980! Initialize: 14981! ----------- 14982 CALL AllocateVector( Mesh % Edges, 12*Mesh % NumberOfBulkElements ) 14983 Edges => Mesh % Edges 14984 14985 DO i=1,Mesh % NumberOfBulkElements 14986 Element => Mesh % Elements(i) 14987 IF ( .NOT. ASSOCIATED( Element % EdgeIndexes ) ) & 14988 CALL AllocateVector(Element % EdgeIndexes, Element % TYPE % NumberOfEdges ) 14989 Element % EdgeIndexes = 0 14990 END DO 14991 14992 ALLOCATE( HashTable( Mesh % NumberOfNodes ) ) 14993 DO i=1,Mesh % NumberOfNodes 14994 NULLIFY( HashTable(i) % Head ) 14995 END DO 14996!------------------------------------------------------------------------------ 14997 14998! Loop over elements: 14999! ------------------- 15000 NofEdges = 0 15001 DO i=1,Mesh % NumberOfBulkElements 15002 Element => Mesh % Elements(i) 15003 15004 ! For P elements mappings are different 15005 IF ( ASSOCIATED(Element % PDefs) ) THEN 15006 CALL GetElementEdgeMap( Element, EdgeMap ) 15007 CALL GetElementFaceEdgeMap( Element, FaceEdgeMap ) 15008 n = Element % TYPE % NumberOfEdges 15009 ELSE 15010 SELECT CASE( Element % TYPE % ElementCode / 100 ) 15011 CASE(5) 15012 n = 6 15013 EdgeMap => TetraEdgeMap 15014 FaceEdgeMap => TetraFaceEdgeMap 15015 CASE(6) 15016 n = 8 15017 EdgeMap => PyramidEdgeMap 15018 FaceEdgeMap => PyramidFaceEdgeMap 15019 CASE(7) 15020 n = 9 15021 EdgeMap => WedgeEdgeMap 15022 FaceEdgeMap => WedgeFaceEdgeMap 15023 CASE(8) 15024 n = 12 15025 EdgeMap => BrickEdgeMap 15026 FaceEdgeMap => BrickFaceEdgeMap 15027 CASE DEFAULT 15028 CYCLE 15029 WRITE(Message,*) 'Element type',Element % TYPE % ElementCode,'not implemented.' 15030 CALL Fatal('FindMeshEdges',Message) 15031 END SELECT 15032 END IF 15033 15034! Loop over every edge of every element: 15035! -------------------------------------- 15036 DO k=1,n 15037 15038! Use MIN(Node1,Node2) as key to hash table: 15039! ------------------------------------------ 15040 n1 = Element % NodeIndexes(EdgeMap(k,1)) 15041 n2 = Element % NodeIndexes(EdgeMap(k,2)) 15042 IF ( n1 < n2 ) THEN 15043 Node1 = n1 15044 Node2 = n2 15045 ELSE 15046 Node1 = n2 15047 Node2 = n1 15048 END IF 15049! 15050! Look the edge from the hash table: 15051! ---------------------------------- 15052 HashPtr => HashTable(Node1) % Head 15053 Found = .FALSE. 15054 DO WHILE( ASSOCIATED( HashPtr ) ) 15055 IF ( HashPtr % Node1 == Node2 ) THEN 15056 Found = .TRUE. 15057 Edge = HashPtr % Edge 15058 EXIT 15059 END IF 15060 HashPtr => HashPtr % Next 15061 END DO 15062! 15063! Existing edge, update structures: 15064! --------------------------------- 15065 IF ( Found ) THEN 15066 Element % EdgeIndexes(k) = Edge 15067 15068 ! Mark edge as an edge of pydamid square face 15069 IF (isPPyramid(Element) .AND. k < 5) THEN 15070 Edges(Edge) % PDefs % pyramidQuadEdge = .TRUE. 15071 END IF 15072 15073 IF ( ASSOCIATED(Mesh % Faces) ) THEN 15074 DO ii=1,Element % TYPE % NumberOfFaces 15075 Face => Mesh % Faces(Element % FaceIndexes(ii)) 15076 IF ( .NOT. ASSOCIATED(Face % EdgeIndexes) ) THEN 15077 ALLOCATE(Face % EdgeIndexes(Face % TYPE % NumberOfEdges)) 15078 Face % EdgeIndexes = 0 15079 END IF 15080 DO jj=1,Face % TYPE % NumberOfEdges 15081 IF (FaceEdgeMap(ii,jj) == k) THEN 15082 Face % EdgeIndexes(jj) = Edge 15083 IF ( .NOT. ASSOCIATED(Edges(Edge) % BoundaryInfo % Left)) THEN 15084 Edges(Edge) % BoundaryInfo % Left => Face 15085 ELSE 15086 Edges(Edge) % BoundaryInfo % Right => Face 15087 END IF 15088 EXIT 15089 END IF 15090 END DO 15091 END DO 15092 END IF 15093 ELSE 15094 15095! Edge not yet there, create: 15096! --------------------------- 15097 NofEdges = NofEdges + 1 15098 Edge = NofEdges 15099 Edges(Edge) % ElementIndex = Edge 15100 Degree = Element % TYPE % BasisFunctionDegree 15101 15102! Edge is always a line segment with deg+1 nodes: 15103! ----------------------------------------------- 15104 Edges(Edge) % TYPE => GetElementType( 201 + degree, .FALSE.) 15105 15106 Edges(Edge) % NDOFs = 0 15107 IF (Element % NDOFs /= 0 ) & 15108 Edges(Edge) % NDOFs = Edges(Edge) % TYPE % NumberOfNodes 15109 Edges(Edge) % BDOFs = 0 15110 Edges(Edge) % DGDOFs = 0 15111 Edges(Edge) % EdgeIndexes => NULL() 15112 Edges(Edge) % FaceIndexes => NULL() 15113 15114 CALL AllocateVector( Edges(Edge) % NodeIndexes, degree + 1 ) 15115 DO n2=1,degree+1 15116 Edges(Edge) % NodeIndexes(n2) = & 15117 Element % NodeIndexes(EdgeMap(k,n2)) 15118 END DO 15119 15120 Element % EdgeIndexes(k) = Edge 15121 ALLOCATE( Edges(Edge) % BoundaryInfo ) 15122 Edges(Edge) % BoundaryInfo % Left => NULL() 15123 Edges(Edge) % BoundaryInfo % Right => NULL() 15124 15125 ! Allocate P element definitions 15126 IF ( ASSOCIATED( Element % PDefs ) ) THEN 15127 CALL AllocatePDefinitions(Edges(Edge)) 15128 15129 Edges(Edge) % PDefs % P = 0 15130 Edges(Edge) % PDefs % pyramidQuadEdge = .FALSE. 15131 ! Here mark edge as edge of pyramid if needed (or set as not) 15132 IF (isPPyramid(Element) .AND. k < 5) THEN 15133 Edges(Edge) % PDefs % pyramidQuadEdge = .TRUE. 15134 END IF 15135 ELSE 15136 NULLIFY( Edges(Edge) % PDefs ) 15137 END IF 15138 15139 IF ( ASSOCIATED(Mesh % Faces) ) THEN 15140 DO ii=1,Element % TYPE % NumberOfFaces 15141 Face => Mesh % Faces( Element % FaceIndexes(ii) ) 15142 IF ( .NOT. ASSOCIATED(Face % EdgeIndexes) ) THEN 15143 ALLOCATE( Face % EdgeIndexes( Face % TYPE % NumberOfEdges ) ) 15144 Face % EdgeIndexes = 0 15145 END IF 15146 DO jj=1,Face % TYPE % NumberOfEdges 15147 IF ( FaceEdgeMap(ii,jj) == k ) THEN 15148 Face % EdgeIndexes(jj) = Edge 15149 IF (.NOT.ASSOCIATED( Edges(Edge) % BoundaryInfo % Left)) THEN 15150 Edges(Edge) % BoundaryInfo % Left => Face 15151 ELSE 15152 Edges(Edge) % BoundaryInfo % Right => Face 15153 END IF 15154 END IF 15155 END DO 15156 END DO 15157 END IF 15158 15159! Update the hash table: 15160! ---------------------- 15161 ALLOCATE( HashPtr ) 15162 HashPtr % Edge = Edge 15163 HashPtr % Node1 = Node2 15164 HashPtr % Next => HashTable(Node1) % Head 15165 HashTable(Node1) % Head => HashPtr 15166 END IF 15167 END DO 15168 END DO 15169 15170 Mesh % NumberOfEdges = NofEdges 15171 CALL Info('FindMeshEdges3D','Number of edges found: '//TRIM(I2S(NofEdges)),Level=10) 15172 15173! Delete the hash table: 15174! ---------------------- 15175 DO i=1,Mesh % NumberOfNodes 15176 HashPtr => HashTable(i) % Head 15177 DO WHILE( ASSOCIATED(HashPtr) ) 15178 HashPtr1 => HashPtr % Next 15179 DEALLOCATE( HashPtr ) 15180 HashPtr => HashPtr1 15181 END DO 15182 END DO 15183 DEALLOCATE( HashTable ) 15184 15185 IF (ASSOCIATED(Mesh % Faces)) CALL FixFaceEdges() 15186 15187 CALL Info('FindMeshEdges3D','All done',Level=12) 15188 15189CONTAINS 15190 15191 SUBROUTINE FixFaceEdges() 15192 15193 INTEGER :: i,j,k,n,swap,edgeind(4),i1(2),i2(2) 15194 15195 DO i=1,Mesh % NumberOfFaces 15196 Face => Mesh % Faces(i) 15197 n = Face % TYPE % NumberOfEdges 15198 Edgeind(1:n) = Face % EdgeIndexes(1:n) 15199 DO j=1,n 15200 i1 = Mesh % Edges(Edgeind(j)) % NodeIndexes(1:2) 15201 IF ( i1(1)>i1(2) ) THEN 15202 swap=i1(1) 15203 i1(1)=i1(2) 15204 i1(2)=swap 15205 END IF 15206 DO k=1,n 15207 i2(1) = k 15208 i2(2) = k+1 15209 IF ( i2(2)>n ) i2(2)=1 15210 i2 = Face % NodeIndexes(i2) 15211 IF ( i2(1)>i2(2) ) THEN 15212 swap=i2(1) 15213 i2(1)=i2(2) 15214 i2(2)=swap 15215 END IF 15216 IF ( ALL(i1 == i2) ) THEN 15217 Face % EdgeIndexes(k) = edgeind(j) 15218 EXIT 15219 END IF 15220 END DO 15221 END DO 15222 END DO 15223 END SUBROUTINE FixFaceEdges 15224!------------------------------------------------------------------------------ 15225 END SUBROUTINE FindMeshEdges3D 15226!------------------------------------------------------------------------------ 15227 15228 15229!------------------------------------------------------------------------------ 15230!> Finds neighbours of the nodes in given direction. 15231!> The algorithm finds the neighbour that within 45 degrees of the 15232!> given direction has the smallest distance. 15233!------------------------------------------------------------------------------ 15234 SUBROUTINE FindNeighbourNodes( Mesh,Direction,Neighbours,EndNeighbours) 15235!------------------------------------------------------------------------------ 15236 15237 TYPE(Mesh_t) , POINTER :: Mesh 15238 REAL(KIND=dp) :: Direction(:) 15239 INTEGER :: Neighbours(:) 15240 INTEGER, OPTIONAL :: EndNeighbours(:) 15241 15242 TYPE(Nodes_t) :: ElementNodes 15243 TYPE(Element_t),POINTER :: CurrentElement 15244 REAL(KIND=dp), POINTER :: Distances(:) 15245 REAL(KIND=dp) :: rn(3), rs(3), ss, sn 15246 INTEGER, POINTER :: NodeIndexes(:) 15247 INTEGER :: i,j,k,n,t,DIM,istat 15248 15249 IF(SIZE(Neighbours) < Mesh % NumberOfNodes) THEN 15250 CALL Warn('FindNeigbourNodes','SIZE of Neighbours should equal Number of Nodes!') 15251 RETURN 15252 END IF 15253 15254 15255 IF(PRESENT(EndNeighbours)) THEN 15256 IF(SIZE(EndNeighbours) < Mesh % NumberOfNodes) THEN 15257 CALL Warn('FindNeigbourNodes','SIZE of EndNeigbours should equal Number of Nodes!') 15258 RETURN 15259 END IF 15260 END IF 15261 15262 15263 DIM = CoordinateSystemDimension() 15264 N = Mesh % MaxElementNodes 15265 15266 CALL AllocateVector( ElementNodes % x, n ) 15267 CALL AllocateVector( ElementNodes % y, n ) 15268 CALL AllocateVector( ElementNodes % z, n ) 15269 CALL AllocateVector( Distances, Mesh % NumberOfNodes ) 15270 15271 Neighbours = 0 15272 Distances = HUGE(Distances) 15273 15274 rn(1:DIM) = Direction(1:DIM) 15275 ss = SQRT(SUM(rn(1:DIM)**2)) 15276 rn = rn / ss 15277 15278 DO t=1,Mesh % NumberOfBulkElements 15279 15280 CurrentElement => Mesh % Elements(t) 15281 n = CurrentElement % TYPE % NumberOfNodes 15282 NodeIndexes => CurrentElement % NodeIndexes 15283 15284 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes(1:n)) 15285 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes(1:n)) 15286 IF(DIM == 3) THEN 15287 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes(1:n)) 15288 END IF 15289 15290 15291 DO i=1,n 15292 DO j=i+1,n 15293 rs(1) = ElementNodes % x(j) - ElementNodes % x(i) 15294 rs(2) = ElementNodes % y(j) - ElementNodes % y(i) 15295 IF (DIM == 3) THEN 15296 rs(3) = ElementNodes % z(j) - ElementNodes % z(i) 15297 END IF 15298 15299 ss = SQRT(SUM(rs(1:DIM)**2)) 15300 sn = SUM(rs(1:DIM)*rn(1:DIM)) 15301 15302 IF(ss < SQRT(2.0) * ABS(sn)) THEN 15303 IF(sn > 0) THEN 15304 IF(ss < Distances(NodeIndexes(i))) THEN 15305 Distances(NodeIndexes(i)) = ss 15306 Neighbours(NodeIndexes(i)) = NodeIndexes(j) 15307 END IF 15308 ELSE 15309 IF(ss < Distances(NodeIndexes(j))) THEN 15310 Distances(NodeIndexes(j)) = ss 15311 Neighbours(NodeIndexes(j)) = NodeIndexes(i) 15312 END IF 15313 END IF 15314 END IF 15315 END DO 15316 END DO 15317 END DO 15318 15319 ! This loop finds the final neighbour in the end of the chain 15320 IF(PRESENT(EndNeighbours)) THEN 15321 EndNeighbours = Neighbours 15322 15323 DO t=1,Mesh%NumberOfNodes 15324 j = Neighbours(t) 15325 DO WHILE(j /= 0) 15326 EndNeighbours(t) = j 15327 j = Neighbours(j) 15328 END DO 15329 END DO 15330 END IF 15331 DEALLOCATE(ElementNodes % x, ElementNodes % y, ElementNodes % z, Distances) 15332!------------------------------------------------------------------------------ 15333END SUBROUTINE FindNeighbourNodes 15334!------------------------------------------------------------------------------ 15335 15336 15337!------------------------------------------------------------------------------ 15338 SUBROUTINE UpdateSolverMesh( Solver, Mesh ) 15339!------------------------------------------------------------------------------ 15340 TYPE( Mesh_t ), POINTER :: Mesh 15341 TYPE( Solver_t ), TARGET :: Solver 15342!------------------------------------------------------------------------------ 15343 INTEGER :: i,j,k,n,n1,n2,DOFs 15344 LOGICAL :: Found, OptimizeBandwidth 15345 TYPE(Matrix_t), POINTER :: Matrix 15346 REAL(KIND=dp), POINTER :: Work(:) 15347 INTEGER, POINTER :: Permutation(:) 15348 TYPE(Variable_t), POINTER :: TimeVar, SaveVar, Var 15349 CHARACTER(LEN=MAX_NAME_LEN) :: str 15350!------------------------------------------------------------------------------ 15351 SaveVar => Solver % Variable 15352 DOFs = SaveVar % DOFs 15353 15354 Solver % Mesh => Mesh 15355 CALL SetCurrentMesh( CurrentModel, Mesh ) 15356! 15357! Create matrix and variable structures for 15358! current equation on the new mesh: 15359! ----------------------------------------- 15360 Solver % Variable => VariableGet( Mesh % Variables, & 15361 Solver % Variable % Name, ThisOnly = .FALSE. ) 15362 15363 CALL AllocateVector( Permutation, SIZE(Solver % Variable % Perm) ) 15364 15365 OptimizeBandwidth = ListGetLogical( Solver % Values, 'Optimize Bandwidth', Found ) 15366 IF ( .NOT. Found ) OptimizeBandwidth = .TRUE. 15367 15368 Matrix => CreateMatrix( CurrentModel, Solver, & 15369 Mesh, Permutation, DOFs, MATRIX_CRS, OptimizeBandwidth, & 15370 ListGetString( Solver % Values, 'Equation' ) ) 15371 15372 Matrix % Symmetric = ListGetLogical( Solver % Values, & 15373 'Linear System Symmetric', Found ) 15374 15375 Matrix % Lumped = ListGetLogical( Solver % Values, & 15376 'Lumped Mass Matrix', Found ) 15377 15378 ALLOCATE( Work(SIZE(Solver % Variable % Values)) ) 15379 Work = Solver % Variable % Values 15380 DO k=0,DOFs-1 15381 DO i=1,SIZE(Permutation) 15382 IF ( Permutation(i) > 0 ) THEN 15383 Solver % Variable % Values( DOFs*Permutation(i)-k ) = & 15384 Work( DOFs*Solver % Variable % Perm(i)-k ) 15385 END IF 15386 END DO 15387 END DO 15388 15389 IF ( ASSOCIATED( Solver % Variable % PrevValues ) ) THEN 15390 DO j=1,SIZE(Solver % Variable % PrevValues,2) 15391 Work = Solver % Variable % PrevValues(:,j) 15392 DO k=0,DOFs-1 15393 DO i=1,SIZE(Permutation) 15394 IF ( Permutation(i) > 0 ) THEN 15395 Solver % Variable % PrevValues( DOFs*Permutation(i) - k,j ) = & 15396 Work( DOFs * Solver % Variable % Perm(i) - k ) 15397 END IF 15398 END DO 15399 END DO 15400 END DO 15401 END IF 15402 DEALLOCATE( Work ) 15403 15404 Solver % Variable % Perm = Permutation 15405 Solver % Variable % Solver => Solver 15406 15407 DEALLOCATE( Permutation ) 15408 CALL AllocateVector( Matrix % RHS, Matrix % NumberOfRows ) 15409 15410 IF ( ASSOCIATED(SaveVar % EigenValues) ) THEN 15411 n = SIZE(SaveVar % EigenValues) 15412 15413 IF ( n > 0 ) THEN 15414 Solver % NOFEigenValues = n 15415 CALL AllocateVector( Solver % Variable % EigenValues,n ) 15416 CALL AllocateArray( Solver % Variable % EigenVectors, n, & 15417 SIZE(Solver % Variable % Values) ) 15418 15419 IF( Solver % Variable % Dofs > 1 ) THEN 15420 DO k=1,Solver % Variable % DOFs 15421 str = ComponentName( Solver % Variable % Name, k ) 15422 Var => VariableGet( Solver % Mesh % Variables, str, .TRUE. ) 15423 IF ( ASSOCIATED( Var ) ) THEN 15424 Var % EigenValues => Solver % Variable % EigenValues 15425 Var % EigenVectors => & 15426 Solver % Variable % EigenVectors(:,k::Solver % Variable % DOFs ) 15427 END IF 15428 END DO 15429 END IF 15430 15431 Solver % Variable % EigenValues = 0.0d0 15432 Solver % Variable % EigenVectors = 0.0d0 15433 15434 CALL AllocateVector( Matrix % MassValues, SIZE(Matrix % Values) ) 15435 Matrix % MassValues = 0.0d0 15436 END IF 15437 ELSE IF ( ASSOCIATED( Solver % Matrix ) ) THEN 15438 IF( ASSOCIATED( Solver % Matrix % Force) ) THEN 15439 n1 = Matrix % NumberOFRows 15440 n2 = SIZE(Solver % Matrix % Force,2) 15441 ALLOCATE(Matrix % Force(n1,n2)) 15442 Matrix % Force = 0.0d0 15443 END IF 15444 END IF 15445 15446 Solver % Matrix => Matrix 15447 Solver % Mesh % Changed = .TRUE. 15448 15449!------------------------------------------------------------------------------ 15450 END SUBROUTINE UpdateSolverMesh 15451!------------------------------------------------------------------------------ 15452 15453!------------------------------------------------------------------------------ 15454!> Split a mesh equally to smaller pieces by performing a uniform split. 15455!> Also known as mesh multiplication. A 2D element splits into 4 elements of 15456!> same form, and 3D element into 8 elements. 15457!> Currently works only for linear elements. 15458!------------------------------------------------------------------------------ 15459 FUNCTION SplitMeshEqual(Mesh,h) RESULT( NewMesh ) 15460!------------------------------------------------------------------------------ 15461 REAL(KIND=dp), OPTIONAL :: h(:) 15462 TYPE(Mesh_t), POINTER :: Mesh, NewMesh 15463!------------------------------------------------------------------------------ 15464 REAL(KIND=dp), POINTER :: u(:),v(:),w(:),x(:),y(:),z(:),xh(:) 15465 INTEGER :: i, j, k, n, NewElCnt, NodeCnt, EdgeCnt, FaceCnt, Node, ParentId, Diag, NodeIt 15466 LOGICAL :: Found, EdgesPresent 15467 TYPE(Element_t), POINTER :: Enew,Eold,Edge,Eptr,Eparent,Face,Faces(:) 15468 INTEGER, POINTER :: Child(:,:) 15469 INTEGER :: n1,n2,n3,EoldNodes(4),FaceNodes(4),EdgeNodes(2) ! Only linears so far 15470 INTEGER :: FaceNumber,Edge1,Edge2,Edge3,Edge4,Node12,Node23,Node34,Node41,Node31 15471 REAL(KIND=dp) :: dxyz(3,3),Dist(3),r,s,t,h1,h2 15472 TYPE(PElementDefs_t), POINTER :: PDefs 15473 INTEGER :: ierr, ParTmp(6), ParSizes(6) 15474 INTEGER, ALLOCATABLE :: FacePerm(:), BulkPerm(:) 15475!------------------------------------------------------------------------------ 15476 IF ( .NOT. ASSOCIATED( Mesh ) ) RETURN 15477 15478 CALL Info( 'SplitMeshEqual', 'Mesh splitting works for first order elements 303, 404, 504, (706) and 808.', Level = 6 ) 15479 15480 DO i=1,Mesh % NumberOfBulkElements 15481 SELECT CASE(Mesh % Elements(i) % TYPE % ElementCode/100) 15482 CASE(6) 15483 CALL Fatal('SplitMeshEqual','Pyramids not supported, sorry.') 15484 END SELECT 15485 END DO 15486 15487 NewMesh => AllocateMesh() 15488 15489 EdgesPresent = ASSOCIATED(Mesh % Edges) 15490 IF(.NOT.EdgesPresent) CALL FindMeshEdges( Mesh ) 15491 15492 CALL ResetTimer('SplitMeshEqual') 15493 15494 CALL Info( 'SplitMeshEqual', '******** Old mesh ********', Level = 6 ) 15495 WRITE( Message, * ) 'Nodes : ',Mesh % NumberOfNodes 15496 CALL info( 'SplitMeshEqual', Message, Level=6 ) 15497 WRITE( Message, * ) 'Bulk elements : ',Mesh % NumberOfBulkElements 15498 CALL info( 'SplitMeshEqual', Message, Level=6 ) 15499 WRITE( Message, * ) 'Boundary elements : ',Mesh % NumberOfBoundaryElements 15500 CALL info( 'SplitMeshEqual', Message, Level=6 ) 15501 WRITE( Message, * ) 'Edges : ',Mesh % NumberOfEdges 15502 CALL info( 'SplitMeshEqual', Message, Level=6 ) 15503 WRITE( Message, * ) 'Faces : ',Mesh % NumberOfFaces 15504 CALL info( 'SplitMeshEqual', Message, Level=6 ) 15505! 15506! Update nodal coordinates: 15507! ------------------------- 15508 NodeCnt = Mesh % NumberOfNodes + Mesh % NumberOfEdges 15509! 15510! For quad faces add one node in the center: 15511! ------------------------ 15512 ALLOCATE(FacePerm(Mesh % NumberOfFaces)); FacePerm = 0 15513 FaceCnt = 0 15514 DO i = 1, Mesh % NumberOfFaces 15515 Face => Mesh % Faces(i) 15516 IF( Face % TYPE % NumberOfNodes == 4 ) THEN 15517 NodeCnt = NodeCnt+1 15518 FaceCnt = FaceCnt+1 15519 FacePerm(i) = NodeCnt 15520 END IF 15521 END DO 15522 15523 WRITE( Message, * ) 'Added nodes in the center of faces : ', FaceCnt 15524 CALL Info( 'SplitMeshEqual', Message, Level=10 ) 15525! 15526! For quads and bricks, count centerpoints: 15527! ----------------------------------------- 15528 NodeIt = 0 15529 DO i=1,Mesh % NumberOfBulkElements 15530 Eold => Mesh % Elements(i) 15531 SELECT CASE( Eold % TYPE % ElementCode / 100 ) 15532 CASE(4,8) 15533 NodeCnt = NodeCnt + 1 15534 NodeIt = NodeIt + 1 15535 END SELECT 15536 END DO 15537 15538 WRITE( Message, * ) 'Added nodes in the center of bulks : ', NodeIt 15539 CALL Info( 'SplitMeshEqual', Message, Level=10 ) 15540! 15541! new mesh nodecoordinate arrays: 15542! ------------------------------- 15543 CALL AllocateVector( NewMesh % Nodes % x, NodeCnt ) 15544 CALL AllocateVector( NewMesh % Nodes % y, NodeCnt ) 15545 CALL AllocateVector( NewMesh % Nodes % z, NodeCnt ) 15546 15547! shortcuts (u,v,w) old mesh nodes, 15548! (x,y,z) new mesh nodes: 15549! ---------------------------------- 15550 u => Mesh % Nodes % x 15551 v => Mesh % Nodes % y 15552 w => Mesh % Nodes % z 15553 15554 x => NewMesh % Nodes % x 15555 y => NewMesh % Nodes % y 15556 z => NewMesh % Nodes % z 15557! 15558! new mesh includes old mesh nodes: 15559! ---------------------------------- 15560 x(1:Mesh % NumberOfNodes) = u 15561 y(1:Mesh % NumberOfNodes) = v 15562 z(1:Mesh % NumberOfNodes) = w 15563 15564! what is h? - pointer to nodal element size 15565 IF (PRESENT(h)) THEN 15566 ALLOCATE(xh(SIZE(x))) 15567 xh(1:SIZE(h)) = h 15568 END IF 15569! 15570! add edge centers: 15571! ----------------- 15572 j = Mesh % NumberOfNodes 15573 DO i=1,Mesh % NumberOfEdges 15574 j = j + 1 15575 Edge => Mesh % Edges(i) 15576 k = Edge % TYPE % NumberOfNodes 15577 IF (PRESENT(h)) THEN 15578 h1=h(Edge % NodeIndexes(1)) 15579 h2=h(Edge % NodeIndexes(2)) 15580 r=1._dp/(1+h1/h2) 15581 x(j) = r*u(Edge%NodeIndexes(1))+(1-r)*u(Edge%NodeIndexes(2)) 15582 y(j) = r*v(Edge%NodeIndexes(1))+(1-r)*v(Edge%NodeIndexes(2)) 15583 z(j) = r*w(Edge%NodeIndexes(1))+(1-r)*w(Edge%NodeIndexes(2)) 15584 xh(j)=r*h1+(1-r)*h2 15585 ELSE 15586 x(j) = SUM(u(Edge % NodeIndexes))/k 15587 y(j) = SUM(v(Edge % NodeIndexes))/k 15588 z(j) = SUM(w(Edge % NodeIndexes))/k 15589 END IF 15590 END DO 15591 15592 CALL Info('SplitMeshEqual','Added edge centers to the nodes list.', Level=10 ) 15593! 15594! add quad face centers for bricks and prisms(wedges): 15595! ---------------------------- 15596 j = Mesh % NumberOfNodes + Mesh % NumberOfEdges 15597 DO i=1,Mesh % NumberOfFaces 15598 Face => Mesh % Faces(i) 15599 k = Face % TYPE % NumberOfNodes 15600 IF( k == 4 ) THEN 15601 j = j + 1 15602 IF (PRESENT(h)) THEN 15603 n=Mesh % NumberOfNodes 15604 h1=xh(n+Face % EdgeIndexes(2)) 15605 h2=xh(n+Face % EdgeIndexes(4)) 15606 r=2._dp/(1+h1/h2)-1 15607 h1=xh(n+Face % EdgeIndexes(3)) 15608 h2=xh(n+Face % EdgeIndexes(1)) 15609 s=2._dp/(1+h1/h2)-1 15610 x(j) = InterpolateInElement2D(Face,u(Face % NodeIndexes),r,s) 15611 y(j) = InterpolateInElement2D(Face,v(Face % NodeIndexes),r,s) 15612 z(j) = InterpolateInElement2D(Face,w(Face % NodeIndexes),r,s) 15613 xh(j) = InterpolateInElement2D(Face,h(Face % NodeIndexes),r,s) 15614 ELSE 15615 x(j) = SUM(u(Face % NodeIndexes))/k 15616 y(j) = SUM(v(Face % NodeIndexes))/k 15617 z(j) = SUM(w(Face % NodeIndexes))/k 15618 END IF 15619 END IF 15620 END DO 15621 15622 CALL Info('SplitMeshEqual','Added face centers to the nodes list.', Level=10 ) 15623! 15624! add centerpoint for quads & bricks: 15625! ----------------------------------- 15626 DO i=1,Mesh % NumberOfBulkElements 15627 Eold => Mesh % Elements(i) 15628 k = Eold % TYPE % NumberOfNodes 15629 SELECT CASE( Eold % TYPE % ElementCode / 100 ) 15630 15631 CASE(4) 15632 j = j + 1 15633 IF (PRESENT(h)) THEN 15634 n=Mesh % NumberOfNodes 15635 h1=xh(n+Eold % Edgeindexes(2)) 15636 h2=xh(n+Eold % Edgeindexes(4)) 15637 r=2._dp/(1+h1/h2)-1 15638 h1=xh(n+Eold % EdgeIndexes(3)) 15639 h2=xh(n+Eold % EdgeIndexes(1)) 15640 s=2._dp/(1+h1/h2)-1 15641 x(j) = InterpolateInElement2D(Eold,u(Eold % NodeIndexes),r,s) 15642 y(j) = InterpolateInElement2D(Eold,v(Eold % NodeIndexes),r,s) 15643 z(j) = InterpolateInElement2D(Eold,w(Eold % NodeIndexes),r,s) 15644 ELSE 15645 x(j) = SUM(u(Eold % NodeIndexes))/k 15646 y(j) = SUM(v(Eold % NodeIndexes))/k 15647 z(j) = SUM(w(Eold % NodeIndexes))/k 15648 END IF 15649 CASE(8) 15650 j = j + 1 15651 IF (PRESENT(h)) THEN 15652 n=Mesh % NumberOfNodes+Mesh % NumberOfEdges 15653 h1=xh(n+Eold % FaceIndexes(4)) 15654 h2=xh(n+Eold % FaceIndexes(6)) 15655 r=2._dp/(1+h1/h2)-1 15656 15657 h1=xh(n+Eold % FaceIndexes(5)) 15658 h2=xh(n+Eold % FaceIndexes(3)) 15659 s=2._dp/(1+h1/h2)-1 15660 15661 h1=xh(n+Eold % FaceIndexes(2)) 15662 h2=xh(n+Eold % FaceIndexes(1)) 15663 t=2._dp/(1+h1/h2)-1 15664 x(j) = InterpolateInElement3D(Eold,u(Eold % NodeIndexes),r,s,t) 15665 y(j) = InterpolateInElement3D(Eold,v(Eold % NodeIndexes),r,s,t) 15666 z(j) = InterpolateInElement3D(Eold,w(Eold % NodeIndexes),r,s,t) 15667 ELSE 15668 x(j) = SUM(u(Eold % NodeIndexes))/k 15669 y(j) = SUM(v(Eold % NodeIndexes))/k 15670 z(j) = SUM(w(Eold % NodeIndexes))/k 15671 END IF 15672 END SELECT 15673 END DO 15674! 15675! Update new mesh node count: 15676! --------------------------- 15677 NewMesh % NumberOfEdges = 0 15678 NewMesh % NumberOfFaces = 0 15679 NewMesh % MaxBDOFs = Mesh % MaxBDOFs 15680 NewMesh % MinEdgeDOFs = Mesh % MinEdgeDOFs 15681 NewMesh % MinFaceDOFs = Mesh % MinFaceDOFs 15682 NewMesh % MaxEdgeDOFs = Mesh % MaxEdgeDOFs 15683 NewMesh % MaxFaceDOFs = Mesh % MaxFaceDOFs 15684 NewMesh % MaxElementDOFs = Mesh % MaxElementDOFs 15685 NewMesh % MeshDim = Mesh % MeshDim 15686 15687 NewMesh % NumberOfNodes = NodeCnt 15688 NewMesh % Nodes % NumberOfNodes = NodeCnt 15689! 15690! Update bulk elements: 15691! ===================== 15692! 15693! First count new elements: 15694! ------------------------- 15695 NewElCnt = 0 15696 DO i=1, Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 15697 Eold => Mesh % Elements(i) 15698 SELECT CASE( Eold % TYPE % ElementCode/100 ) 15699 15700! Each element will be divided into 2**Dim new elements: 15701! ------------------------------------------------------ 15702 CASE(2) 15703 NewElCnt = NewElCnt + 2 ! lines 15704 CASE(3) 15705 NewElCnt = NewElCnt + 4 ! trias 15706 CASE(4) 15707 NewElCnt = NewElCnt + 4 ! quads 15708 CASE(5) 15709 NewElCnt = NewElCnt + 8 ! tetras 15710 CASE(7) 15711 NewElCnt = NewElCnt + 8 ! prisms (wedges) 15712 CASE(8) 15713 NewElCnt = NewElCnt + 8 ! hexas 15714 END SELECT 15715 END DO 15716 15717 WRITE( Message, * ) 'Count of new elements : ', NewElCnt 15718 CALL Info( 'SplitMeshEqual', Message, Level=10 ) 15719 15720 CALL AllocateVector( NewMesh % Elements, NewElCnt ) 15721 CALL Info('SplitMeshEqual','New mesh allocated.', Level=10 ) 15722 15723 CALL AllocateArray( Child, Mesh % NumberOfBulkElements, 8 ) 15724 CALL Info('SplitMeshEqual','Array for bulk elements allocated.', Level=10 ) 15725 15726 NewElCnt = 0 15727 NodeCnt = Mesh % NumberOfNodes 15728 EdgeCnt = Mesh % NumberOfEdges 15729 15730! 15731! Index to old quad/hexa centerpoint node in the new mesh nodal arrays: 15732! --------------------------------------------------------------------- 15733 Node = NodeCnt + EdgeCnt + FaceCnt 15734! 15735! Now update all new mesh elements: 15736! --------------------------------- 15737 DO i=1,Mesh % NumberOfBulkElements 15738 15739 Eold => Mesh % Elements(i) 15740 15741 SELECT CASE( Eold % TYPE % ElementCode ) 15742 CASE(303) 15743! 15744! Split triangle to four triangles from 15745! edge centerpoints: 15746! -------------------------------------- 15747! 15748! 1st new element 15749! --------------- 15750 NewElCnt = NewElCnt + 1 15751 Child(i,1) = NewElCnt 15752 Enew => NewMesh % Elements(NewElCnt) 15753 Enew = Eold 15754 Enew % ElementIndex = NewElCnt 15755 CALL AllocateVector( ENew % NodeIndexes, 3) 15756 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 15757 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 15758 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 15759! 15760! 2nd new element 15761! --------------- 15762 NewElCnt = NewElCnt + 1 15763 Child(i,2) = NewElCnt 15764 Enew => NewMesh % Elements(NewElCnt) 15765 Enew = Eold 15766 Enew % ElementIndex = NewElCnt 15767 CALL AllocateVector( ENew % NodeIndexes, 3) 15768 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 15769 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 15770 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 15771! 15772! 3rd new element 15773! --------------- 15774 NewElCnt = NewElCnt + 1 15775 Child(i,3) = NewElCnt 15776 Enew => NewMesh % Elements(NewElCnt) 15777 Enew = Eold 15778 Enew % ElementIndex = NewElCnt 15779 CALL AllocateVector( ENew % NodeIndexes, 3) 15780 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 15781 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 15782 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 15783! 15784! 4th new element 15785! --------------- 15786 NewElCnt = NewElCnt + 1 15787 Child(i,4) = NewElCnt 15788 Enew => NewMesh % Elements(NewElCnt) 15789 Enew = Eold 15790 Enew % ElementIndex = NewElCnt 15791 CALL AllocateVector( ENew % NodeIndexes, 3) 15792 Enew % NodeIndexes(1) = Eold % EdgeIndexes(2) + NodeCnt 15793 Enew % NodeIndexes(2) = Eold % NodeIndexes(3) 15794 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 15795 15796 CASE(404) 15797! 15798! Index to old quad centerpoint node in the 15799! new mesh nodal arrays: 15800! ------------------------------------------ 15801 Node = Node + 1 15802! 15803! Split quad to four new quads from edge 15804! centerpoints and centerpoint of the 15805! element: 15806! -------------------------------------- 15807! 1st new element 15808! --------------- 15809 NewElCnt = NewElCnt + 1 15810 Enew => NewMesh % Elements(NewElCnt) 15811 Child(i,1) = NewElCnt 15812 Enew = Eold 15813 Enew % ElementIndex = NewElCnt 15814 CALL AllocateVector( ENew % NodeIndexes, 4) 15815 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 15816 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 15817 Enew % NodeIndexes(3) = Node 15818 Enew % NodeIndexes(4) = Eold % EdgeIndexes(4) + NodeCnt 15819! 15820! 2nd new element 15821! --------------- 15822 NewElCnt = NewElCnt + 1 15823 Enew => NewMesh % Elements(NewElCnt) 15824 Child(i,2) = NewElCnt 15825 Enew = Eold 15826 Enew % ElementIndex = NewElCnt 15827 CALL AllocateVector( ENew % NodeIndexes, 4) 15828 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 15829 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 15830 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 15831 Enew % NodeIndexes(4) = Node 15832! 15833! 3rd new element 15834! --------------- 15835 NewElCnt = NewElCnt + 1 15836 Enew => NewMesh % Elements(NewElCnt) 15837 Child(i,3) = NewElCnt 15838 Enew = Eold 15839 Enew % ElementIndex = NewElCnt 15840 CALL AllocateVector( ENew % NodeIndexes, 4) 15841 Enew % NodeIndexes(1) = Node 15842 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 15843 Enew % NodeIndexes(3) = Eold % NodeIndexes(3) 15844 Enew % NodeIndexes(4) = Eold % EdgeIndexes(3) + NodeCnt 15845! 15846! 4th new element 15847! --------------- 15848 NewElCnt = NewElCnt + 1 15849 Enew => NewMesh % Elements(NewElCnt) 15850 Child(i,4) = NewElCnt 15851 Enew = Eold 15852 Enew % ElementIndex = NewElCnt 15853 CALL AllocateVector( ENew % NodeIndexes, 4) 15854 Enew % NodeIndexes(1) = Eold % EdgeIndexes(4) + NodeCnt 15855 Enew % NodeIndexes(2) = Node 15856 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 15857 Enew % NodeIndexes(4) = Eold % NodeIndexes(4) 15858 15859 15860 CASE(504) 15861! 15862! Split tetra to 8 new elements from 15863! corners and edge centerpoints: 15864! ---------------------------------- 15865! 15866! 1st new element: 15867! ---------------- 15868 NewElCnt = NewElCnt + 1 15869 Enew => NewMesh % Elements(NewElCnt) 15870 Child(i,1) = NewElCnt 15871 Enew = Eold 15872 Enew % ElementIndex = NewElCnt 15873 CALL AllocateVector( ENew % NodeIndexes, 4) 15874 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 15875 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 15876 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 15877 Enew % NodeIndexes(4) = Eold % EdgeIndexes(4) + NodeCnt 15878! 15879! 2nd new element: 15880! ---------------- 15881 NewElCnt = NewElCnt + 1 15882 Enew => NewMesh % Elements(NewElCnt) 15883 Child(i,2) = NewElCnt 15884 Enew = Eold 15885 Enew % ElementIndex = NewElCnt 15886 CALL AllocateVector( ENew % NodeIndexes, 4) 15887 Enew % NodeIndexes(1) = Eold % NodeIndexes(2) 15888 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 15889 Enew % NodeIndexes(3) = Eold % EdgeIndexes(5) + NodeCnt 15890 Enew % NodeIndexes(4) = Eold % EdgeIndexes(2) + NodeCnt 15891! 15892! 3rd new element: 15893! ---------------- 15894 NewElCnt = NewElCnt + 1 15895 Enew => NewMesh % Elements(NewElCnt) 15896 Child(i,3) = NewElCnt 15897 Enew = Eold 15898 Enew % ElementIndex = NewElCnt 15899 CALL AllocateVector( ENew % NodeIndexes, 4) 15900 Enew % NodeIndexes(1) = Eold % NodeIndexes(3) 15901 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 15902 Enew % NodeIndexes(3) = Eold % EdgeIndexes(6) + NodeCnt 15903 Enew % NodeIndexes(4) = Eold % EdgeIndexes(3) + NodeCnt 15904! 15905! 4th new element: 15906! ---------------- 15907 NewElCnt = NewElCnt + 1 15908 Enew => NewMesh % Elements(NewElCnt) 15909 Child(i,4) = NewElCnt 15910 Enew = Eold 15911 Enew % ElementIndex = NewElCnt 15912 CALL AllocateVector( ENew % NodeIndexes, 4) 15913 Enew % NodeIndexes(1) = Eold % NodeIndexes(4) 15914 Enew % NodeIndexes(2) = Eold % EdgeIndexes(4) + NodeCnt 15915 Enew % NodeIndexes(3) = Eold % EdgeIndexes(6) + NodeCnt 15916 Enew % NodeIndexes(4) = Eold % EdgeIndexes(5) + NodeCnt 15917 15918! Then the annoying part; we still have to split the 15919! remaining octahedron into four elements. This can 15920! be done in three ways of which only one preserves 15921! the minimum angle condition (Delaunay splitting): 15922! -------------------------------------------------- 15923 dxyz(1,1) = x(Eold % EdgeIndexes(4) + NodeCnt) & 15924 - x(Eold % EdgeIndexes(2) + NodeCnt) 15925 dxyz(2,1) = y(Eold % EdgeIndexes(4) + NodeCnt) & 15926 - y(Eold % EdgeIndexes(2) + NodeCnt) 15927 dxyz(3,1) = z(Eold % EdgeIndexes(4) + NodeCnt) & 15928 - z(Eold % EdgeIndexes(2) + NodeCnt) 15929 15930 dxyz(1,2) = x(Eold % EdgeIndexes(5) + NodeCnt) & 15931 - x(Eold % EdgeIndexes(3) + NodeCnt) 15932 dxyz(2,2) = y(Eold % EdgeIndexes(5) + NodeCnt) & 15933 - y(Eold % EdgeIndexes(3) + NodeCnt) 15934 dxyz(3,2) = z(Eold % EdgeIndexes(5) + NodeCnt) & 15935 - z(Eold % EdgeIndexes(3) + NodeCnt) 15936 15937 dxyz(1,3) = x(Eold % EdgeIndexes(6) + NodeCnt) & 15938 - x(Eold % EdgeIndexes(1) + NodeCnt) 15939 dxyz(2,3) = y(Eold % EdgeIndexes(6) + NodeCnt) & 15940 - y(Eold % EdgeIndexes(1) + NodeCnt) 15941 dxyz(3,3) = z(Eold % EdgeIndexes(6) + NodeCnt) & 15942 - z(Eold % EdgeIndexes(1) + NodeCnt) 15943 15944 Dist(1) = SQRT( dxyz(1,1)**2 + dxyz(2,1)**2 + dxyz(3,1)**2 ) 15945 Dist(2) = SQRT( dxyz(1,2)**2 + dxyz(2,2)**2 + dxyz(3,2)**2 ) 15946 Dist(3) = SQRT( dxyz(1,3)**2 + dxyz(2,3)**2 + dxyz(3,3)**2 ) 15947 15948 Diag = 1 ! The default diagonal for splitting is between edges 2-4 15949 IF (Dist(2) < Dist(1) .AND. Dist(2) < Dist(3)) Diag = 2 ! Edges 3-5 15950 IF (Dist(3) < Dist(1) .AND. Dist(3) < Dist(2)) Diag = 3 ! Edges 1-6 15951 15952 SELECT CASE( Diag ) 15953 CASE(1) 15954! 15955! 5th new element: 15956! ---------------- 15957 NewElCnt = NewElCnt + 1 15958 Enew => NewMesh % Elements(NewElCnt) 15959 Child(i,5) = NewElCnt 15960 Enew = Eold 15961 Enew % ElementIndex = NewElCnt 15962 CALL AllocateVector( ENew % NodeIndexes, 4) 15963 Enew % NodeIndexes(1) = Eold % EdgeIndexes(6) + NodeCnt 15964 Enew % NodeIndexes(2) = Eold % EdgeIndexes(4) + NodeCnt 15965 Enew % NodeIndexes(3) = Eold % EdgeIndexes(5) + NodeCnt 15966 Enew % NodeIndexes(4) = Eold % EdgeIndexes(2) + NodeCnt 15967! 15968! 6th new element: 15969! ---------------- 15970 NewElCnt = NewElCnt + 1 15971 Enew => NewMesh % Elements(NewElCnt) 15972 Child(i,6) = NewElCnt 15973 Enew = Eold 15974 Enew % ElementIndex = NewElCnt 15975 CALL AllocateVector( ENew % NodeIndexes, 4) 15976 Enew % NodeIndexes(1) = Eold % EdgeIndexes(6) + NodeCnt 15977 Enew % NodeIndexes(2) = Eold % EdgeIndexes(4) + NodeCnt 15978 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 15979 Enew % NodeIndexes(4) = Eold % EdgeIndexes(3) + NodeCnt 15980! 15981! 7th new element: 15982! ---------------- 15983 NewElCnt = NewElCnt + 1 15984 Enew => NewMesh % Elements(NewElCnt) 15985 Child(i,7) = NewElCnt 15986 Enew = Eold 15987 Enew % ElementIndex = NewElCnt 15988 CALL AllocateVector( ENew % NodeIndexes, 4) 15989 Enew % NodeIndexes(1) = Eold % EdgeIndexes(4) + NodeCnt 15990 Enew % NodeIndexes(2) = Eold % EdgeIndexes(5) + NodeCnt 15991 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 15992 Enew % NodeIndexes(4) = Eold % EdgeIndexes(1) + NodeCnt 15993! 15994! 8th new element: 15995! ---------------- 15996 NewElCnt = NewElCnt + 1 15997 Enew => NewMesh % Elements(NewElCnt) 15998 Child(i,8) = NewElCnt 15999 Enew = Eold 16000 Enew % ElementIndex = NewElCnt 16001 CALL AllocateVector( ENew % NodeIndexes, 4) 16002 Enew % NodeIndexes(1) = Eold % EdgeIndexes(4) + NodeCnt 16003 Enew % NodeIndexes(2) = Eold % EdgeIndexes(3) + NodeCnt 16004 Enew % NodeIndexes(3) = Eold % EdgeIndexes(1) + NodeCnt 16005 Enew % NodeIndexes(4) = Eold % EdgeIndexes(2) + NodeCnt 16006! 16007 CASE(2) 16008! 16009! 5th new element: 16010! ---------------- 16011 NewElCnt = NewElCnt + 1 16012 Enew => NewMesh % Elements(NewElCnt) 16013 Child(i,5) = NewElCnt 16014 Enew = Eold 16015 Enew % ElementIndex = NewElCnt 16016 CALL AllocateVector( ENew % NodeIndexes, 4) 16017 Enew % NodeIndexes(1) = Eold % EdgeIndexes(5) + NodeCnt 16018 Enew % NodeIndexes(2) = Eold % EdgeIndexes(4) + NodeCnt 16019 Enew % NodeIndexes(3) = Eold % EdgeIndexes(6) + NodeCnt 16020 Enew % NodeIndexes(4) = Eold % EdgeIndexes(3) + NodeCnt 16021! 16022! 6th new element: 16023! ---------------- 16024 NewElCnt = NewElCnt + 1 16025 Enew => NewMesh % Elements(NewElCnt) 16026 Child(i,6) = NewElCnt 16027 Enew = Eold 16028 Enew % ElementIndex = NewElCnt 16029 CALL AllocateVector( ENew % NodeIndexes, 4) 16030 Enew % NodeIndexes(1) = Eold % EdgeIndexes(5) + NodeCnt 16031 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 16032 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 16033 Enew % NodeIndexes(4) = Eold % EdgeIndexes(3) + NodeCnt 16034! 16035! 7th new element: 16036! ---------------- 16037 NewElCnt = NewElCnt + 1 16038 Enew => NewMesh % Elements(NewElCnt) 16039 Child(i,7) = NewElCnt 16040 Enew = Eold 16041 Enew % ElementIndex = NewElCnt 16042 CALL AllocateVector( ENew % NodeIndexes, 4) 16043 Enew % NodeIndexes(1) = Eold % EdgeIndexes(3) + NodeCnt 16044 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 16045 Enew % NodeIndexes(3) = Eold % EdgeIndexes(6) + NodeCnt 16046 Enew % NodeIndexes(4) = Eold % EdgeIndexes(5) + NodeCnt 16047! 16048! 8th new element: 16049! ---------------- 16050 NewElCnt = NewElCnt + 1 16051 Enew => NewMesh % Elements(NewElCnt) 16052 Child(i,8) = NewElCnt 16053 Enew = Eold 16054 Enew % ElementIndex = NewElCnt 16055 CALL AllocateVector( ENew % NodeIndexes, 4) 16056 Enew % NodeIndexes(1) = Eold % EdgeIndexes(3) + NodeCnt 16057 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 16058 Enew % NodeIndexes(3) = Eold % EdgeIndexes(4) + NodeCnt 16059 Enew % NodeIndexes(4) = Eold % EdgeIndexes(5) + NodeCnt 16060! 16061 CASE(3) 16062! 16063! 5th new element: 16064! ---------------- 16065 NewElCnt = NewElCnt + 1 16066 Enew => NewMesh % Elements(NewElCnt) 16067 Child(i,5) = NewElCnt 16068 Enew = Eold 16069 Enew % ElementIndex = NewElCnt 16070 CALL AllocateVector( ENew % NodeIndexes, 4) 16071 Enew % NodeIndexes(1) = Eold % EdgeIndexes(6) + NodeCnt 16072 Enew % NodeIndexes(2) = Eold % EdgeIndexes(4) + NodeCnt 16073 Enew % NodeIndexes(3) = Eold % EdgeIndexes(5) + NodeCnt 16074 Enew % NodeIndexes(4) = Eold % EdgeIndexes(1) + NodeCnt 16075! 16076! 6th new element: 16077! ---------------- 16078 NewElCnt = NewElCnt + 1 16079 Enew => NewMesh % Elements(NewElCnt) 16080 Child(i,6) = NewElCnt 16081 Enew = Eold 16082 Enew % ElementIndex = NewElCnt 16083 CALL AllocateVector( ENew % NodeIndexes, 4) 16084 Enew % NodeIndexes(1) = Eold % EdgeIndexes(6) + NodeCnt 16085 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 16086 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 16087 Enew % NodeIndexes(4) = Eold % EdgeIndexes(1) + NodeCnt 16088! 16089! 7th new element: 16090! ---------------- 16091 NewElCnt = NewElCnt + 1 16092 Enew => NewMesh % Elements(NewElCnt) 16093 Child(i,7) = NewElCnt 16094 Enew = Eold 16095 Enew % ElementIndex = NewElCnt 16096 CALL AllocateVector( ENew % NodeIndexes, 4) 16097 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 16098 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 16099 Enew % NodeIndexes(3) = Eold % EdgeIndexes(5) + NodeCnt 16100 Enew % NodeIndexes(4) = Eold % EdgeIndexes(6) + NodeCnt 16101! 16102! 8th new element: 16103! ---------------- 16104 NewElCnt = NewElCnt + 1 16105 Enew => NewMesh % Elements(NewElCnt) 16106 Child(i,8) = NewElCnt 16107 Enew = Eold 16108 Enew % ElementIndex = NewElCnt 16109 CALL AllocateVector( ENew % NodeIndexes, 4) 16110 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 16111 Enew % NodeIndexes(2) = Eold % EdgeIndexes(3) + NodeCnt 16112 Enew % NodeIndexes(3) = Eold % EdgeIndexes(4) + NodeCnt 16113 Enew % NodeIndexes(4) = Eold % EdgeIndexes(6) + NodeCnt 16114 16115 END SELECT 16116 16117 16118 CASE(706) 16119! 16120! Split prism to 8 new prism from edge 16121! centerpoints: 16122! -------------------------------------- 16123! 16124! 1st new element 16125! --------------- 16126 NewElCnt = NewElCnt + 1 16127 Enew => NewMesh % Elements(NewElCnt) 16128 Child(i,1) = NewElCnt 16129 Enew = Eold 16130 Enew % ElementIndex = NewElCnt 16131 CALL AllocateVector( ENew % NodeIndexes, 6) 16132 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 16133 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 16134 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 16135 Enew % NodeIndexes(4) = Eold % EdgeIndexes(7) + NodeCnt 16136 Enew % NodeIndexes(5) = FacePerm(Eold % FaceIndexes(3)) 16137 Enew % NodeIndexes(6) = FacePerm(Eold % FaceIndexes(5)) 16138 16139! 16140! 2nd new element 16141! --------------- 16142 NewElCnt = NewElCnt + 1 16143 Enew => NewMesh % Elements(NewElCnt) 16144 Child(i,2) = NewElCnt 16145 Enew = Eold 16146 Enew % ElementIndex = NewElCnt 16147 CALL AllocateVector( ENew % NodeIndexes, 6) 16148 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 16149 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 16150 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 16151 Enew % NodeIndexes(4) = FacePerm(Eold % FaceIndexes(3)) 16152 Enew % NodeIndexes(5) = Eold % EdgeIndexes(8) + NodeCnt 16153 Enew % NodeIndexes(6) = FacePerm(Eold % FaceIndexes(4)) 16154 16155! 16156! 3rd new element (near node 3) 16157! --------------- 16158 NewElCnt = NewElCnt + 1 16159 Enew => NewMesh % Elements(NewElCnt) 16160 Child(i,3) = NewElCnt 16161 Enew = Eold 16162 Enew % ElementIndex = NewElCnt 16163 CALL AllocateVector( ENew % NodeIndexes, 6) 16164 Enew % NodeIndexes(1) = Eold % EdgeIndexes(3) + NodeCnt 16165 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 16166 Enew % NodeIndexes(3) = Eold % NodeIndexes(3) 16167 Enew % NodeIndexes(4) = FacePerm(Eold % FaceIndexes(5)) 16168 Enew % NodeIndexes(5) = FacePerm(Eold % FaceIndexes(4)) 16169 Enew % NodeIndexes(6) = Eold % EdgeIndexes(9) + NodeCnt 16170 16171! 16172! 4th new element (bottom center) 16173! --------------- 16174 NewElCnt = NewElCnt + 1 16175 Enew => NewMesh % Elements(NewElCnt) 16176 Child(i,4) = NewElCnt 16177 Enew = Eold 16178 Enew % ElementIndex = NewElCnt 16179 CALL AllocateVector( ENew % NodeIndexes, 6) 16180 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 16181 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 16182 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 16183 Enew % NodeIndexes(4) = FacePerm(Eold % FaceIndexes(3)) 16184 Enew % NodeIndexes(5) = FacePerm(Eold % FaceIndexes(4)) 16185 Enew % NodeIndexes(6) = FacePerm(Eold % FaceIndexes(5)) 16186 16187! 16188! 5th new element 16189! --------------- 16190 NewElCnt = NewElCnt + 1 16191 Enew => NewMesh % Elements(NewElCnt) 16192 Child(i,5) = NewElCnt 16193 Enew = Eold 16194 Enew % ElementIndex = NewElCnt 16195 CALL AllocateVector( ENew % NodeIndexes, 6) 16196 Enew % NodeIndexes(1) = Eold % EdgeIndexes(7) + NodeCnt 16197 Enew % NodeIndexes(2) = FacePerm(Eold % FaceIndexes(3)) 16198 Enew % NodeIndexes(3) = FacePerm(Eold % FaceIndexes(5)) 16199 Enew % NodeIndexes(4) = Eold % NodeIndexes(4) 16200 Enew % NodeIndexes(5) = Eold % EdgeIndexes(4) + NodeCnt 16201 Enew % NodeIndexes(6) = Eold % EdgeIndexes(6) + NodeCnt 16202 16203! 16204! 6th new element 16205! --------------- 16206 NewElCnt = NewElCnt + 1 16207 Enew => NewMesh % Elements(NewElCnt) 16208 Child(i,6) = NewElCnt 16209 Enew = Eold 16210 Enew % ElementIndex = NewElCnt 16211 CALL AllocateVector( ENew % NodeIndexes, 6) 16212 Enew % NodeIndexes(1) = FacePerm(Eold % FaceIndexes(3)) 16213 Enew % NodeIndexes(2) = Eold % EdgeIndexes(8) + NodeCnt 16214 Enew % NodeIndexes(3) = FacePerm(Eold % FaceIndexes(4)) 16215 Enew % NodeIndexes(4) = Eold % EdgeIndexes(4) + NodeCnt 16216 Enew % NodeIndexes(5) = Eold % NodeIndexes(5) 16217 Enew % NodeIndexes(6) = Eold % EdgeIndexes(5) + NodeCnt 16218 16219! 16220! 7th new element 16221! --------------- 16222 NewElCnt = NewElCnt + 1 16223 Enew => NewMesh % Elements(NewElCnt) 16224 Child(i,7) = NewElCnt 16225 Enew = Eold 16226 Enew % ElementIndex = NewElCnt 16227 CALL AllocateVector( ENew % NodeIndexes, 6) 16228 Enew % NodeIndexes(1) = FacePerm(Eold % FaceIndexes(5)) 16229 Enew % NodeIndexes(2) = FacePerm(Eold % FaceIndexes(4)) 16230 Enew % NodeIndexes(3) = Eold % EdgeIndexes(9) + NodeCnt 16231 Enew % NodeIndexes(4) = Eold % EdgeIndexes(6) + NodeCnt 16232 Enew % NodeIndexes(5) = Eold % EdgeIndexes(5) + NodeCnt 16233 Enew % NodeIndexes(6) = Eold % NodeIndexes(6) 16234! 16235! 8th new element (top half, center) 16236! --------------- 16237 NewElCnt = NewElCnt + 1 16238 Enew => NewMesh % Elements(NewElCnt) 16239 Child(i,8) = NewElCnt 16240 Enew = Eold 16241 Enew % ElementIndex = NewElCnt 16242 CALL AllocateVector( ENew % NodeIndexes, 6) 16243 Enew % NodeIndexes(1) = FacePerm(Eold % FaceIndexes(3)) 16244 Enew % NodeIndexes(2) = FacePerm(Eold % FaceIndexes(4)) 16245 Enew % NodeIndexes(3) = FacePerm(Eold % FaceIndexes(5)) 16246 Enew % NodeIndexes(4) = Eold % EdgeIndexes(4) + NodeCnt 16247 Enew % NodeIndexes(5) = Eold % EdgeIndexes(5) + NodeCnt 16248 Enew % NodeIndexes(6) = Eold % EdgeIndexes(6) + NodeCnt 16249 16250 16251 16252 CASE(808) 16253! 16254! Index to old quad centerpoint node in the 16255! new mesh nodal arrays: 16256! ------------------------------------------ 16257 Node = Node + 1 16258! 16259! Split brick to 8 new bricks from edge 16260! centerpoints and centerpoint of the 16261! element: 16262! -------------------------------------- 16263! 16264! 1st new element 16265! --------------- 16266 NewElCnt = NewElCnt + 1 16267 Enew => NewMesh % Elements(NewElCnt) 16268 Child(i,1) = NewElCnt 16269 Enew = Eold 16270 Enew % ElementIndex = NewElCnt 16271 CALL AllocateVector( ENew % NodeIndexes, 8) 16272 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 16273 Enew % NodeIndexes(2) = Eold % EdgeIndexes(1) + NodeCnt 16274 Enew % NodeIndexes(3) = FacePerm(Eold % FaceIndexes(1)) 16275 Enew % NodeIndexes(4) = Eold % EdgeIndexes(4) + NodeCnt 16276 Enew % NodeIndexes(5) = Eold % EdgeIndexes(9) + NodeCnt 16277 Enew % NodeIndexes(6) = FacePerm(Eold % FaceIndexes(3)) 16278 Enew % NodeIndexes(7) = Node 16279 Enew % NodeIndexes(8) = FacePerm(Eold % FaceIndexes(6)) 16280! 16281! 2nd new element 16282! --------------- 16283 NewElCnt = NewElCnt + 1 16284 Enew => NewMesh % Elements(NewElCnt) 16285 Child(i,2) = NewElCnt 16286 Enew = Eold 16287 Enew % ElementIndex = NewElCnt 16288 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16289 Enew % NodeIndexes(1) = Eold % EdgeIndexes(1) + NodeCnt 16290 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 16291 Enew % NodeIndexes(3) = Eold % EdgeIndexes(2) + NodeCnt 16292 Enew % NodeIndexes(4) = FacePerm(Eold % FaceIndexes(1)) 16293 Enew % NodeIndexes(5) = FacePerm(Eold % FaceIndexes(3)) 16294 Enew % NodeIndexes(6) = Eold % EdgeIndexes(10)+ NodeCnt 16295 Enew % NodeIndexes(7) = FacePerm(Eold % FaceIndexes(4)) 16296 Enew % NodeIndexes(8) = Node 16297! 16298! 3rd new element 16299! --------------- 16300 NewElCnt = NewElCnt + 1 16301 Enew => NewMesh % Elements(NewElCnt) 16302 Child(i,3) = NewElCnt 16303 Enew = Eold 16304 Enew % ElementIndex = NewElCnt 16305 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16306 Enew % NodeIndexes(1) = Eold % EdgeIndexes(4) + NodeCnt 16307 Enew % NodeIndexes(2) = FacePerm(Eold % FaceIndexes(1)) 16308 Enew % NodeIndexes(3) = Eold % EdgeIndexes(3) + NodeCnt 16309 Enew % NodeIndexes(4) = Eold % NodeIndexes(4) 16310 Enew % NodeIndexes(5) = FacePerm(Eold % FaceIndexes(6)) 16311 Enew % NodeIndexes(6) = Node 16312 Enew % NodeIndexes(7) = FacePerm(Eold % FaceIndexes(5)) 16313 Enew % NodeIndexes(8) = Eold % EdgeIndexes(12)+ NodeCnt 16314! 16315! 4th new element 16316! --------------- 16317 NewElCnt = NewElCnt + 1 16318 Enew => NewMesh % Elements(NewElCnt) 16319 Child(i,4) = NewElCnt 16320 Enew = Eold 16321 Enew % ElementIndex = NewElCnt 16322 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16323 Enew % NodeIndexes(1) = FacePerm(Eold % FaceIndexes(1)) 16324 Enew % NodeIndexes(2) = Eold % EdgeIndexes(2) + NodeCnt 16325 Enew % NodeIndexes(3) = Eold % NodeIndexes(3) 16326 Enew % NodeIndexes(4) = Eold % EdgeIndexes(3) + NodeCnt 16327 Enew % NodeIndexes(5) = Node 16328 Enew % NodeIndexes(6) = FacePerm(Eold % FaceIndexes(4)) 16329 Enew % NodeIndexes(7) = Eold % EdgeIndexes(11)+ NodeCnt 16330 Enew % NodeIndexes(8) = FacePerm(Eold % FaceIndexes(5)) 16331! 16332! 5th new element 16333! --------------- 16334 NewElCnt = NewElCnt + 1 16335 Enew => NewMesh % Elements(NewElCnt) 16336 Child(i,5) = NewElCnt 16337 Enew = Eold 16338 Enew % ElementIndex = NewElCnt 16339 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16340 Enew % NodeIndexes(1) = Eold % EdgeIndexes(9) + NodeCnt 16341 Enew % NodeIndexes(2) = FacePerm(Eold % FaceIndexes(3)) 16342 Enew % NodeIndexes(3) = Node 16343 Enew % NodeIndexes(4) = FacePerm(Eold % FaceIndexes(6)) 16344 Enew % NodeIndexes(5) = Eold % NodeIndexes(5) 16345 Enew % NodeIndexes(6) = Eold % EdgeIndexes(5) + NodeCnt 16346 Enew % NodeIndexes(7) = FacePerm(Eold % FaceIndexes(2)) 16347 Enew % NodeIndexes(8) = Eold % EdgeIndexes(8) + NodeCnt 16348! 16349! 6th new element 16350! --------------- 16351 NewElCnt = NewElCnt + 1 16352 Enew => NewMesh % Elements(NewElCnt) 16353 Child(i,6) = NewElCnt 16354 Enew = Eold 16355 Enew % ElementIndex = NewElCnt 16356 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16357 Enew % NodeIndexes(1) = FacePerm(Eold % FaceIndexes(3)) 16358 Enew % NodeIndexes(2) = Eold % EdgeIndexes(10)+ NodeCnt 16359 Enew % NodeIndexes(3) = FacePerm(Eold % FaceIndexes(4)) 16360 Enew % NodeIndexes(4) = Node 16361 Enew % NodeIndexes(5) = Eold % EdgeIndexes(5) + NodeCnt 16362 Enew % NodeIndexes(6) = Eold % NodeIndexes(6) 16363 Enew % NodeIndexes(7) = Eold % EdgeIndexes(6) + NodeCnt 16364 Enew % NodeIndexes(8) = FacePerm(Eold % FaceIndexes(2)) 16365! 16366! 7th new element 16367! --------------- 16368 NewElCnt = NewElCnt + 1 16369 Enew => NewMesh % Elements(NewElCnt) 16370 Child(i,7) = NewElCnt 16371 Enew = Eold 16372 Enew % ElementIndex = NewElCnt 16373 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16374 Enew % NodeIndexes(1) = FacePerm(Eold % FaceIndexes(6)) 16375 Enew % NodeIndexes(2) = Node 16376 Enew % NodeIndexes(3) = FacePerm(Eold % FaceIndexes(5)) 16377 Enew % NodeIndexes(4) = Eold % EdgeIndexes(12)+ NodeCnt 16378 Enew % NodeIndexes(5) = Eold % EdgeIndexes(8) + NodeCnt 16379 Enew % NodeIndexes(6) = FacePerm(Eold % FaceIndexes(2)) 16380 Enew % NodeIndexes(7) = Eold % EdgeIndexes(7) + NodeCnt 16381 Enew % NodeIndexes(8) = Eold % NodeIndexes(8) 16382! 16383! 8th new element 16384! --------------- 16385 NewElCnt = NewElCnt + 1 16386 Enew => NewMesh % Elements(NewElCnt) 16387 Child(i,8) = NewElCnt 16388 Enew = Eold 16389 Enew % ElementIndex = NewElCnt 16390 CALL AllocateVector( ENew % NodeIndexes, 8 ) 16391 Enew % NodeIndexes(1) = Node 16392 Enew % NodeIndexes(2) = FacePerm(Eold % FaceIndexes(4)) 16393 Enew % NodeIndexes(3) = Eold % EdgeIndexes(11)+ NodeCnt 16394 Enew % NodeIndexes(4) = FacePerm(Eold % FaceIndexes(5)) 16395 Enew % NodeIndexes(5) = FacePerm(Eold % FaceIndexes(2)) 16396 Enew % NodeIndexes(6) = Eold % EdgeIndexes(6) + NodeCnt 16397 Enew % NodeIndexes(7) = Eold % NodeIndexes(7) 16398 Enew % NodeIndexes(8) = Eold % EdgeIndexes(7) + NodeCnt 16399 16400 CASE DEFAULT 16401 WRITE( Message,* ) 'Element type ', Eold % TYPE % ElementCode, & 16402 ' not supprted by the multigrid solver.' 16403 CALL Fatal( 'SplitMeshEqual', Message ) 16404 END SELECT 16405 END DO 16406 16407! 16408! Update new mesh element counts: 16409! ------------------------------- 16410 NewMesh % NumberOfBulkElements = NewElCnt 16411 16412! 16413! Update boundary elements: 16414! NOTE: Internal boundaries not taken care of...:!!!! 16415! --------------------------------------------------- 16416 DO i=1,Mesh % NumberOfBoundaryElements 16417 16418 j = i + Mesh % NumberOfBulkElements 16419 Eold => Mesh % Elements(j) 16420! 16421! get parent of the boundary element: 16422! ----------------------------------- 16423 Eparent => Eold % BoundaryInfo % Left 16424 IF ( .NOT.ASSOCIATED(Eparent) ) & 16425 eParent => Eold % BoundaryInfo % Right 16426 IF ( .NOT. ASSOCIATED( Eparent ) ) CYCLE 16427 16428 ParentId = Eparent % ElementIndex 16429 16430 SELECT CASE( Eold % TYPE % ElementCode / 100 ) 16431 CASE(2) 16432! 16433! Line segments: 16434! ============== 16435! 16436! which edge of the parent element are we ? 16437! ----------------------------------------- 16438 DO Edge1=1,SIZE(Eparent % EdgeIndexes) 16439 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge1) ) 16440 IF ( Eold % NodeIndexes(1) == Edge % NodeIndexes(1) .AND. & 16441 Eold % NodeIndexes(2) == Edge % NodeIndexes(2) .OR. & 16442 Eold % NodeIndexes(2) == Edge % NodeIndexes(1) .AND. & 16443 Eold % NodeIndexes(1) == Edge % NodeIndexes(2) ) EXIT 16444 END DO 16445! 16446! index of the old edge centerpoint in the 16447! new mesh nodal arrays: 16448! ---------------------------------------- 16449 Node = Eparent % EdgeIndexes(Edge1) + Mesh % NumberOfNodes 16450! 16451! 1st new element 16452! --------------- 16453 NewElCnt = NewElCnt + 1 16454 Enew => NewMesh % Elements(NewElCnt) 16455 Enew = Eold 16456 Enew % ElementIndex = NewElCnt 16457 CALL AllocateVector( Enew % NodeIndexes, 2 ) 16458 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 16459 Enew % NodeIndexes(2) = Node 16460 ALLOCATE( Enew % BoundaryInfo ) 16461 Enew % BoundaryInfo = Eold % BoundaryInfo 16462 NULLIFY( Enew % BoundaryInfo % Left ) 16463 NULLIFY( Enew % BoundaryInfo % Right ) 16464! 16465! Search the new mesh parent element among the 16466! children of the old mesh parent element: 16467! -------------------------------------------- 16468 DO j=1,4 16469 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16470 n = Eptr % TYPE % NumberOfNodes 16471 Found = .FALSE. 16472 DO k=1,n-1 16473 IF ( Enew % NodeIndexes(1) == Eptr % NodeIndexes(k) .AND. & 16474 Enew % NodeIndexes(2) == Eptr % NodeIndexes(k+1) .OR. & 16475 Enew % NodeIndexes(2) == Eptr % NodeIndexes(k) .AND. & 16476 Enew % NodeIndexes(1) == Eptr % NodeIndexes(k+1) ) THEN 16477 Found = .TRUE. 16478 EXIT 16479 END IF 16480 END DO 16481 IF ( Enew % NodeIndexes(1) == Eptr % NodeIndexes(n) .AND. & 16482 Enew % NodeIndexes(2) == Eptr % NodeIndexes(1) .OR. & 16483 Enew % NodeIndexes(2) == Eptr % NodeIndexes(n) .AND. & 16484 Enew % NodeIndexes(1) == Eptr % NodeIndexes(1) ) THEN 16485 Found = .TRUE. 16486 END IF 16487 IF ( Found ) EXIT 16488 END DO 16489 Enew % BoundaryInfo % Left => Eptr 16490! 16491! 2nd new element 16492! --------------- 16493 NewElCnt = NewElCnt + 1 16494 Enew => NewMesh % Elements(NewElCnt) 16495 Enew = Eold 16496 Enew % ElementIndex = NewElCnt 16497 CALL AllocateVector( Enew % NodeIndexes, 2 ) 16498 Enew % NodeIndexes(1) = Node 16499 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 16500 ALLOCATE( Enew % BoundaryInfo ) 16501 Enew % BoundaryInfo = Eold % BoundaryInfo 16502 NULLIFY( Enew % BoundaryInfo % Left ) 16503 NULLIFY( Enew % BoundaryInfo % Right ) 16504! 16505! Search the new mesh parent element among the 16506! children of the old mesh parent element: 16507! -------------------------------------------- 16508 DO j=1,4 16509 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16510 n = Eptr % TYPE % NumberOfNodes 16511 Found = .FALSE. 16512 DO k=1,n-1 16513 IF ( Enew % NodeIndexes(1) == Eptr % NodeIndexes(k) .AND. & 16514 Enew % NodeIndexes(2) == Eptr % NodeIndexes(k+1) .OR. & 16515 Enew % NodeIndexes(2) == Eptr % NodeIndexes(k) .AND. & 16516 Enew % NodeIndexes(1) == Eptr % NodeIndexes(k+1) ) THEN 16517 Found = .TRUE. 16518 EXIT 16519 END IF 16520 END DO 16521 IF ( Enew % NodeIndexes(1) == Eptr % NodeIndexes(n) .AND. & 16522 Enew % NodeIndexes(2) == Eptr % NodeIndexes(1) .OR. & 16523 Enew % NodeIndexes(2) == Eptr % NodeIndexes(n) .AND. & 16524 Enew % NodeIndexes(1) == Eptr % NodeIndexes(1) ) THEN 16525 Found = .TRUE. 16526 END IF 16527 IF ( Found ) EXIT 16528 END DO 16529 Enew % BoundaryInfo % Left => Eptr 16530 16531 CASE(3) 16532! 16533! Trias: 16534! ====== 16535! 16536! On which face of the parent element are we ? 16537! -------------------------------------------- 16538 EoldNodes(1:3) = Eold % NodeIndexes(1:3) 16539 CALL sort( 3, EoldNodes ) 16540 16541 DO FaceNumber = 1, SIZE( Eparent % FaceIndexes ) 16542 Face => Mesh % Faces( Eparent % FaceIndexes(FaceNumber) ) 16543 FaceNodes(1:3) = Face % NodeIndexes(1:3) 16544 CALL sort( 3, FaceNodes ) 16545 16546 IF ( EoldNodes(1) == FaceNodes(1) .AND. & 16547 EoldNodes(2) == FaceNodes(2) .AND. & 16548 EoldNodes(3) == FaceNodes(3) ) EXIT 16549 16550 END DO 16551! 16552! Then, what are the edges on this face? 16553! -------------------------------------- 16554! 16555! First edge: 16556! ----------- 16557 EoldNodes(1) = MIN( Eold % NodeIndexes(1), Eold % NodeIndexes(2) ) 16558 EoldNodes(2) = MAX( Eold % NodeIndexes(1), Eold % NodeIndexes(2) ) 16559 DO Edge1 = 1,SIZE(Eparent % EdgeIndexes) 16560 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge1) ) 16561 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16562 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16563 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16564 EoldNodes(2) == EdgeNodes(2) ) EXIT 16565 END DO 16566 16567! Second edge: 16568! ------------ 16569 EoldNodes(1) = MIN( Eold % NodeIndexes(2), Eold % NodeIndexes(3) ) 16570 EoldNodes(2) = MAX( Eold % NodeIndexes(2), Eold % NodeIndexes(3) ) 16571 DO Edge2 = 1,SIZE(Eparent % EdgeIndexes) 16572 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge2) ) 16573 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16574 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16575 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16576 EoldNodes(2) == EdgeNodes(2) ) EXIT 16577 END DO 16578 16579! Third edge: 16580! ----------- 16581 EoldNodes(1) = MIN( Eold % NodeIndexes(3), Eold % NodeIndexes(1) ) 16582 EoldNodes(2) = MAX( Eold % NodeIndexes(3), Eold % NodeIndexes(1) ) 16583 DO Edge3 = 1,SIZE(Eparent % EdgeIndexes) 16584 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge3) ) 16585 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16586 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16587 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16588 EoldNodes(2) == EdgeNodes(2) ) EXIT 16589 END DO 16590! 16591! index of the old face and edge centerpoints 16592! in the new mesh nodal arrays: 16593! ---------------------------------------- 16594 Node12 = Eparent % EdgeIndexes(Edge1) + Mesh % NumberOfNodes 16595 Node23 = Eparent % EdgeIndexes(Edge2) + Mesh % NumberOfNodes 16596 Node31 = Eparent % EdgeIndexes(Edge3) + Mesh % NumberOfNodes 16597! 16598! 1st new element 16599! --------------- 16600 NewElCnt = NewElCnt + 1 16601 Enew => NewMesh % Elements(NewElCnt) 16602 Enew = Eold 16603 Enew % ElementIndex = NewElCnt 16604 CALL AllocateVector( Enew % NodeIndexes, 3 ) 16605 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 16606 Enew % NodeIndexes(2) = Node12 16607 Enew % NodeIndexes(3) = Node31 16608 ALLOCATE( Enew % BoundaryInfo ) 16609 Enew % BoundaryInfo = Eold % BoundaryInfo 16610 NULLIFY( Enew % BoundaryInfo % Left ) 16611 NULLIFY( Enew % BoundaryInfo % Right ) 16612! 16613! Search the new mesh parent element among the 16614! children of the old mesh parent element: 16615! -------------------------------------------- 16616 DO j=1,8 16617 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16618 n = Eptr % TYPE % NumberOfNodes 16619 n3 = 0 ! Count matches (metodo stupido) 16620 DO n1 = 1,3 16621 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16622 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16623 END DO 16624 END DO 16625 IF ( n3 > 2 ) EXIT 16626 END DO 16627 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16628 Enew % BoundaryInfo % Left => Eptr 16629! 16630! 2nd new element 16631! --------------- 16632 NewElCnt = NewElCnt + 1 16633 Enew => NewMesh % Elements(NewElCnt) 16634 Enew = Eold 16635 Enew % ElementIndex = NewElCnt 16636 CALL AllocateVector( Enew % NodeIndexes, 3 ) 16637 Enew % NodeIndexes(1) = Node12 16638 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 16639 Enew % NodeIndexes(3) = Node23 16640 ALLOCATE( Enew % BoundaryInfo ) 16641 Enew % BoundaryInfo = Eold % BoundaryInfo 16642 NULLIFY( Enew % BoundaryInfo % Left ) 16643 NULLIFY( Enew % BoundaryInfo % Right ) 16644! 16645! Search the new mesh parent element among the 16646! children of the old mesh parent element: 16647! -------------------------------------------- 16648 DO j=1,8 16649 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16650 n = Eptr % TYPE % NumberOfNodes 16651 n3 = 0 ! Count matches (metodo stupido) 16652 DO n1 = 1,3 16653 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16654 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16655 END DO 16656 END DO 16657 IF ( n3 > 2 ) EXIT 16658 END DO 16659 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16660 Enew % BoundaryInfo % Left => Eptr 16661! 16662! 3rd new element 16663! --------------- 16664 NewElCnt = NewElCnt + 1 16665 Enew => NewMesh % Elements(NewElCnt) 16666 Enew = Eold 16667 Enew % ElementIndex = NewElCnt 16668 CALL AllocateVector( Enew % NodeIndexes, 3 ) 16669 Enew % NodeIndexes(1) = Node12 16670 Enew % NodeIndexes(2) = Node23 16671 Enew % NodeIndexes(3) = Node31 16672 ALLOCATE( Enew % BoundaryInfo ) 16673 Enew % BoundaryInfo = Eold % BoundaryInfo 16674 NULLIFY( Enew % BoundaryInfo % Left ) 16675 NULLIFY( Enew % BoundaryInfo % Right ) 16676! 16677! Search the new mesh parent element among the 16678! children of the old mesh parent element: 16679! -------------------------------------------- 16680 DO j=1,8 16681 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16682 n = Eptr % TYPE % NumberOfNodes 16683 n3 = 0 ! Count matches (metodo stupido) 16684 DO n1 = 1,3 16685 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16686 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16687 END DO 16688 END DO 16689 IF ( n3 > 2 ) EXIT 16690 END DO 16691 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16692 Enew % BoundaryInfo % Left => Eptr 16693! 16694! 4th new element 16695! --------------- 16696 NewElCnt = NewElCnt + 1 16697 Enew => NewMesh % Elements(NewElCnt) 16698 Enew = Eold 16699 Enew % ElementIndex = NewElCnt 16700 CALL AllocateVector( Enew % NodeIndexes, 3 ) 16701 Enew % NodeIndexes(1) = Node31 16702 Enew % NodeIndexes(2) = Node23 16703 Enew % NodeIndexes(3) = Eold % NodeIndexes(3) 16704 ALLOCATE( Enew % BoundaryInfo ) 16705 Enew % BoundaryInfo = Eold % BoundaryInfo 16706 NULLIFY( Enew % BoundaryInfo % Left ) 16707 NULLIFY( Enew % BoundaryInfo % Right ) 16708! 16709! Search the new mesh parent element among the 16710! children of the old mesh parent element: 16711! -------------------------------------------- 16712 DO j=1,8 16713 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16714 n = Eptr % TYPE % NumberOfNodes 16715 n3 = 0 ! Count matches (metodo stupido) 16716 DO n1 = 1,3 16717 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16718 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16719 END DO 16720 END DO 16721 IF ( n3 > 2 ) EXIT 16722 END DO 16723 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16724 Enew % BoundaryInfo % Left => Eptr 16725 16726 CASE(4) 16727! 16728! Quads: 16729! ====== 16730! 16731! On which face of the parent element are we ? 16732! -------------------------------------------- 16733 EoldNodes(1:4) = Eold % NodeIndexes(1:4) 16734 CALL sort( 4, EoldNodes ) 16735 16736 DO FaceNumber = 1, SIZE( Eparent % FaceIndexes ) 16737 Face => Mesh % Faces( Eparent % FaceIndexes(FaceNumber) ) 16738 FaceNodes(1:4) = Face % NodeIndexes(1:4) 16739 CALL sort( 4, FaceNodes ) 16740 16741 IF ( EoldNodes(1) == FaceNodes(1) .AND. & 16742 EoldNodes(2) == FaceNodes(2) .AND. & 16743 EoldNodes(3) == FaceNodes(3) .AND. & 16744 EoldNodes(4) == FaceNodes(4) ) EXIT 16745 16746 END DO 16747 16748! Then, what are the edges on this face? 16749! -------------------------------------- 16750! 16751! First edge: 16752! ----------- 16753 EoldNodes(1) = MIN( Eold % NodeIndexes(1), Eold % NodeIndexes(2) ) 16754 EoldNodes(2) = MAX( Eold % NodeIndexes(1), Eold % NodeIndexes(2) ) 16755 DO Edge1 = 1,SIZE(Eparent % EdgeIndexes) 16756 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge1) ) 16757 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16758 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16759 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16760 EoldNodes(2) == EdgeNodes(2) ) EXIT 16761 END DO 16762 16763! Second edge: 16764! ------------ 16765 EoldNodes(1) = MIN( Eold % NodeIndexes(2), Eold % NodeIndexes(3) ) 16766 EoldNodes(2) = MAX( Eold % NodeIndexes(2), Eold % NodeIndexes(3) ) 16767 DO Edge2 = 1,SIZE(Eparent % EdgeIndexes) 16768 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge2) ) 16769 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16770 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16771 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16772 EoldNodes(2) == EdgeNodes(2) ) EXIT 16773 END DO 16774 16775! Third edge: 16776! ----------- 16777 EoldNodes(1) = MIN( Eold % NodeIndexes(3), Eold % NodeIndexes(4) ) 16778 EoldNodes(2) = MAX( Eold % NodeIndexes(3), Eold % NodeIndexes(4) ) 16779 DO Edge3 = 1,SIZE(Eparent % EdgeIndexes) 16780 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge3) ) 16781 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16782 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16783 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16784 EoldNodes(2) == EdgeNodes(2) ) EXIT 16785 END DO 16786 16787! Fourth edge: 16788! ----------- 16789 EoldNodes(1) = MIN( Eold % NodeIndexes(4), Eold % NodeIndexes(1) ) 16790 EoldNodes(2) = MAX( Eold % NodeIndexes(4), Eold % NodeIndexes(1) ) 16791 DO Edge4 = 1,SIZE(Eparent % EdgeIndexes) 16792 Edge => Mesh % Edges( Eparent % EdgeIndexes(Edge4) ) 16793 EdgeNodes(1) = MIN( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16794 EdgeNodes(2) = MAX( Edge % NodeIndexes(1), Edge % NodeIndexes(2) ) 16795 IF ( EoldNodes(1) == EdgeNodes(1) .AND. & 16796 EoldNodes(2) == EdgeNodes(2) ) EXIT 16797 END DO 16798! 16799! index of the old face and edge centerpoints 16800! in the new mesh nodal arrays: 16801! ---------------------------------------- 16802 Node = FacePerm(Eparent % FaceIndexes(FaceNumber)) ! faces mid-point 16803 Node12 = Eparent % EdgeIndexes(Edge1) + Mesh % NumberOfNodes 16804 Node23 = Eparent % EdgeIndexes(Edge2) + Mesh % NumberOfNodes 16805 Node34 = Eparent % EdgeIndexes(Edge3) + Mesh % NumberOfNodes 16806 Node41 = Eparent % EdgeIndexes(Edge4) + Mesh % NumberOfNodes 16807! 16808! 1st new element 16809! --------------- 16810 NewElCnt = NewElCnt + 1 16811 Enew => NewMesh % Elements(NewElCnt) 16812 Enew = Eold 16813 Enew % ElementIndex = NewElCnt 16814 CALL AllocateVector( Enew % NodeIndexes, 4 ) 16815 Enew % NodeIndexes(1) = Eold % NodeIndexes(1) 16816 Enew % NodeIndexes(2) = Node12 16817 Enew % NodeIndexes(3) = Node 16818 Enew % NodeIndexes(4) = Node41 16819 ALLOCATE( Enew % BoundaryInfo ) 16820 Enew % BoundaryInfo = Eold % BoundaryInfo 16821 NULLIFY( Enew % BoundaryInfo % Left ) 16822 NULLIFY( Enew % BoundaryInfo % Right ) 16823! 16824! Search the new mesh parent element among the 16825! children of the old mesh parent element: 16826! -------------------------------------------- 16827 DO j=1,8 16828 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16829 n = Eptr % TYPE % NumberOfNodes 16830 n3 = 0 ! Count matches (metodo stupido) 16831 DO n1 = 1,4 16832 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16833 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16834 END DO 16835 END DO 16836 IF ( n3 > 2 ) EXIT 16837 END DO 16838 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16839 Enew % BoundaryInfo % Left => Eptr 16840! 16841! 2nd new element 16842! --------------- 16843 NewElCnt = NewElCnt + 1 16844 Enew => NewMesh % Elements(NewElCnt) 16845 Enew = Eold 16846 Enew % ElementIndex = NewElCnt 16847 CALL AllocateVector( Enew % NodeIndexes, 4 ) 16848 Enew % NodeIndexes(1) = Node12 16849 Enew % NodeIndexes(2) = Eold % NodeIndexes(2) 16850 Enew % NodeIndexes(3) = Node23 16851 Enew % NodeIndexes(4) = Node 16852 ALLOCATE( Enew % BoundaryInfo ) 16853 Enew % BoundaryInfo = Eold % BoundaryInfo 16854 NULLIFY( Enew % BoundaryInfo % Left ) 16855 NULLIFY( Enew % BoundaryInfo % Right ) 16856! 16857! Search the new mesh parent element among the 16858! children of the old mesh parent element: 16859! -------------------------------------------- 16860 DO j=1,8 16861 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16862 n = Eptr % TYPE % NumberOfNodes 16863 n3 = 0 ! Count matches (metodo stupido) 16864 DO n1 = 1,4 16865 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16866 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16867 END DO 16868 END DO 16869 IF ( n3 > 2 ) EXIT 16870 END DO 16871 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16872 Enew % BoundaryInfo % Left => Eptr 16873! 16874! 3rd new element 16875! --------------- 16876 NewElCnt = NewElCnt + 1 16877 Enew => NewMesh % Elements(NewElCnt) 16878 Enew = Eold 16879 Enew % ElementIndex = NewElCnt 16880 CALL AllocateVector( Enew % NodeIndexes, 4 ) 16881 Enew % NodeIndexes(1) = Node41 16882 Enew % NodeIndexes(2) = Node 16883 Enew % NodeIndexes(3) = Node34 16884 Enew % NodeIndexes(4) = Eold % NodeIndexes(4) 16885 ALLOCATE( Enew % BoundaryInfo ) 16886 Enew % BoundaryInfo = Eold % BoundaryInfo 16887 NULLIFY( Enew % BoundaryInfo % Left ) 16888 NULLIFY( Enew % BoundaryInfo % Right ) 16889! 16890! Search the new mesh parent element among the 16891! children of the old mesh parent element: 16892! -------------------------------------------- 16893 DO j=1,8 16894 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16895 n = Eptr % TYPE % NumberOfNodes 16896 n3 = 0 ! Count matches (metodo stupido) 16897 DO n1 = 1,4 16898 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16899 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16900 END DO 16901 END DO 16902 IF ( n3 > 2 ) EXIT 16903 END DO 16904 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16905 Enew % BoundaryInfo % Left => Eptr 16906! 16907! 4th new element 16908! --------------- 16909 NewElCnt = NewElCnt + 1 16910 Enew => NewMesh % Elements(NewElCnt) 16911 Enew = Eold 16912 Enew % ElementIndex = NewElCnt 16913 CALL AllocateVector( Enew % NodeIndexes, 4 ) 16914 Enew % NodeIndexes(1) = Node 16915 Enew % NodeIndexes(2) = Node23 16916 Enew % NodeIndexes(3) = Eold % NodeIndexes(3) 16917 Enew % NodeIndexes(4) = Node34 16918 ALLOCATE( Enew % BoundaryInfo ) 16919 Enew % BoundaryInfo = Eold % BoundaryInfo 16920 NULLIFY( Enew % BoundaryInfo % Left ) 16921 NULLIFY( Enew % BoundaryInfo % Right ) 16922! 16923! Search the new mesh parent element among the 16924! children of the old mesh parent element: 16925! -------------------------------------------- 16926 DO j=1,8 16927 Eptr => NewMesh % Elements( Child(ParentId,j) ) 16928 n = Eptr % TYPE % NumberOfNodes 16929 n3 = 0 ! Count matches (metodo stupido) 16930 DO n1 = 1,4 16931 DO n2 = 1,SIZE(Eptr % NodeIndexes) 16932 IF( Enew % NodeIndexes(n1) == Eptr % NodeIndexes(n2) ) n3 = n3+1 16933 END DO 16934 END DO 16935 IF ( n3 > 2 ) EXIT 16936 END DO 16937 IF( n3 < 3 ) CALL Error( 'SplitMeshEqual', 'Parent element not found' ) 16938 Enew % BoundaryInfo % Left => Eptr 16939 END SELECT 16940 END DO 16941 16942! 16943! Update new mesh boundary element counts: 16944! ---------------------------------------- 16945 NewMesh % NumberOfBoundaryElements = NewElCnt - & 16946 NewMesh % NumberOfBulkElements 16947 NewMesh % MaxElementDOFs = Mesh % MaxElementDOFs 16948 NewMesh % MaxElementNodes = Mesh % MaxElementNodes 16949 16950 j = 0 16951 DO i=1,NewMesh % NumberOfBulkElements+NewMesh % NumberOfBoundaryElements 16952 Enew => NewMesh % Elements(i) 16953 16954 IF ( Enew % DGDOFs>0 ) THEN 16955 ALLOCATE(Enew % DGIndexes(Enew % DGDOFs)) 16956 DO k=1,Enew % DGDOFs 16957 j = j + 1 16958 Enew % DGIndexes(k)=j 16959 END DO 16960 ELSE 16961 Enew % DGIndexes=>NULL() 16962 END IF 16963 16964 IF (i<=NewMesh % NumberOfBulkElements) THEN 16965 PDefs => Enew % PDefs 16966 16967 IF(ASSOCIATED(PDefs)) THEN 16968 CALL AllocatePDefinitions(Enew) 16969 Enew % PDefs = PDefs 16970 16971 ! All elements in actual mesh are not edges 16972 Enew % PDefs % pyramidQuadEdge = .FALSE. 16973 Enew % PDefs % isEdge = .FALSE. 16974 16975 ! If element is of type tetrahedron and is a p element, 16976 ! do the Ainsworth & Coyle trick 16977 IF (Enew % TYPE % ElementCode == 504) CALL ConvertToACTetra(Enew) 16978 CALL GetRefPElementNodes( Enew % Type, Enew % Type % NodeU, & 16979 Enew % Type % NodeV, Enew % Type % NodeW ) 16980 END IF 16981 ELSE 16982 Enew % PDefs=>NULL() 16983 END IF 16984 Enew % EdgeIndexes => NULL() 16985 Enew % FaceIndexes => NULL() 16986 Enew % BubbleIndexes => NULL() 16987 END DO 16988 16989 CALL Info( 'SplitMeshEqual', '******** New mesh ********', Level=6 ) 16990 WRITE( Message, * ) 'Nodes : ',NewMesh % NumberOfNodes 16991 CALL Info( 'SplitMeshEqual', Message, Level=6 ) 16992 WRITE( Message, * ) 'Bulk elements : ',NewMesh % NumberOfBulkElements 16993 CALL Info( 'SplitMeshEqual', Message, Level=6 ) 16994 WRITE( Message, * ) 'Boundary elements : ',NewMesh % NumberOfBoundaryElements 16995 CALL Info( 'SplitMeshEqual', Message, Level=6 ) 16996 16997 16998 ! Information of the new system size, also in parallel 16999 !---------------------------------------------------------------------- 17000 ParTmp(1) = Mesh % NumberOfNodes 17001 ParTmp(2) = Mesh % NumberOfBulkElements 17002 ParTmp(3) = Mesh % NumberOfBoundaryElements 17003 ParTmp(4) = NewMesh % NumberOfNodes 17004 ParTmp(5) = NewMesh % NumberOfBulkElements 17005 ParTmp(6) = NewMesh % NumberOfBoundaryElements 17006 17007 IF( .FALSE. .AND. ParEnv % PEs > 1 ) THEN 17008 CALL MPI_ALLREDUCE(ParTmp,ParSizes,6,MPI_INTEGER,MPI_SUM,ELMER_COMM_WORLD,ierr) 17009 17010 CALL Info('SplitMeshEqual','Information on parallel mesh sizes') 17011 WRITE ( Message,'(A,I0,A)') 'Initial mesh has ',ParSizes(1),' nodes' 17012 CALL Info('SplitMeshEqual',Message) 17013 WRITE ( Message,'(A,I0,A)') 'Initial mesh has ',ParSizes(2),' bulk elements' 17014 CALL Info('SplitMeshEqual',Message) 17015 WRITE ( Message,'(A,I0,A)') 'Initial mesh has ',ParSizes(3),' boundary elements' 17016 CALL Info('SplitMeshEqual',Message) 17017 WRITE ( Message,'(A,I0,A)') 'New mesh has ',ParSizes(4),' nodes' 17018 CALL Info('SplitMeshEqual',Message) 17019 WRITE ( Message,'(A,I0,A)') 'New mesh has ',ParSizes(5),' bulk elements' 17020 CALL Info('SplitMeshEqual',Message) 17021 WRITE ( Message,'(A,I0,A)') 'New mesh has ',ParSizes(6),' boundary elements' 17022 CALL Info('SplitMeshEqual',Message) 17023 END IF 17024 17025 17026 CALL CheckTimer('SplitMeshEqual',Delete=.TRUE.) 17027 17028! 17029! Update structures needed for parallel execution: 17030! ------------------------------------------------ 17031 CALL UpdateParallelMesh( Mesh, NewMesh ) 17032! 17033! 17034! Finalize: 17035! --------- 17036 DEALLOCATE( Child ) 17037 IF(.NOT.EdgesPresent) THEN 17038 CALL ReleaseMeshEdgeTables( Mesh ) 17039 CALL ReleaseMeshFaceTables( Mesh ) 17040 ELSE 17041 CALL FindMeshEdges( NewMesh ) 17042 END IF 17043 17044!call writemeshtodisk( NewMesh, "." ) 17045!stop 17046CONTAINS 17047 17048!------------------------------------------------------------------------------ 17049 SUBROUTINE UpdateParallelMesh( Mesh, NewMesh ) 17050!------------------------------------------------------------------------------ 17051 TYPE(Mesh_t), POINTER :: Mesh, NewMesh 17052!------------------------------------------------------------------------------ 17053 TYPE(Element_t), POINTER :: Edge, Face, Element, BoundaryElement 17054 INTEGER :: i,j,k,l,m,n,p,q, istat 17055 INTEGER, POINTER :: IntCnts(:),IntArray(:),Reorder(:) 17056 INTEGER, ALLOCATABLE :: list1(:), list2(:) 17057 LOGICAL, ALLOCATABLE :: InterfaceTag(:) 17058 17059 INTEGER :: jedges 17060 LOGICAL :: Found 17061!------------------------------------------------------------------------------ 17062 17063 IF ( ParEnv % PEs <= 1 ) RETURN 17064! 17065! Update mesh interfaces for parallel execution. 17066! ============================================== 17067! 17068! Try to get an agreement about the global numbering 17069! of new mesh nodes among set of processes solving 17070! this specific eq. Also allocate and generate 17071! all other control information needed in parallel 17072! execution: 17073! ---------------------------------------------------- 17074 n = NewMesh % NumberOfNodes 17075 ALLOCATE( NewMesh % ParallelInfo % NeighbourList(n), stat=istat ) 17076 IF ( istat /= 0 ) & 17077 CALL Fatal( 'UpdateParallelMesh', 'Allocate error.' ) 17078 CALL AllocateVector( NewMesh % ParallelInfo % INTERFACE,n ) 17079 CALL AllocateVector( NewMesh % ParallelInfo % GlobalDOFs,n ) 17080 17081 DO i=1,n 17082 NULLIFY( NewMesh % ParallelInfo % NeighbourList(i) % Neighbours ) 17083 END DO 17084 17085 n = Mesh % NumberOfNodes 17086 NewMesh % ParallelInfo % INTERFACE = .FALSE. 17087 NewMesh % ParallelInfo % INTERFACE(1:n) = Mesh % ParallelInfo % INTERFACE 17088 17089 NewMesh % ParallelInfo % GlobalDOFs = 0 17090 NewMesh % ParallelInfo % GlobalDOFs(1:n) = & 17091 Mesh % ParallelInfo % GlobalDOFs 17092! 17093! My theory is, that a new node will be an 17094! interface node only if all the edge or face 17095! nodes which contribute to its existence are 17096! interface nodes (the code immediately below 17097! will only count sizes): 17098! ------------------------------------------- 17099! 17100 17101 ! New version based on edges and faces (2. March 2007): 17102 !===================================================== 17103 SELECT CASE( CoordinateSystemDimension() ) 17104 17105 CASE(2) 17106 ! 17107 ! Count interface nodes: 17108 !----------------------- 17109 p = 0 17110 DO i = 1, Mesh % NumberOfNodes 17111 IF( Mesh % ParallelInfo % INTERFACE(i) ) p = p+1 17112 END DO 17113! WRITE(*,'(A,I4,A,I6,A)')'SplitMeshEqual: PE:', & 17114! Parenv % MyPE+1, ' Found',p,' interface nodes' 17115 ! 17116 ! Determine possible interface edges: 17117 !------------------------------------ 17118 ALLOCATE( InterfaceTag( Mesh % NumberOfEdges ) ) 17119 InterfaceTag = .FALSE. 17120 DO i = 1,Mesh % NumberOfEdges 17121 Edge => Mesh % Edges(i) 17122 IF( ASSOCIATED(Edge % BoundaryInfo % Left) .AND. & 17123 ASSOCIATED(Edge % BoundaryInfo % Right) ) CYCLE 17124 IF( .NOT.ALL( Mesh % ParallelInfo % INTERFACE( Edge % NodeIndexes ) )) CYCLE 17125 InterfaceTag(i) = .TRUE. 17126 END DO 17127 ! 17128 ! Eliminate false positives based on BoundaryElement -data: 17129 !---------------------------------------------------------- 17130 DO i = 1,Mesh % NumberOfBoundaryElements 17131 BoundaryElement => Mesh % Elements( Mesh % NumberOfBulkElements + i ) 17132 Element => BoundaryElement % BoundaryInfo % Left 17133 IF( .NOT.ASSOCIATED( Element ) ) & 17134 Element => BoundaryElement % BoundaryInfo % Right 17135 IF( .NOT.ASSOCIATED( Element ) ) CYCLE 17136 IF( .NOT.ASSOCIATED( Element % EdgeIndexes ) ) CYCLE 17137 17138 ALLOCATE( list1( SIZE( BoundaryElement % NodeIndexes ))) 17139 list1 = BoundaryElement % NodeIndexes 17140 CALL Sort( SIZE(list1), list1 ) 17141 17142 DO j = 1,Element % TYPE % NumberOfEdges 17143 k = Element % EdgeIndexes(j) 17144 Edge => Mesh % Edges(k) 17145 IF( SIZE( Edge % NodeIndexes ) /= SIZE(list1) ) CYCLE 17146 17147 ALLOCATE( list2( SIZE( Edge % NodeIndexes ))) 17148 list2 = Edge % NodeIndexes 17149 CALL Sort( SIZE(list2), list2 ) 17150 17151 Found = .TRUE. 17152 DO l = 1,SIZE(list2) 17153 Found = Found .AND. ( list1(l)==list2(l) ) 17154 END DO 17155 17156 DEALLOCATE(list2) 17157 IF( Found ) InterfaceTag(k) = .FALSE. 17158 END DO 17159 17160 DEALLOCATE(list1) 17161 END DO 17162 17163 ! Mark all new interface nodes and count interface edges: 17164 !-------------------------------------------------------- 17165 p = 0 17166 DO i = 1, Mesh % NumberOfEdges 17167 IF( .NOT. InterfaceTag(i) ) CYCLE 17168 Edge => Mesh % Edges(i) 17169 17170 ! This is just for the edge count: 17171 !--------------------------------- 17172 IF( NewMesh % ParallelInfo % INTERFACE( Mesh % NumberOfNodes + i) ) CYCLE 17173 17174 ! Mark interface nodes and count edges: 17175 !-------------------------------------- 17176 NewMesh % ParallelInfo % INTERFACE( Mesh % NumberOfNodes + i) = .TRUE. 17177 p = p+1 17178 17179 END DO 17180! WRITE(*,'(A,I4,A,I6,A)')'SplitMeshEqual: PE:', & 17181! Parenv % MyPE+1, ' Found',p,' interface edges' 17182 17183 DEALLOCATE( InterfaceTag ) 17184 17185 j = p 17186 k = 2*p ! check 17187 17188 CASE(3) 17189 17190 ! Count interface nodes: 17191 !----------------------- 17192 p = 0 17193 DO i = 1, Mesh % NumberOfNodes 17194 IF( Mesh % ParallelInfo % INTERFACE(i) ) p = p+1 17195 END DO 17196! WRITE(*,'(A,I4,A,I6,A)')'SplitMeshEqual: PE:', & 17197! Parenv % MyPE+1, ' Found',p,' interface nodes' 17198 17199 ! Determine possible interface faces: 17200 !------------------------------------ 17201 ALLOCATE( InterfaceTag( Mesh % NumberOfFaces ) ) 17202 InterfaceTag = .FALSE. 17203 DO i = 1,Mesh % NumberOfFaces 17204 Face => Mesh % Faces(i) 17205 IF( ASSOCIATED(Face % BoundaryInfo % Left) .AND. & 17206 ASSOCIATED(Face % BoundaryInfo % Right) ) CYCLE 17207 IF( .NOT.ALL( Mesh % ParallelInfo % INTERFACE( Face % NodeIndexes ) )) CYCLE 17208 InterfaceTag(i) = .TRUE. 17209 END DO 17210 17211 ! Eliminate false interface faces based on BoundaryElement -data: 17212 !---------------------------------------------------------------- 17213 DO i = 1,Mesh % NumberOfBoundaryElements 17214 BoundaryElement => Mesh % Elements(Mesh % NumberOfBulkElements+i) 17215 Element => BoundaryElement % BoundaryInfo % Left 17216 IF( .NOT.ASSOCIATED(Element) ) & 17217 Element => BoundaryElement % BoundaryInfo % Right 17218 IF( .NOT.ASSOCIATED(Element) ) CYCLE 17219 IF( .NOT.ASSOCIATED(Element % FaceIndexes) ) CYCLE 17220 17221 ALLOCATE(list1(SIZE(BoundaryElement % NodeIndexes))) 17222 list1 = BoundaryElement % NodeIndexes 17223 CALL Sort(SIZE(list1),list1) 17224 17225 DO j = 1,Element % TYPE % NumberOfFaces 17226 k = Element % FaceIndexes(j) 17227 Face => Mesh % Faces(k) 17228 IF(SIZE(Face % NodeIndexes)/= SIZE(list1) ) CYCLE 17229 17230 ALLOCATE( list2( SIZE( Face % NodeIndexes ))) 17231 list2 = Face % NodeIndexes 17232 CALL Sort( SIZE(list2), list2 ) 17233 17234 Found = .TRUE. 17235 DO l = 1,SIZE(list2) 17236 Found = Found .AND. ( list1(l)==list2(l) ) 17237 END DO 17238 17239 DEALLOCATE(list2) 17240 17241 IF( Found ) InterfaceTag(k) = .FALSE. 17242 END DO 17243 17244 DEALLOCATE(list1) 17245 END DO 17246 17247 ! Count interface faces: 17248 !----------------------- 17249 p = 0 17250 DO i = 1, Mesh % NumberOfFaces 17251 Face => Mesh % Faces(i) 17252 IF( InterfaceTag(i) ) p = p+1 17253 END DO 17254! WRITE(*,'(A,I4,A,I6,A)')'SplitMeshEqual: PE:', & 17255! Parenv % MyPE+1, ' Found',p,' interface faces' 17256 17257 ! Mark all new interface nodes and count interface edges: 17258 !-------------------------------------------------------- 17259 p = 0 17260 DO i = 1, Mesh % NumberOfFaces 17261 IF( .NOT. InterfaceTag(i) ) CYCLE 17262 Face => Mesh % Faces(i) 17263 17264 DO j = 1,SIZE( Face % EdgeIndexes ) 17265 k = Face % EdgeIndexes(j) 17266 Edge => Mesh % Edges(k) 17267 17268 ! This is just for the edge count: 17269 !--------------------------------- 17270 IF( NewMesh % ParallelInfo % INTERFACE( Mesh % NumberOfNodes + k) ) CYCLE 17271 17272 ! Mark interface nodes and count edges: 17273 !-------------------------------------- 17274 NewMesh % ParallelInfo % INTERFACE( Mesh % NumberOfNodes + k) = .TRUE. 17275 p = p+1 17276 END DO 17277 END DO 17278! WRITE(*,'(A,I4,A,I6,A)')'SplitMeshEqual: PE:', & 17279! Parenv % MyPE+1, ' Found',p,' interface edges' 17280 17281 DEALLOCATE( InterfaceTag ) 17282 17283 j = p 17284 k = 3*p ! check 17285 17286 END SELECT 17287 17288!====================================================================================================== 17289 j = p 17290 jedges = p 17291 17292! For bricks, check also the faces: 17293! --------------------------------- 17294 DO i = 1,Mesh % NumberOfFaces 17295 Face => Mesh % Faces(i) 17296 IF( Face % TYPE % NumberOfNodes == 4 ) THEN 17297 IF ( ALL( Mesh % ParallelInfo % INTERFACE( Face % NodeIndexes ) ) ) THEN 17298 NewMesh % ParallelInfo % INTERFACE( Mesh % NumberOfNodes & 17299 + Mesh % NumberOfEdges + i ) = .TRUE. 17300 j = j + 1 17301 k = k + Face % TYPE % NumberOfNodes 17302 END IF 17303 END IF 17304 END DO 17305 17306! CALL AllocateVector( IntCnts, j ) 17307! CALL AllocateVector( IntArray, k ) 17308! 17309! Old mesh nodes were copied as is... 17310! ----------------------------------- 17311 DO i=1,Mesh % NumberOfNodes 17312 CALL AllocateVector( NewMesh % ParallelInfo % NeighbourList(i) % Neighbours, & 17313 SIZE( Mesh % ParallelInfo % Neighbourlist(i) % Neighbours) ) 17314 17315 NewMesh % ParallelInfo % NeighbourList(i) % Neighbours = & 17316 Mesh % ParallelInfo % NeighbourList(i) % Neighbours 17317 END DO 17318! 17319! Take care of the new mesh internal nodes. 17320! Parallel global numbering will take care 17321! of the interface nodes: 17322! ---------------------------------------- 17323 DO i=Mesh % NumberOfNodes+1, NewMesh % NumberOfNodes 17324 IF ( .NOT. NewMesh % ParallelInfo % INTERFACE(i) ) THEN 17325 CALL AllocateVector( NewMesh % ParallelInfo % NeighbourList(i) % Neighbours,1 ) 17326 NewMesh % ParallelInfo % NeighbourList(i) % Neighbours(1) = ParEnv % MyPE 17327 END IF 17328 END DO 17329! 17330! Copy global indices of edge and/or face nodes 17331! to temporary work arrays: 17332! --------------------------------------------- 17333! 17334! check also this: 17335! j = 0 17336! k = 0 17337! DO i = 1,Mesh % NumberOfEdges 17338! Edge => Mesh % Edges(i) 17339! 17340! ! Added check for parent elements 25.2.2007: 17341! Found = .NOT.( ASSOCIATED(edge % boundaryinfo % left) & 17342! .AND. ASSOCIATED(edge % boundaryinfo % right) ) 17343! 17344! IF ( ALL(Mesh % ParallelInfo % INTERFACE(Edge % NodeIndexes)) .AND. Found ) THEN 17345! j = j + 1 17346! IntCnts(j) = Edge % TYPE % NumberOfNodes 17347! IntArray( k+1:k+IntCnts(j) ) = & 17348! Mesh % Parallelinfo % GlobalDOFs(Edge % NodeIndexes) 17349! CALL Sort( IntCnts(j), IntArray(k+1:k+IntCnts(j)) ) 17350! k = k + IntCnts(j) 17351! END IF 17352! END DO 17353! ! 17354! ! For bricks, check also the faces: 17355! ! --------------------------------- 17356! DO i = 1,Mesh % NumberOfFaces 17357! Face => Mesh % Faces(i) 17358! IF( Face % TYPE % NumberOfNodes == 4 ) THEN 17359! IF ( ALL( Mesh % ParallelInfo % INTERFACE(Face % NodeIndexes) ) ) THEN 17360! j = j + 1 17361! IntCnts(j) = Face % TYPE % NumberOfNodes 17362! IntArray(k+1:k+IntCnts(j)) = & 17363! Mesh % ParallelInfo % GlobalDOFs(Face % NodeIndexes) 17364! CALL Sort( IntCnts(j), IntArray(k+1:k+IntCnts(j)) ) 17365! k = k + IntCnts(j) 17366! END IF 17367! END IF 17368! END DO 17369! 17370! Finally the beef, do the exchange of new 17371! interfaces. The parallel global numbering 17372! subroutine will also do reordering of the 17373! nodes, hence the reorder array: 17374! ------------------------------------------- 17375 CALL AllocateVector( Reorder, NewMesh % NumberOfNodes ) 17376 Reorder = [ (i, i=1,NewMesh % NumberOfNodes) ] 17377 17378 k = NewMesh % Nodes % NumberOfNodes - Mesh % Nodes % NumberOfNodes 17379 CALL ParallelGlobalNumbering( NewMesh, Mesh, k, Reorder ) 17380 17381! Account for the reordering of the nodes: 17382! ---------------------------------------- 17383 DO i=1,NewMesh % NumberOfBulkElements + & 17384 NewMesh % NumberOfBoundaryElements 17385 NewMesh % Elements(i) % NodeIndexes = & 17386 Reorder( NewMesh % Elements(i) % NodeIndexes ) 17387 END DO 17388 17389! DEALLOCATE( IntCnts, IntArray, Reorder ) 17390! DEALLOCATE( Reorder ) 17391!------------------------------------------------------------------------------ 17392 END SUBROUTINE UpdateParallelMesh 17393 END FUNCTION SplitMeshEqual 17394!------------------------------------------------------------------------------ 17395 17396 17397!------------------------------------------------------------------------------ 17398 SUBROUTINE ReleaseMesh( Mesh ) 17399!------------------------------------------------------------------------------ 17400 TYPE(Mesh_t), POINTER :: Mesh 17401!------------------------------------------------------------------------------ 17402 TYPE(Projector_t), POINTER :: Projector 17403 TYPE(Projector_t), POINTER :: Projector1 17404 TYPE(Variable_t), POINTER :: Var, Var1 17405 INTEGER :: i,j,k 17406 LOGICAL :: GotIt 17407 REAL(KIND=dp), POINTER :: ptr(:) 17408!------------------------------------------------------------------------------ 17409 17410! Deallocate mesh variables: 17411! -------------------------- 17412 17413 17414 CALL Info('ReleaseMesh','Releasing mesh variables',Level=15) 17415 CALL ReleaseVariableList( Mesh % Variables ) 17416 Mesh % Variables => NULL() 17417 17418! Deallocate mesh geometry (nodes,elements and edges): 17419! ---------------------------------------------------- 17420 IF ( ASSOCIATED( Mesh % Nodes ) ) THEN 17421 CALL Info('ReleaseMesh','Releasing mesh nodes',Level=15) 17422 IF ( ASSOCIATED( Mesh % Nodes % x ) ) DEALLOCATE( Mesh % Nodes % x ) 17423 IF ( ASSOCIATED( Mesh % Nodes % y ) ) DEALLOCATE( Mesh % Nodes % y ) 17424 IF ( ASSOCIATED( Mesh % Nodes % z ) ) DEALLOCATE( Mesh % Nodes % z ) 17425 DEALLOCATE( Mesh % Nodes ) 17426 17427 IF ( ASSOCIATED( Mesh % ParallelInfo % GlobalDOFs ) ) & 17428 DEALLOCATE( Mesh % ParallelInfo % GlobalDOFs ) 17429 17430 IF ( ASSOCIATED( Mesh % ParallelInfo % NeighbourList ) ) THEN 17431 DO i=1,Mesh % NumberOfNodes 17432 IF(ASSOCIATED( Mesh % ParallelInfo % NeighbourList(i) % Neighbours ) ) & 17433 DEALLOCATE( Mesh % ParallelInfo % NeighbourList(i) % Neighbours ) 17434 END DO 17435 DEALLOCATE( Mesh % ParallelInfo % NeighbourList ) 17436 END IF 17437 17438 IF ( ASSOCIATED( Mesh % ParallelInfo % INTERFACE ) ) & 17439 DEALLOCATE( Mesh % ParallelInfo % INTERFACE ) 17440 END IF 17441 17442 Mesh % Nodes => NULL() 17443 17444 IF ( ASSOCIATED( Mesh % Edges ) ) THEN 17445 CALL Info('ReleaseMesh','Releasing mesh edges',Level=15) 17446 CALL ReleaseMeshEdgeTables( Mesh ) 17447 Mesh % Edges => NULL() 17448 END IF 17449 17450 IF ( ASSOCIATED( Mesh % Faces ) ) THEN 17451 CALL Info('ReleaseMesh','Releasing mesh faces',Level=15) 17452 CALL ReleaseMeshFaceTables( Mesh ) 17453 Mesh % Faces => NULL() 17454 END IF 17455 17456 IF (ASSOCIATED(Mesh % ViewFactors) ) THEN 17457 CALL Info('ReleaseMesh','Releasing mesh view factors',Level=15) 17458 CALL ReleaseMeshFactorTables( Mesh % ViewFactors ) 17459 Mesh % ViewFactors => NULL() 17460 END IF 17461 17462 17463! Deallocate mesh to mesh projector structures: 17464! --------------------------------------------- 17465 Projector => Mesh % Projector 17466 DO WHILE( ASSOCIATED( Projector ) ) 17467 CALL Info('ReleaseMesh','Releasing mesh projector',Level=15) 17468 CALL FreeMatrix( Projector % Matrix ) 17469 CALL FreeMatrix( Projector % TMatrix ) 17470 Projector1 => Projector 17471 Projector => Projector % Next 17472 DEALLOCATE( Projector1 ) 17473 END DO 17474 Mesh % Projector => NULL() 17475 17476 17477! Deallocate quadrant tree (used in mesh to mesh interpolation): 17478! -------------------------------------------------------------- 17479 IF( ASSOCIATED( Mesh % RootQuadrant ) ) THEN 17480 CALL Info('ReleaseMesh','Releasing mesh quadrant tree',Level=15) 17481 CALL FreeQuadrantTree( Mesh % RootQuadrant ) 17482 Mesh % RootQuadrant => NULL() 17483 END IF 17484 17485 17486 IF ( ASSOCIATED( Mesh % Elements ) ) THEN 17487 CALL Info('ReleaseMesh','Releasing mesh elements',Level=15) 17488 17489 DO i=1,Mesh % NumberOfBulkElements+Mesh % NumberOfBoundaryElements 17490 17491! Boundaryinfo structure for boundary elements 17492! --------------------------------------------- 17493 IF ( Mesh % Elements(i) % Copy ) CYCLE 17494 17495 IF ( i > Mesh % NumberOfBulkElements ) THEN 17496 IF ( ASSOCIATED( Mesh % Elements(i) % BoundaryInfo ) ) THEN 17497 IF (ASSOCIATED(Mesh % Elements(i) % BoundaryInfo % GebhardtFactors)) THEN 17498 IF ( ASSOCIATED( Mesh % Elements(i) % BoundaryInfo % & 17499 GebhardtFactors % Elements ) ) THEN 17500 DEALLOCATE( Mesh % Elements(i) % BoundaryInfo % & 17501 GebhardtFactors % Elements ) 17502 DEALLOCATE( Mesh % Elements(i) % BoundaryInfo % & 17503 GebhardtFactors % Factors ) 17504 END IF 17505 DEALLOCATE( Mesh % Elements(i) % BoundaryInfo % GebhardtFactors ) 17506 END IF 17507 DEALLOCATE( Mesh % Elements(i) % BoundaryInfo ) 17508 END IF 17509 END IF 17510 17511 IF ( ASSOCIATED( Mesh % Elements(i) % NodeIndexes ) ) & 17512 DEALLOCATE( Mesh % Elements(i) % NodeIndexes ) 17513 Mesh % Elements(i) % NodeIndexes => NULL() 17514 17515 IF ( ASSOCIATED( Mesh % Elements(i) % EdgeIndexes ) ) & 17516 DEALLOCATE( Mesh % Elements(i) % EdgeIndexes ) 17517 Mesh % Elements(i) % EdgeIndexes => NULL() 17518 17519 IF ( ASSOCIATED( Mesh % Elements(i) % FaceIndexes ) ) & 17520 DEALLOCATE( Mesh % Elements(i) % FaceIndexes ) 17521 Mesh % Elements(i) % FaceIndexes => NULL() 17522 17523 IF ( ASSOCIATED( Mesh % Elements(i) % DGIndexes ) ) & 17524 DEALLOCATE( Mesh % Elements(i) % DGIndexes ) 17525 Mesh % Elements(i) % DGIndexes => NULL() 17526 17527 IF ( ASSOCIATED( Mesh % Elements(i) % BubbleIndexes ) ) & 17528 DEALLOCATE( Mesh % Elements(i) % BubbleIndexes ) 17529 Mesh % Elements(i) % BubbleIndexes => NULL() 17530 17531 ! This creates problems later on!!! 17532 !IF ( ASSOCIATED( Mesh % Elements(i) % PDefs ) ) & 17533 ! DEALLOCATE( Mesh % Elements(i) % PDefs ) 17534 17535 Mesh % Elements(i) % PDefs => NULL() 17536 17537 END DO 17538 DEALLOCATE( Mesh % Elements ) 17539 Mesh % Elements => NULL() 17540 END IF 17541 17542 CALL Info('ReleaseMesh','Releasing mesh finished',Level=15) 17543 17544!------------------------------------------------------------------------------ 17545 END SUBROUTINE ReleaseMesh 17546!------------------------------------------------------------------------------ 17547 17548 17549!------------------------------------------------------------------------------ 17550 SUBROUTINE ReleaseMeshEdgeTables( Mesh ) 17551!------------------------------------------------------------------------------ 17552 TYPE(Mesh_t), POINTER :: Mesh 17553!------------------------------------------------------------------------------ 17554 INTEGER :: i 17555 TYPE(Element_t), POINTER :: Edge 17556!------------------------------------------------------------------------------ 17557 IF ( ASSOCIATED( Mesh % Edges ) ) THEN 17558 DO i=1,Mesh % NumberOfEdges 17559 Edge => Mesh % Edges(i) 17560 IF ( ASSOCIATED( Edge % NodeIndexes ) ) THEN 17561 DEALLOCATE( Edge % NodeIndexes ) 17562 END IF 17563 IF ( ASSOCIATED( Edge % BoundaryInfo ) ) THEN 17564 DEALLOCATE( Edge % BoundaryInfo ) 17565 END IF 17566 END DO 17567 17568 DEALLOCATE( Mesh % Edges ) 17569 END IF 17570 NULLIFY( Mesh % Edges ) 17571 Mesh % NumberOfEdges = 0 17572 17573 DO i=1,Mesh % NumberOfBulkElements 17574 IF ( ASSOCIATED( Mesh % Elements(i) % EdgeIndexes ) ) THEN 17575 DEALLOCATE( Mesh % Elements(i) % EdgeIndexes ) 17576 NULLIFY( Mesh % Elements(i) % EdgeIndexes ) 17577 END IF 17578 END DO 17579!------------------------------------------------------------------------------ 17580 END SUBROUTINE ReleaseMeshEdgeTables 17581!------------------------------------------------------------------------------ 17582 17583!------------------------------------------------------------------------------ 17584 SUBROUTINE ReleaseMeshFaceTables( Mesh ) 17585!------------------------------------------------------------------------------ 17586 TYPE(Mesh_t), POINTER :: Mesh 17587!------------------------------------------------------------------------------ 17588 INTEGER :: i 17589 TYPE(Element_t), POINTER :: Face 17590!------------------------------------------------------------------------------ 17591 IF ( ASSOCIATED( Mesh % Faces ) ) THEN 17592 DO i=1,Mesh % NumberOfFaces 17593 Face => Mesh % Faces(i) 17594 IF ( ASSOCIATED( Face % NodeIndexes ) ) THEN 17595 DEALLOCATE( Face % NodeIndexes ) 17596 END IF 17597 IF ( ASSOCIATED( Face % BoundaryInfo ) ) THEN 17598 DEALLOCATE( Face % BoundaryInfo ) 17599 END IF 17600 END DO 17601 17602 DEALLOCATE( Mesh % Faces ) 17603 END IF 17604 NULLIFY( Mesh % Faces ) 17605 Mesh % NumberOfFaces = 0 17606 17607 DO i=1,Mesh % NumberOfBulkElements 17608 IF ( ASSOCIATED( Mesh % Elements(i) % FaceIndexes ) ) THEN 17609 DEALLOCATE( Mesh % Elements(i) % FaceIndexes ) 17610 NULLIFY( Mesh % Elements(i) % FaceIndexes ) 17611 END IF 17612 END DO 17613!------------------------------------------------------------------------------ 17614 END SUBROUTINE ReleaseMeshFaceTables 17615!------------------------------------------------------------------------------ 17616 17617!------------------------------------------------------------------------------ 17618 SUBROUTINE ReleaseMeshFactorTables( Factors ) 17619!------------------------------------------------------------------------------ 17620 TYPE(Factors_t), POINTER :: Factors(:) 17621!------------------------------------------------------------------------------ 17622 INTEGER :: i 17623!------------------------------------------------------------------------------ 17624 IF ( ASSOCIATED( Factors ) ) THEN 17625 DO i=1,SIZE( Factors) 17626 IF (ASSOCIATED(Factors(i) % Factors)) DEALLOCATE(Factors(i) % Factors) 17627 IF (ASSOCIATED(Factors(i) % Elements)) DEALLOCATE(Factors(i) % Elements) 17628 END DO 17629 DEALLOCATE( Factors ) 17630 END IF 17631!------------------------------------------------------------------------------ 17632 END SUBROUTINE ReleaseMeshFactorTables 17633!------------------------------------------------------------------------------ 17634 17635 17636!------------------------------------------------------------------------------ 17637 SUBROUTINE SetCurrentMesh( Model, Mesh ) 17638!------------------------------------------------------------------------------ 17639 TYPE(Model_t) :: Model 17640 TYPE(Mesh_t), POINTER :: Mesh 17641!------------------------------------------------------------------------------ 17642 Model % Variables => Mesh % Variables 17643 17644 Model % Mesh => Mesh 17645 Model % Nodes => Mesh % Nodes 17646 Model % NumberOfNodes = Mesh % NumberOfNodes 17647 Model % Nodes % NumberOfNodes = Mesh % NumberOfNodes 17648 17649 Model % Elements => Mesh % Elements 17650 Model % MaxElementNodes = Mesh % MaxElementNodes 17651 Model % NumberOfBulkElements = Mesh % NumberOfBulkElements 17652 Model % NumberOfBoundaryElements = Mesh % NumberOfBoundaryElements 17653!------------------------------------------------------------------------------ 17654 END SUBROUTINE SetCurrentMesh 17655!------------------------------------------------------------------------------ 17656 17657 17658!---------------------------------------------------------------------------------- 17659 SUBROUTINE DisplaceMesh( Mesh, Update, SIGN, Perm, DOFs, StabRecomp, UpdateDirs ) 17660!---------------------------------------------------------------------------------- 17661 TYPE(Mesh_t) , POINTER :: Mesh 17662 REAL(KIND=dp) :: Update(:) 17663 INTEGER :: DOFs,SIGN,Perm(:) 17664 LOGICAL, OPTIONAL :: StabRecomp 17665 INTEGER, OPTIONAL :: UpdateDirs 17666 17667 INTEGER :: i,k,dim 17668 LOGICAL :: StabFlag 17669 17670 TYPE(Nodes_t) :: ElementNodes 17671 TYPE(Element_t), POINTER :: Element 17672 17673 IF ( PRESENT( UpdateDirs ) ) THEN 17674 dim = UpdateDirs 17675 ELSE 17676 dim = DOFs 17677 END IF 17678 17679 DO i=1,MIN( SIZE(Perm), SIZE(Mesh % Nodes % x) ) 17680 k = Perm(i) 17681 IF ( k > 0 ) THEN 17682 k = DOFs * (k-1) 17683 Mesh % Nodes % x(i) = Mesh % Nodes % x(i) + SIGN * Update(k+1) 17684 IF ( dim > 1 ) & 17685 Mesh % Nodes % y(i) = Mesh % Nodes % y(i) + SIGN * Update(k+2) 17686 IF ( dim > 2 ) & 17687 Mesh % Nodes % z(i) = Mesh % Nodes % z(i) + SIGN * Update(k+3) 17688 END IF 17689 END DO 17690 17691 StabFlag = .TRUE. 17692 IF ( PRESENT( StabRecomp ) ) StabFlag = StabRecomp 17693 17694 IF ( SIGN == 1 .AND. StabFlag ) THEN 17695 k = Mesh % MaxElementDOFs 17696 CALL AllocateVector( ElementNodes % x,k ) 17697 CALL AllocateVector( ElementNodes % y,k ) 17698 CALL AllocateVector( ElementNodes % z,k ) 17699 17700 DO i=1,Mesh % NumberOfBulkElements 17701 Element => Mesh % Elements(i) 17702 IF ( ANY( Perm( Element % NodeIndexes ) == 0 ) ) CYCLE 17703 17704 k = Element % TYPE % NumberOfNodes 17705 ElementNodes % x(1:k) = Mesh % Nodes % x(Element % NodeIndexes) 17706 ElementNodes % y(1:k) = Mesh % Nodes % y(Element % NodeIndexes) 17707 ElementNodes % z(1:k) = Mesh % Nodes % z(Element % NodeIndexes) 17708 IF ( Mesh % Stabilize ) THEN 17709 CALL StabParam( Element,ElementNodes,k, & 17710 Element % StabilizationMk, Element % Hk ) 17711 ELSE 17712 Element % hK = ElementDiameter( Element, ElementNodes ) 17713 END IF 17714 END DO 17715 17716 DEALLOCATE( ElementNodes % x, ElementNodes % y, ElementNodes % z) 17717 END IF 17718!------------------------------------------------------------------------------ 17719 END SUBROUTINE DisplaceMesh 17720!------------------------------------------------------------------------------ 17721 17722 17723!------------------------------------------------------------------------------ 17724!> Convert tetrahedral element to Ainsworth & Coyle type tetrahedron. 17725!------------------------------------------------------------------------------ 17726 SUBROUTINE ConvertToACTetra( Tetra ) 17727!------------------------------------------------------------------------------ 17728 USE PElementMaps, ONLY : getTetraEdgeMap, getTetraFaceMap 17729 IMPLICIT NONE 17730 17731 TYPE(Element_t), POINTER :: Tetra !< Tetrahedral element to convert 17732!------------------------------------------------------------------------------ 17733 INTEGER :: i, globalMin, globalMax, globalMinI 17734 INTEGER, DIMENSION(3) :: face, globalFace 17735 INTRINSIC MIN, MAX, CSHIFT 17736 17737 ! Sanity check 17738 IF (Tetra % TYPE % ElementCode /= 504 .OR. & 17739 .NOT. ASSOCIATED(Tetra % PDefs)) THEN 17740 CALL Warn('MeshUtils::ConvertToACTetra','Element to convert not p tetrahedron!') 17741 RETURN 17742 END IF 17743 17744 ! Find global min and max vertices 17745 globalMin = Tetra % NodeIndexes(1) 17746 globalMinI = 1 17747 globalMax = Tetra % NodeIndexes(1) 17748 DO i=2,4 17749 ! Find min 17750 IF (globalMin > Tetra % NodeIndexes(i)) THEN 17751 globalMin = Tetra % NodeIndexes(i) 17752 globalMinI = i 17753 ELSE IF (globalMax < Tetra % NodeIndexes(i)) THEN 17754 globalMax = Tetra % NodeIndexes(i) 17755 END IF 17756 END DO 17757 17758 ! Get face containing global min (either face 1 or 2) 17759 IF (globalMinI == 4) THEN 17760 face = getTetraFaceMap(2) 17761 ELSE 17762 face = getTetraFaceMap(1) 17763 END IF 17764 globalFace(1:3) = Tetra % NodeIndexes(face) 17765 17766 ! Rotate face until first local index is min global 17767 DO 17768 ! Check if first node matches global min node 17769 IF (globalMin == globalFace(1)) EXIT 17770 17771 globalFace(1:3) = CSHIFT(globalFace,1) 17772 END DO 17773 ! Assign new local numbering 17774 Tetra % NodeIndexes(face) = globalFace(1:3) 17775 17776 ! Face 3 now contains global max 17777 face = getTetraFaceMap(3) 17778 globalFace(1:3) = Tetra % NodeIndexes(face) 17779 ! Rotate face until last local index is max global 17780 DO 17781 ! Check if last node matches global max node 17782 IF (globalMax == globalFace(3)) EXIT 17783 17784 globalFace(1:3) = CSHIFT(globalFace,1) 17785 END DO 17786 ! Assign new local numbering 17787 Tetra % NodeIndexes(face) = globalFace(1:3) 17788 17789 ! Set AC tetra type 17790 IF (Tetra % NodeIndexes(2) < Tetra % NodeIndexes(3)) THEN 17791 Tetra % PDefs % TetraType = 1 17792 ELSE IF (Tetra % NodeIndexes(3) < Tetra % NodeIndexes(2)) THEN 17793 Tetra % PDefs % TetraType = 2 17794 ELSE 17795 CALL Fatal('MeshUtils::ConvertToACTetra','Corrupt element type') 17796 END IF 17797 17798 END SUBROUTINE ConvertToACTetra 17799 17800 17801!------------------------------------------------------------------------------ 17802!> Assign local number of edge to given boundary element. Also copies all 17803!> p element attributes from element edge to boundary edge. 17804!------------------------------------------------------------------------------ 17805 SUBROUTINE AssignLocalNumber( EdgeElement, Element, Mesh,NoPE ) 17806!------------------------------------------------------------------------------ 17807 USE PElementMaps, ONLY : getFaceEdgeMap 17808 IMPLICIT NONE 17809 17810 ! Parameters 17811 TYPE(Mesh_t) :: Mesh !< Finite element mesh containing faces and edges. 17812 TYPE(Element_t), POINTER :: EdgeElement !< Edge element to which assign local number 17813 TYPE(Element_t), POINTER :: Element !< Bulk element with some global numbering to use to assign local number 17814 LOGICAL, OPTIONAL :: NoPE 17815!------------------------------------------------------------------------------ 17816 ! Local variables 17817 17818 INTEGER i,j,n,edgeNumber, numEdges, bMap(4) 17819 TYPE(Element_t), POINTER :: Edge 17820 LOGICAL :: EvalPE 17821 17822 EvalPE = .TRUE. 17823 IF(PRESENT(NoPE)) EvalPE = .NOT.NoPE 17824 17825 ! Get number of points, edges or faces 17826 numEdges = 0 17827 SELECT CASE (Element % TYPE % DIMENSION) 17828 CASE (1) 17829 RETURN 17830 CASE (2) 17831 numEdges = Element % TYPE % NumberOfEdges 17832 CASE (3) 17833 numEdges = Element % TYPE % NumberOfFaces 17834 CASE DEFAULT 17835 WRITE (*,*) 'MeshUtils::AssignLocalNumber, Unsupported dimension:', Element % TYPE % DIMENSION 17836 RETURN 17837 END SELECT 17838 17839 ! For each edge or face in element try to find local number 17840 DO edgeNumber=1, numEdges 17841 ! If edges have not been created, stop search. This should not happen, actually. 17842 IF (.NOT. ASSOCIATED(Element % EdgeIndexes)) THEN 17843 ! EdgeElement % localNumber = 0 17844 RETURN 17845 END IF 17846 17847 Edge => GetElementEntity(Element,edgeNumber,Mesh) 17848 17849 ! Edge element not found. This should not be possible, unless there 17850 ! is an error in the mesh read in process.. 17851 IF (.NOT. ASSOCIATED(Edge)) THEN 17852 CALL Warn('MeshUtils::AssignLocalNumber','Edge element not found') 17853 ! EdgeElement % localNumber = 0 17854 RETURN 17855 END IF 17856 17857 n = 0 17858 ! For each element node 17859 DO i=1, Edge % TYPE % NumberOfNodes 17860 ! For each node in edge element 17861 DO j=1, EdgeElement % TYPE % NumberOfNodes 17862 ! If edge and edgeelement node match increment counter 17863 IF (Edge % NodeIndexes(i) == EdgeElement % NodeIndexes(j)) n = n + 1 17864 END DO 17865 END DO 17866 17867 ! If all nodes are on boundary, edge was found 17868 IF (n == EdgeElement % TYPE % NumberOfNodes) THEN 17869 IF(EvalPE) & 17870 EdgeElement % PDefs % localNumber = edgeNumber 17871 17872 ! Change ordering of global nodes to match that of element 17873 bMap = getElementBoundaryMap( Element, edgeNumber ) 17874 DO j=1,n 17875 EdgeElement % NodeIndexes(j) = Element % NodeIndexes(bMap(j)) 17876 END DO 17877 17878 ! Copy attributes of edge element to boundary element 17879 ! Misc attributes 17880 IF(EvalPE) THEN 17881 EdgeElement % PDefs % isEdge = Edge % PDefs % isEdge 17882 17883 ! Gauss points 17884 EdgeElement % PDefs % GaussPoints = Edge % PDefs % GaussPoints 17885 17886 ! Element p 17887 EdgeElement % PDefs % P = Edge % PDefs % P 17888 END IF 17889 17890 !(and boundary bubble dofs) 17891 EdgeElement % BDOFs = Edge % BDOFs 17892 17893 17894 ! If this boundary has edges copy edge indexes 17895 IF (ASSOCIATED(Edge % EdgeIndexes)) THEN 17896 ! Allocate element edges to element 17897 n = Edge % TYPE % NumberOfEdges 17898 bmap(1:4) = getFaceEdgeMap( Element, edgeNumber ) 17899 17900 IF ( ASSOCIATED( EdgeElement % EdgeIndexes) ) THEN 17901 DEALLOCATE( EdgeElement % EdgeIndexes ) 17902 END IF 17903 17904 CALL AllocateVector( EdgeElement % EdgeIndexes, n ) 17905 ! Copy edges from edge to boundary edge 17906 DO i=1,n 17907 EdgeElement % EdgeIndexes(i) = Element % EdgeIndexes(bmap(i)) 17908 ! EdgeElement % EdgeIndexes(i) = Element % EdgeIndexes(i) 17909 END DO 17910 END IF 17911 17912 ! Edge fields copied and local edge found so return 17913 RETURN 17914 END IF 17915 END DO 17916 17917 ! If we are here local number not found 17918 CALL Warn('MeshUtils::AssignLocalNumber','Unable to find local edge') 17919 ! EdgeElement % localNumber = 1 17920 CONTAINS 17921 17922 FUNCTION GetElementEntity(Element, which, Mesh) RESULT(Entity) 17923 IMPLICIT NONE 17924 17925 TYPE(Element_t), POINTER :: Element, Entity 17926 INTEGER :: which 17927 TYPE(Mesh_t) :: Mesh 17928 17929 NULLIFY(Entity) 17930 ! Switch by element dimension 17931 SELECT CASE (Element % TYPE % DIMENSION) 17932 CASE (2) 17933 Entity => Mesh % Edges( Element % EdgeIndexes(which)) 17934 CASE (3) 17935 Entity => Mesh % Faces( Element % FaceIndexes(which)) 17936 CASE DEFAULT 17937 WRITE (*,*) 'AssignLocalNumber::GetElementEntity: Unsupported dimension' 17938 RETURN 17939 END SELECT 17940 END FUNCTION GetElementEntity 17941 END SUBROUTINE AssignLocalNumber 17942 17943 17944!------------------------------------------------------------------------------ 17945!> Based on element degrees of freedom, return the sum of element 17946!> degrees of freedom. 17947!------------------------------------------------------------------------------ 17948 FUNCTION getElementMaxDOFs( Mesh, Element ) RESULT(dofs) 17949!------------------------------------------------------------------------------ 17950 IMPLICIT NONE 17951 17952 TYPE(Mesh_t), POINTER :: Mesh !< Finite element mesh 17953 TYPE(Element_t), POINTER :: Element !< Element to get maximum dofs for 17954 INTEGER :: dofs !< maximum number of dofs for Element 17955!------------------------------------------------------------------------------ 17956 17957 TYPE(ELement_t), POINTER :: Edge, Face 17958 INTEGER :: i, edgeDofs, faceDofs 17959 17960 ! Get sum of edge dofs if any 17961 edgeDofs = 0 17962 IF (ASSOCIATED(Element % EdgeIndexes)) THEN 17963 DO i=1, Element % TYPE % NumberOfEdges 17964 Edge => Mesh % Edges(Element % EdgeIndexes(i)) 17965 edgeDofs = edgeDofs + Edge % BDOFs 17966 END DO 17967 END IF 17968 17969 ! Get sum of face dofs if any 17970 faceDofs = 0 17971 IF (ASSOCIATED(Element % FaceIndexes)) THEN 17972 DO i=1, Element % TYPE % NumberOfFaces 17973 Face => Mesh % Faces(Element % FaceIndexes(i)) 17974 faceDofs = faceDofs + Face % BDOFs 17975 END DO 17976 END IF 17977 17978 ! Get sum of all dofs in element 17979 dofs = Element % TYPE % NumberOfNodes + & 17980 edgeDofs + faceDofs + Element % BDOFs 17981 END FUNCTION getElementMaxDOFs 17982 17983 17984 17985 17986!------------------------------------------------------------------------------ 17987!> Creates a permutation table for bodies or boundaries using a free chosen string 17988!> as mask. The resulting permutation is optimized in order, if requested. The 17989!> subroutine is intended to help in saving boundary data in an ordered manner, 17990!> but it can find other uses as well. Currently the implementation is limited 17991!> to normal Lagrangian elements. 17992!------------------------------------------------------------------------------ 17993 SUBROUTINE MakePermUsingMask( Model,Solver,Mesh,MaskName, & 17994 OptimizeBW, Perm, LocalNodes, MaskOnBulk, RequireLogical, ParallelComm ) 17995!------------------------------------------------------------------------------ 17996 TYPE(Model_t) :: Model 17997 TYPE(Mesh_t) :: Mesh 17998 TYPE(SOlver_t) :: Solver 17999 INTEGER :: LocalNodes 18000 LOGICAL :: OptimizeBW 18001 INTEGER, POINTER :: Perm(:) 18002 CHARACTER(LEN=*) :: MaskName 18003 LOGICAL, OPTIONAL :: MaskOnBulk 18004 LOGICAL, OPTIONAL :: RequireLogical 18005 LOGICAL, OPTIONAL :: ParallelComm 18006!------------------------------------------------------------------------------ 18007 INTEGER, POINTER :: InvPerm(:), Neighbours(:) 18008 INTEGER, ALLOCATABLE :: s_e(:,:), r_e(:), fneigh(:), ineigh(:) 18009 TYPE(ListMatrix_t), POINTER :: ListMatrix(:) 18010 INTEGER :: t,i,j,k,l,m,k1,k2,n,p,q,e1,e2,f1,f2,This,bf_id,nn,ii(ParEnv % PEs) 18011 INTEGER :: ierr, status(MPI_STATUS_SIZE), NewDofs 18012 LOGICAL :: Flag, Found, FirstRound, MaskIsLogical, Hit, Parallel 18013 LOGICAL, ALLOCATABLE :: IsNeighbour(:) 18014 INTEGER :: Indexes(30), ElemStart, ElemFin, Width 18015 TYPE(ListMatrixEntry_t), POINTER :: CList, Lptr 18016 TYPE(Element_t), POINTER :: CurrentElement,Elm 18017 REAL(KIND=dp) :: MinDist, Dist 18018!------------------------------------------------------------------------------ 18019 18020 IF(PRESENT(ParallelComm)) THEN 18021 Parallel = ParallelComm 18022 ELSE 18023 Parallel = ParEnv % PEs > 1 18024 END IF 18025 18026 ! First check if there are active elements for this mask 18027 IF( PRESENT( MaskOnBulk ) ) MaskOnBulk = .FALSE. 18028 IF( PRESENT( RequireLogical ) ) THEN 18029 MaskIsLogical = RequireLogical 18030 ELSE 18031 MaskIsLogical = .FALSE. 18032 END IF 18033 18034 IF(.NOT. ASSOCIATED( Perm ) ) THEN 18035 ALLOCATE( Perm( Mesh % NumberOfNodes ) ) 18036 Perm = 0 18037 END IF 18038 18039 ElemStart = HUGE(ElemStart) 18040 ElemFin = 0 18041 DO l = 1, Model % NumberOfBodyForces 18042 IF( MaskIsLogical ) THEN 18043 Hit = ListGetLogical( Model % BodyForces(l) % Values,MaskName,Found) 18044 ELSE 18045 Hit = ListCheckPresent( Model % BodyForces(l) % Values,MaskName) 18046 END IF 18047 IF( Hit ) THEN 18048 ElemStart = 1 18049 ElemFin = Mesh % NumberOfBulkElements 18050 IF( PRESENT( MaskOnBulk ) ) MaskOnBulk = .TRUE. 18051 EXIT 18052 END IF 18053 END DO 18054 DO l = 1, Model % NumberOfBCs 18055 IF( MaskIsLogical ) THEN 18056 Hit = ListGetLogical(Model % BCs(l) % Values,MaskName,Found ) 18057 ELSE 18058 Hit = ListCheckPresent(Model % BCs(l) % Values,MaskName ) 18059 END IF 18060 IF( Hit ) THEN 18061 ElemStart = MIN( ElemStart, Mesh % NumberOfBulkElements + 1) 18062 ElemFin = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements 18063 EXIT 18064 END IF 18065 END DO 18066 18067 IF( ElemFin - ElemStart <= 0) THEN 18068 LocalNodes = 0 18069 RETURN 18070 END IF 18071 18072 k = 0 18073 Perm = 0 18074 FirstRound = .TRUE. 18075 18076 ! Loop over the active elements 18077 ! 1st round initial numbering is given 18078 ! 2nd round a list matrix giving all the connections is created 18079 18080100 DO t=ElemStart, ElemFin 18081 18082 CurrentElement => Mesh % Elements(t) 18083 18084 Hit = .FALSE. 18085 IF(t <= Mesh % NumberOfBulkElements) THEN 18086 l = CurrentElement % BodyId 18087 bf_id = ListGetInteger( Model % Bodies(l) % Values, 'Body Force',Found) 18088 IF( bf_id>0 ) THEN 18089 IF( MaskIsLogical ) THEN 18090 Hit = ListGetLogical( Model % BodyForces(bf_id) % Values, MaskName, Found ) 18091 ELSE 18092 Hit = ListCheckPresent( Model % BodyForces(bf_id) % Values, MaskName ) 18093 END IF 18094 END IF 18095 ELSE 18096 DO l=1, Model % NumberOfBCs 18097 IF ( Model % BCs(l) % Tag /= CurrentElement % BoundaryInfo % Constraint ) CYCLE 18098 IF( MaskIsLogical ) THEN 18099 Hit = ListGetLogical(Model % BCs(l) % Values,MaskName, Found ) 18100 ELSE 18101 Hit = ListCheckPresent(Model % BCs(l) % Values,MaskName ) 18102 END IF 18103 EXIT 18104 END DO 18105 END IF 18106 IF( .NOT. Hit ) CYCLE 18107 18108 n = CurrentElement % TYPE % NumberOfNodes 18109 Indexes(1:n) = CurrentElement % NodeIndexes(1:n) 18110 18111 IF( FirstRound ) THEN 18112 DO i=1,n 18113 j = Indexes(i) 18114 IF ( Perm(j) == 0 ) THEN 18115 k = k + 1 18116 Perm(j) = k 18117 END IF 18118 END DO 18119 ELSE 18120 DO i=1,n 18121 k1 = Perm(Indexes(i)) 18122 IF ( k1 <= 0 ) CYCLE 18123 DO j=1,n 18124 k2 = Perm(Indexes(j)) 18125 IF ( k2 <= 0 ) CYCLE 18126 Lptr => List_GetMatrixIndex( ListMatrix,k1,k2 ) 18127 END DO 18128 END DO 18129 END IF 18130 END DO 18131 LocalNodes = k 18132 18133 !In parallel case, detect nodes which are shared with another partition 18134 !which may not have an element on this boundary 18135 !Code borrowed from CommunicateLinearSystemTag 18136 IF( Parallel ) THEN 18137 18138 ALLOCATE( IsNeighbour(ParEnv % PEs), fneigh(ParEnv % PEs), ineigh(ParEnv % PEs) ) 18139 18140 nn = MeshNeighbours(Mesh, IsNeighbour) 18141 nn = 0 18142 ineigh = 0 18143 DO i=0, ParEnv % PEs-1 18144 k = i+1 18145 IF(i==ParEnv % myPE) CYCLE 18146 IF(.NOT. IsNeighbour(k) ) CYCLE 18147 nn = nn + 1 18148 fneigh(nn) = k 18149 ineigh(k) = nn 18150 END DO 18151 18152 n = COUNT(Perm > 0 .AND. Mesh % ParallelInfo % Interface) 18153 ALLOCATE( s_e(n, nn ), r_e(n) ) 18154 18155 CALL CheckBuffer( nn*3*n ) 18156 18157 ii = 0 18158 DO i=1, Mesh % NumberOfNodes 18159 IF(Perm(i) > 0 .AND. Mesh % ParallelInfo % Interface(i) ) THEN 18160 DO j=1,SIZE(Mesh % ParallelInfo % Neighbourlist(i) % Neighbours) 18161 k = Mesh % ParallelInfo % Neighbourlist(i) % Neighbours(j) 18162 IF ( k == ParEnv % MyPE ) CYCLE 18163 k = k + 1 18164 k = ineigh(k) 18165 IF ( k> 0) THEN 18166 ii(k) = ii(k) + 1 18167 s_e(ii(k),k) = Mesh % ParallelInfo % GlobalDOFs(i) 18168 END IF 18169 END DO 18170 END IF 18171 END DO 18172 18173 DO i=1, nn 18174 j = fneigh(i) 18175 CALL MPI_BSEND( ii(i),1,MPI_INTEGER,j-1,110,ELMER_COMM_WORLD,ierr ) 18176 IF( ii(i) > 0 ) THEN 18177 CALL MPI_BSEND( s_e(1:ii(i),i),ii(i),MPI_INTEGER,j-1,111,ELMER_COMM_WORLD,ierr ) 18178 END IF 18179 END DO 18180 18181 NewDofs = 0 18182 18183 DO i=1, nn 18184 j = fneigh(i) 18185 CALL MPI_RECV( n,1,MPI_INTEGER,j-1,110,ELMER_COMM_WORLD, status,ierr ) 18186 IF ( n>0 ) THEN 18187 IF( n>SIZE(r_e)) THEN 18188 DEALLOCATE(r_e) 18189 ALLOCATE(r_e(n)) 18190 END IF 18191 18192 CALL MPI_RECV( r_e,n,MPI_INTEGER,j-1,111,ELMER_COMM_WORLD,status,ierr ) 18193 DO j=1,n 18194 k = SearchNode( Mesh % ParallelInfo, r_e(j), Order=Mesh % ParallelInfo % Gorder ) 18195 IF ( k>0 ) THEN 18196 IF(.NOT. Perm(k) > 0) THEN 18197 NewDofs = NewDofs + 1 18198 Perm(k) = LocalNodes + NewDofs 18199 END IF 18200 END IF 18201 END DO 18202 END IF 18203 END DO 18204 DEALLOCATE(s_e, r_e ) 18205 18206 LocalNodes = LocalNodes + NewDofs 18207 END IF 18208 18209 ! Don't optimize bandwidth for parallel cases 18210 IF( Parallel .OR. .NOT. OptimizeBW ) RETURN 18211 18212 IF(FirstRound) THEN 18213 ! Allocate space 18214 NULLIFY( ListMatrix ) 18215 ListMatrix => List_AllocateMatrix(LocalNodes) 18216 FirstRound = .FALSE. 18217 18218 ! Find the node in the lower left corner at give it the 1st index 18219 ! since it will probably determine the 1st index 18220 MinDist = HUGE(MinDist) 18221 DO i=1,SIZE(Perm) 18222 IF( Perm(i) <= 0) CYCLE 18223 Dist = Mesh % Nodes % x(i) + Mesh % Nodes % y(i) + Mesh % Nodes % z(i) 18224 IF(Dist < MinDist) THEN 18225 MinDist = Dist 18226 j = i 18227 END IF 18228 END DO 18229 18230 ! Find the 1st node and swap it with the lower corner 18231 DO i=1,SIZE(Perm) 18232 IF( Perm(i) == 1) EXIT 18233 END DO 18234 Perm(i) = Perm(j) 18235 Perm(j) = 1 18236 18237 GOTO 100 18238 END IF 18239 18240!------------------------------------------------------------------------------ 18241 18242 ALLOCATE( InvPerm(LocalNodes) ) 18243 InvPerm = 0 18244 DO i=1,SIZE(Perm) 18245 IF (Perm(i)>0) InvPerm(Perm(i)) = i 18246 END DO 18247 18248 ! The bandwidth optimization for lines results to perfectly ordered 18249 ! permutations. If there is only one line the 1st node should be the 18250 ! lower left corner. 18251 18252 Flag = .TRUE. 18253 Width = OptimizeBandwidth( ListMatrix, Perm, InvPerm, & 18254 18255 LocalNodes, Flag, Flag, MaskName ) 18256 18257 ! We really only need the permutation, as there will be no matrix equation 18258 ! associated with it. 18259 DEALLOCATE( InvPerm ) 18260 CALL List_FreeMatrix( LocalNodes, ListMatrix ) 18261 18262!------------------------------------------------------------------------------ 18263 END SUBROUTINE MakePermUsingMask 18264!------------------------------------------------------------------------------ 18265 18266 18267 18268 18269!------------------------------------------------------------------------ 18270!> Find a point in the mesh structure 18271!> There are two strategies: 18272!> 1) Recursive where the same routine is repeated with sloppier criteria 18273!> 2) One-sweep strategy where the best hit is registered and used if of 18274!> acceptable accuracy. 18275!> There are two different epsilons that control the search. One for the 18276!> rough test in absolute coordinates and another one for the more accurate 18277!> test in local coordinates. 18278!------------------------------------------------------------------------- 18279 FUNCTION PointInMesh(Solver, GlobalCoords, LocalCoords, HitElement, & 18280 CandElement, ExtInitialize ) RESULT ( Hit ) 18281 18282 TYPE(Solver_t) :: Solver 18283 REAL(KIND=dp) :: GlobalCoords(3), LocalCoords(3) 18284 TYPE(Element_t), POINTER :: HitElement 18285 TYPE(Element_t), POINTER, OPTIONAL :: CandElement 18286 LOGICAL, OPTIONAL :: ExtInitialize 18287 LOGICAL :: Hit 18288!------------------------------------------------------------------------- 18289 LOGICAL :: Initialize, Allocated = .FALSE., Stat, DummySearch, & 18290 MaskExists, Found, IsRecursive 18291 INTEGER :: i,j,k,n,bf_id,dim,mini 18292 REAL(KIND=dp) :: u,v,w,dist,mindist,MinLocalCoords(3) 18293 TYPE(Nodes_t) :: ElementNodes 18294 TYPE(Mesh_t), POINTER :: Mesh 18295 INTEGER, POINTER :: NodeIndexes(:) 18296 TYPE(Element_t), POINTER :: CurrentElement 18297 TYPE(Quadrant_t), POINTER, SAVE :: RootQuadrant =>NULL(), LeafQuadrant 18298 REAL(kind=dp) :: BoundingBox(6), eps2, eps1 = 1d-3, GlobalEps, LocalEps 18299 CHARACTER(LEN=MAX_NAME_LEN) :: MaskName 18300 18301 18302 SAVE :: Allocated, ElementNodes, DummySearch, Mesh, MaskName, MaskExists, & 18303 GlobalEps, LocalEps, IsRecursive 18304 18305 18306 IF( PRESENT( ExtInitialize ) ) THEN 18307 Initialize = ExtInitialize 18308 ELSE 18309 Initialize = .NOT. Allocated 18310 END IF 18311 18312 IF( Initialize ) THEN 18313 Mesh => Solver % Mesh 18314 n = Mesh % MaxElementNodes 18315 IF( Allocated ) THEN 18316 DEALLOCATE( ElementNodes % x, ElementNodes % y, ElementNodes % z ) 18317 END IF 18318 ALLOCATE( ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n)) 18319 Allocated = .TRUE. 18320 18321 IsRecursive = ListGetLogical( CurrentModel % Simulation,& 18322 'Interpolation Search Recursive',Stat ) 18323! IF(.NOT. Stat ) IsRecursive = .TRUE. 18324 18325 LocalEps = ListGetConstReal( CurrentModel % Simulation, & 18326 'Interpolation Local Epsilon', Stat ) 18327 IF(.NOT. stat) LocalEps = 1.0d-10 18328 18329 GlobalEps = ListGetConstReal( CurrentModel % Simulation, & 18330 'Interpolation Global Epsilon', Stat ) 18331 IF(.NOT. stat) THEN 18332 IF( IsRecursive ) THEN 18333 GlobalEps = 2.0d-10 18334 ELSE 18335 GlobalEps = 1.0d-4 18336 END IF 18337 END IF 18338 18339 DummySearch = ListGetLogical( CurrentModel % Simulation,& 18340 'Interpolation Search Dummy',Stat ) 18341 18342 MaskName = ListGetString( CurrentModel % Simulation,& 18343 'Interpolation Search Mask',MaskExists ) 18344 18345 IF( ASSOCIATED( Mesh % RootQuadrant ) ) THEN 18346 CALL FreeQuadrantTree( Mesh % RootQuadrant ) 18347 Mesh % RootQuadrant => NULL() 18348 END IF 18349 END IF 18350 18351 18352 !----------------------------------------------- 18353 ! Create the octree search structure, if needed 18354 !----------------------------------------------- 18355 IF ( .NOT. ( DummySearch .OR. ASSOCIATED( Mesh % RootQuadrant ) ) ) THEN 18356 BoundingBox(1) = MINVAL( Mesh % Nodes % x ) 18357 BoundingBox(2) = MINVAL( Mesh % Nodes % y ) 18358 BoundingBox(3) = MINVAL( Mesh % Nodes % z ) 18359 BoundingBox(4) = MAXVAL( Mesh % Nodes % x ) 18360 BoundingBox(5) = MAXVAL( Mesh % Nodes % y ) 18361 BoundingBox(6) = MAXVAL( Mesh % Nodes % z ) 18362 18363 eps2 = eps1 * MAXVAL( BoundingBox(4:6) - BoundingBox(1:3) ) 18364 BoundingBox(1:3) = BoundingBox(1:3) - eps2 18365 BoundingBox(4:6) = BoundingBox(4:6) + eps2 18366 18367 CALL BuildQuadrantTree( Mesh,BoundingBox,Mesh % RootQuadrant) 18368 RootQuadrant => Mesh % RootQuadrant 18369 IF (.NOT. ASSOCIATED(RootQuadrant) ) THEN 18370 Hit = .FALSE. 18371 CALL Warn('PointInMesh','No RootQuadrant associated') 18372 RETURN 18373 END IF 18374 END IF 18375 18376 18377 Hit = .FALSE. 18378 18379 ! Check that the previous hit is not hit even now 18380 !------------------------------------------------- 18381 IF( PRESENT( CandElement ) ) THEN 18382 18383 IF( ASSOCIATED(CandElement)) THEN 18384 18385 CurrentElement => CandElement 18386 n = CurrentElement % TYPE % NumberOfNodes 18387 NodeIndexes => CurrentElement % NodeIndexes 18388 18389 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 18390 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 18391 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 18392 18393 IF ( PointInElement( CurrentElement, ElementNodes, & 18394 GlobalCoords, LocalCoords ) ) THEN 18395 Hit = .TRUE. 18396 HitElement => CurrentElement 18397 RETURN 18398 END IF 18399 END IF 18400 END IF 18401 18402 18403 Eps1 = GlobalEps 18404 Eps2 = LocalEps 18405 18406 18407100 IF( DummySearch ) THEN 18408 18409 mindist = HUGE( mindist ) 18410 18411 !---------------------------------------------------------- 18412 ! Go through all bulk elements in a dummy search. 18413 ! This algorithm is mainly here for debugging purposes, or 18414 ! if just a few nodes need to be searched. 18415 !---------------------------------------------------------- 18416 DO k=1,Mesh % NumberOfBulkElements 18417 CurrentElement => Mesh % Elements(k) 18418 n = CurrentElement % TYPE % NumberOfNodes 18419 NodeIndexes => CurrentElement % NodeIndexes 18420 18421 IF( MaskExists ) THEN 18422 bf_id = ListGetInteger( CurrentModel % Bodies(CurrentElement % BodyId) % Values, & 18423 'Body Force', Found ) 18424 IF( .NOT. Found ) CYCLE 18425 IF(.NOT. ListCheckPresent( CurrentModel % BodyForces(bf_id) % Values,MaskName) ) CYCLE 18426 END IF 18427 18428 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 18429 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 18430 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 18431 18432 Hit = PointInElement( CurrentElement, ElementNodes, & 18433 GlobalCoords, LocalCoords, Eps1, Eps2, LocalDistance = dist ) 18434 IF( dist < mindist ) THEN 18435 mini = k 18436 mindist = dist 18437 END IF 18438 IF( Hit ) EXIT 18439 END DO 18440 ELSE 18441 !----------------------------------------------- 18442 ! Find the right element using an octree search 18443 ! This is the preferred algorithms of the two. 18444 !----------------------------------------------- 18445 NULLIFY(CurrentElement) 18446 CALL FindLeafElements(GlobalCoords, Mesh % MeshDim, RootQuadrant, LeafQuadrant) 18447 IF ( ASSOCIATED(LeafQuadrant) ) THEN 18448 DO j=1, LeafQuadrant % NElemsInQuadrant 18449 k = LeafQuadrant % Elements(j) 18450 CurrentElement => Mesh % Elements(k) 18451 18452 IF( MaskExists ) THEN 18453 bf_id = ListGetInteger( CurrentModel % Bodies(CurrentElement % BodyId) % Values, & 18454 'Body Force', Found ) 18455 IF( .NOT. Found ) CYCLE 18456 IF(.NOT. ListCheckPresent( CurrentModel % BodyForces(bf_id) % Values,MaskName) ) CYCLE 18457 END IF 18458 18459 n = CurrentElement % TYPE % NumberOfNodes 18460 NodeIndexes => CurrentElement % NodeIndexes 18461 18462 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 18463 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 18464 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 18465 18466 Hit = PointInElement( CurrentElement, ElementNodes, & 18467 GlobalCoords, LocalCoords, Eps1, Eps2, LocalDistance = dist ) 18468 IF( dist < mindist ) THEN 18469 mini = k 18470 mindist = dist 18471 MinLocalCoords = LocalCoords 18472 END IF 18473 IF( Hit ) EXIT 18474 END DO 18475 END IF 18476 END IF 18477 18478 IF( .NOT. Hit ) THEN 18479 IF( IsRecursive ) THEN 18480 Eps1 = 10.0 * Eps1 18481 Eps2 = 10.0 * Eps2 18482 IF( Eps1 <= 1.0_dp ) GOTO 100 18483 ELSE 18484 IF( mindist < Eps1 ) THEN 18485 CurrentElement => Mesh % Elements(k) 18486 LocalCoords = MinLocalCoords 18487 Hit = .TRUE. 18488 END IF 18489 END IF 18490 END IF 18491 18492 IF( Hit ) HitElement => CurrentElement 18493 18494 END FUNCTION PointInMesh 18495 18496 18497 18498!-------------------------------------------------------------------------- 18499!> This subroutine finds the structure of an extruded mesh even though it is 18500!> given in an unstructured format. The routine may be used by some special 18501!> solvers that employ the special character of the mesh. 18502!> The extrusion is found for a given direction and for each node the corresponding 18503!> up and down, and thereafter top and bottom node is computed. 18504!----------------------------------------------------------------------------- 18505 SUBROUTINE DetectExtrudedStructure( Mesh, Solver, ExtVar, & 18506 TopNodePointer, BotNodePointer, UpNodePointer, DownNodePointer, & 18507 MidNodePointer, MidLayerExists, NumberOfLayers, NodeLayer ) 18508 18509 USE CoordinateSystems 18510 IMPLICIT NONE 18511 18512 TYPE(Mesh_t), POINTER :: Mesh 18513 TYPE(Solver_t), POINTER :: Solver 18514 TYPE(Variable_t), POINTER, OPTIONAL :: ExtVar 18515 INTEGER, POINTER, OPTIONAL :: TopNodePointer(:), BotNodePointer(:), & 18516 UpNodePointer(:), DownNodePointer(:), MidNodePointer(:) 18517 INTEGER, POINTER, OPTIONAL :: NodeLayer(:) 18518 INTEGER, OPTIONAL :: NumberOfLayers 18519 LOGICAL, OPTIONAL :: MidLayerExists 18520!----------------------------------------------------------------------------- 18521 REAL(KIND=dp) :: Direction(3) 18522 TYPE(ValueList_t), POINTER :: Params 18523 TYPE(Variable_t), POINTER :: Var 18524 REAL(KIND=dp) :: Tolerance 18525 TYPE(Element_t), POINTER :: Element 18526 TYPE(Nodes_t) :: Nodes 18527 INTEGER :: i,j,k,n,ii,jj,dim, nsize, nnodes, elem, TopNodes, BotNodes, Rounds, ActiveDirection, & 18528 UpHit, DownHit, bc_ind, jmin, jmax 18529 INTEGER, POINTER :: NodeIndexes(:), MaskPerm(:) 18530 LOGICAL :: MaskExists, UpActive, DownActive, GotIt, Found, DoCoordTransform 18531 LOGICAL, POINTER :: TopFlag(:), BotFlag(:) 18532 REAL(KIND=dp) :: at0, at1, Length, UnitVector(3), Vector(3), Vector2(3), & 18533 ElemVector(3), DotPro, MaxDotPro, MinDotPro, Eps, MinTop, & 18534 MaxTop, MinBot, MaxBot 18535 REAL(KIND=dp), POINTER :: Values(:) 18536 INTEGER, POINTER :: TopPointer(:), BotPointer(:), UpPointer(:), DownPointer(:),Layer(:),MidPointer(:) 18537 CHARACTER(LEN=MAX_NAME_LEN) :: VarName, CoordTransform 18538 CHARACTER(LEN=MAX_NAME_LEN) :: Caller="DetectExtrudedStructure" 18539 18540 CALL Info(Caller,'Determining extruded structure',Level=6) 18541 at0 = CPUTime() 18542 18543 DIM = Mesh % MeshDim 18544 Params => Solver % Values 18545 18546 ActiveDirection = ListGetInteger(Params,'Active Coordinate') 18547 IF( ActiveDirection < 1 .OR. ActiveDirection > 3 ) THEN 18548 CALL Fatal('StructuredMeshMapper','Invalid value for Active Coordinate') 18549 END IF 18550 UnitVector = 0.0_dp 18551 UnitVector(ActiveDirection) = 1.0_dp 18552 18553 18554 IF( ListGetLogical(Params,'Project To Bottom',GotIt) ) & 18555 UnitVector = -1.0_dp * UnitVector 18556 18557 WRITE(Message,'(A,3F8.3)') 'Unit vector of direction:',UnitVector 18558 CALL Info(Caller,Message,Level=8) 18559 18560 ! Set the dot product tolerance 18561 !----------------------------------------------------------------- 18562 Eps = ListGetConstReal( Params,'Dot Product Tolerance',GotIt) 18563 IF(.NOT. GotIt) Eps = 1.0d-4 18564 18565 nnodes = Mesh % NumberOfNodes 18566 nsize = nnodes 18567 18568 VarName = ListGetString(Params,'Mapping Mask Variable',GotIt ) 18569 MaskExists = .FALSE. 18570 IF(GotIt) THEN 18571 Var => VariableGet( Mesh % Variables, VarName ) 18572 IF(ASSOCIATED(Var)) THEN 18573 MaskExists = ASSOCIATED(Var % Perm) 18574 IF( MaskExists ) THEN 18575 ALLOCATE( MaskPerm( SIZE( Var % Perm ) ) ) 18576 MaskPerm = Var % Perm 18577 nsize = MAXVAL( MaskPerm ) 18578 CALL Info(Caller,'Using variable as mask: '//TRIM(VarName),Level=8) 18579 END IF 18580 END IF 18581 ELSE 18582 VarName = ListGetString(Params,'Mapping Mask Name',MaskExists ) 18583 IF( MaskExists ) THEN 18584 CALL Info(Caller,'Using name as mask: '//TRIM(VarName),Level=8) 18585 MaskPerm => NULL() 18586 CALL MakePermUsingMask( CurrentModel, Solver, Mesh, VarName, & 18587 .FALSE., MaskPerm, nsize ) 18588 PRINT *,'nsize:',nsize,SIZE(MaskPerm),MAXVAL(MaskPerm(1:nnodes)) 18589 END IF 18590 END IF 18591 18592 IF( MaskExists ) THEN 18593 CALL Info(Caller,'Applying mask of size: '//TRIM(I2S(nsize)),Level=10) 18594 ELSE 18595 CALL Info(Caller,'Applying extrusion on the whole mesh',Level=10) 18596 END IF 18597 18598 CoordTransform = ListGetString(Params,'Mapping Coordinate Transformation',DoCoordTransform ) 18599 IF( DoCoordTransform .OR. MaskExists) THEN 18600 Var => VariableGet( Mesh % Variables,'Extruded Coordinate') 18601 IF( ASSOCIATED( Var ) ) THEN 18602 CALL Info(Caller,'Reusing > Extruded Coordinate < variable',Level=12 ) 18603 Values => Var % Values 18604 ELSE 18605 NULLIFY( Values ) 18606 ALLOCATE( Values( nsize ) ) 18607 Values = 0.0_dp 18608 IF( MaskExists ) THEN 18609 CALL VariableAdd( Mesh % Variables, Mesh, Solver,'Extruded Coordinate',1,Values, MaskPerm) 18610 ELSE 18611 CALL VariableAdd( Mesh % Variables, Mesh, Solver,'Extruded Coordinate',1,Values) 18612 END IF 18613 Var => VariableGet( Mesh % Variables,'Extruded Coordinate') 18614 END IF 18615 ELSE IF( ActiveDirection == 1 ) THEN 18616 Var => VariableGet( Mesh % Variables,'Coordinate 1') 18617 ELSE IF( ActiveDirection == 2 ) THEN 18618 Var => VariableGet( Mesh % Variables,'Coordinate 2') 18619 ELSE 18620 Var => VariableGet( Mesh % Variables,'Coordinate 3') 18621 END IF 18622 18623 IF( MaskExists .OR. DoCoordTransform) THEN 18624 DO i=1,Mesh % NumberOfNodes 18625 j = i 18626 IF( MaskExists ) THEN 18627 j = MaskPerm(i) 18628 IF( j == 0 ) CYCLE 18629 END IF 18630 Vector(1) = Mesh % Nodes % x(i) 18631 Vector(2) = Mesh % Nodes % y(i) 18632 Vector(3) = Mesh % Nodes % z(i) 18633 IF( DoCoordTransform ) THEN 18634 CALL CoordinateTransformationNodal( CoordTransform, Vector ) 18635 END IF 18636 Values(j) = Vector( ActiveDirection ) 18637 END DO 18638 END IF 18639 IF( PRESENT( ExtVar ) ) ExtVar => Var 18640 18641 ! Check which direction is active 18642 !--------------------------------------------------------------------- 18643 UpActive = PRESENT( UpNodePointer) .OR. PRESENT ( TopNodePointer ) 18644 DownActive = PRESENT( DownNodePointer) .OR. PRESENT ( BotNodePointer ) 18645 18646 IF( PRESENT( NumberOfLayers) .OR. PRESENT( NodeLayer ) ) THEN 18647 UpActive = .TRUE. 18648 DownActive = .TRUE. 18649 END IF 18650 18651 IF(.NOT. (UpActive .OR. DownActive ) ) THEN 18652 CALL Warn(Caller,'Either up or down direction should be active') 18653 RETURN 18654 END IF 18655 18656 ! Allocate pointers to top and bottom, and temporary pointers up and down 18657 !------------------------------------------------------------------------ 18658 IF( UpActive ) THEN 18659 ALLOCATE(TopPointer(nsize),UpPointer(nsize)) 18660 DO i=1,nnodes 18661 j = i 18662 IF( MaskExists ) THEN 18663 j = MaskPerm(i) 18664 IF( j == 0 ) CYCLE 18665 END IF 18666 TopPointer(j) = i 18667 UpPointer(j) = i 18668 END DO 18669 END IF 18670 IF( DownActive ) THEN 18671 ALLOCATE(BotPointer(nsize),DownPointer(nsize)) 18672 DO i=1,nnodes 18673 j = i 18674 IF( MaskExists ) THEN 18675 j = MaskPerm(i) 18676 IF( j == 0 ) CYCLE 18677 END IF 18678 BotPointer(j) = i 18679 DownPointer(j) = i 18680 END DO 18681 END IF 18682 18683 CALL Info(Caller,'Determine up and down pointers',Level=15) 18684 18685 ! Determine the up and down pointers using dot product as criterion 18686 !----------------------------------------------------------------- 18687 n = Mesh % MaxElementNodes 18688 ALLOCATE( Nodes % x(n), Nodes % y(n),Nodes % z(n) ) 18689 18690 DO elem = 1,Mesh % NumberOfBulkElements 18691 18692 Element => Mesh % Elements(elem) 18693 NodeIndexes => Element % NodeIndexes 18694 CurrentModel % CurrentElement => Element 18695 18696 n = Element % TYPE % NumberOfNodes 18697 Nodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 18698 Nodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 18699 Nodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 18700 18701 ! This is probably a copy-paste error, I comment it away for time being. 18702 ! IF (.NOT. (Element % PartIndex == Parenv % Mype) ) CYCLE 18703 18704 IF( MaskExists ) THEN 18705 IF( ANY(MaskPerm(NodeIndexes) == 0) ) CYCLE 18706 END IF 18707 18708 DO i=1,n 18709 ii = NodeIndexes(i) 18710 18711 Vector(1) = Nodes % x(i) 18712 Vector(2) = Nodes % y(i) 18713 Vector(3) = Nodes % z(i) 18714 18715 IF( DoCoordTransform ) THEN 18716 CALL CoordinateTransformationNodal( CoordTransform, Vector ) 18717 END IF 18718 18719 MaxDotPro = -1.0_dp 18720 MinDotPro = 1.0_dp 18721 18722 DO j=i+1,n 18723 jj = NodeIndexes(j) 18724 18725 Vector2(1) = Nodes % x(j) 18726 Vector2(2) = Nodes % y(j) 18727 Vector2(3) = Nodes % z(j) 18728 18729 IF( DoCoordTransform ) THEN 18730 CALL CoordinateTransformationNodal( CoordTransform, Vector2 ) 18731 END IF 18732 18733 ElemVector = Vector2 - Vector 18734 18735 Length = SQRT(SUM(ElemVector*ElemVector)) 18736 DotPro = SUM(ElemVector * UnitVector) / Length 18737 18738 IF( DotPro > MaxDotPro ) THEN 18739 MaxDotPro = DotPro 18740 jmax = jj 18741 END IF 18742 IF( DotPro < MinDotPro ) THEN 18743 MinDotPro = DotPro 18744 jmin = jj 18745 END IF 18746 END DO 18747 18748 IF(MaxDotPro > 1.0_dp - Eps) THEN 18749 IF( MaskExists ) THEN 18750 IF( UpActive ) UpPointer(MaskPerm(ii)) = jmax 18751 IF( DownActive ) DownPointer(MaskPerm(jmax)) = ii 18752 ELSE 18753 IF( UpActive ) UpPointer(ii) = jmax 18754 IF( DownActive ) DownPointer(jmax) = ii 18755 END IF 18756 END IF 18757 18758 IF(MinDotPro < Eps - 1.0_dp) THEN 18759 IF( MaskExists ) THEN 18760 IF( DownActive ) DownPointer(MaskPerm(ii)) = jmin 18761 IF( UpActive ) UpPointer(MaskPerm(jmin)) = ii 18762 ELSE 18763 IF( DownActive ) DownPointer(ii) = jmin 18764 IF( UpActive ) UpPointer(jmin) = ii 18765 END IF 18766 END IF 18767 18768 END DO 18769 END DO 18770 DEALLOCATE( Nodes % x, Nodes % y,Nodes % z ) 18771 18772 18773 ! Pointer to top and bottom are found recursively using up and down 18774 !------------------------------------------------------------------ 18775 CALL Info(Caller,'determine top and bottom pointers',Level=9) 18776 18777 DO Rounds = 1, nsize 18778 DownHit = 0 18779 UpHit = 0 18780 18781 DO i=1,nnodes 18782 IF( MaskExists ) THEN 18783 IF( MaskPerm(i) == 0) CYCLE 18784 IF( UpActive ) THEN 18785 j = UpPointer(MaskPerm(i)) 18786 IF( TopPointer(MaskPerm(i)) /= TopPointer(MaskPerm(j)) ) THEN 18787 UpHit = UpHit + 1 18788 TopPointer(MaskPerm(i)) = TopPointer(MaskPerm(j)) 18789 END IF 18790 END IF 18791 IF( DownActive ) THEN 18792 j = DownPointer(MaskPerm(i)) 18793 IF( BotPointer(MaskPerm(i)) /= BotPointer(MaskPerm(j)) ) THEN 18794 DownHit = DownHit + 1 18795 BotPointer(MaskPerm(i)) = BotPointer(MaskPerm(j)) 18796 END IF 18797 END IF 18798 ELSE 18799 IF( UpActive ) THEN 18800 j = UpPointer(i) 18801 IF( TopPointer(i) /= TopPointer(j) ) THEN 18802 UpHit = UpHit + 1 18803 TopPointer(i) = TopPointer( j ) 18804 END IF 18805 END IF 18806 IF( DownActive ) THEN 18807 j = DownPointer(i) 18808 IF( BotPointer(i) /= BotPointer( j ) ) THEN 18809 DownHit = DownHit + 1 18810 BotPointer(i) = BotPointer( j ) 18811 END IF 18812 END IF 18813 END IF 18814 END DO 18815 18816 IF( UpHit == 0 .AND. DownHit == 0 ) EXIT 18817 END DO 18818 18819 ! The last round is always a check 18820 Rounds = Rounds - 1 18821 18822 CALL Info(Caller,'Layered structure detected in '//TRIM(I2S(Rounds))//' cycles',Level=9) 18823 IF( Rounds == 0 ) THEN 18824 CALL Info(Caller,'Try to increase value for > Dot Product Tolerance < ') 18825 CALL Fatal(Caller,'Zero rounds implies unsuccessful operation') 18826 END IF 18827 18828 ! Compute the number of layers. The Rounds above may in some cases 18829 ! be too small. Here just one layer is used to determine the number 18830 ! of layers to save some time. 18831 !------------------------------------------------------------------ 18832 IF( PRESENT( NumberOfLayers ) ) THEN 18833 CALL Info(Caller,'Compute number of layers',Level=15) 18834 DO i=1,nsize 18835 IF( MaskExists ) THEN 18836 IF( MaskPerm(i) == 0 ) CYCLE 18837 END IF 18838 EXIT 18839 END DO 18840 18841 j = BotPointer(1) 18842 CALL Info(Caller,'Starting from node: '//TRIM(I2S(j)),Level=15) 18843 18844 NumberOfLayers = 0 18845 DO WHILE(.TRUE.) 18846 jj = j 18847 IF( MaskExists ) THEN 18848 jj = MaskPerm(j) 18849 END IF 18850 k = UpPointer(jj) 18851 IF( k == j ) THEN 18852 EXIT 18853 ELSE 18854 NumberOfLayers = NumberOfLayers + 1 18855 j = k 18856 END IF 18857 END DO 18858 18859 IF( NumberOfLayers < Rounds ) THEN 18860 WRITE( Message,'(A,I0,A,I0)') 'There seems to be varying number of layers: ',& 18861 NumberOfLayers,' vs. ',Rounds 18862 CALL Warn(Caller, Message ) 18863 NumberOfLayers = Rounds 18864 END IF 18865 CALL Info(Caller,& 18866 'Extruded structure layers: '//TRIM(I2S(NumberOfLayers)),Level=6) 18867 END IF 18868 18869 18870 ! Create layer index if requested 18871 !------------------------------------------------------------------ 18872 IF( PRESENT( NodeLayer ) ) THEN 18873 CALL Info(Caller,'creating layer index',Level=9) 18874 18875 NULLIFY(Layer) 18876 ALLOCATE( Layer(nsize) ) 18877 Layer = 1 18878 IF( MaskExists ) THEN 18879 WHERE( MaskPerm == 0 ) Layer = 0 18880 18881 DO i=1,nnodes 18882 IF( MaskPerm(i) == 0 ) CYCLE 18883 Rounds = 1 18884 j = BotPointer(MaskPerm(i)) 18885 Layer(MaskPerm(j)) = Rounds 18886 DO WHILE(.TRUE.) 18887 k = UpPointer(MaskPerm(j)) 18888 IF( k == j ) EXIT 18889 Rounds = Rounds + 1 18890 j = k 18891 Layer(MaskPerm(j)) = Rounds 18892 END DO 18893 END DO 18894 ELSE 18895 DO i=1,nsize 18896 Rounds = 1 18897 j = BotPointer(i) 18898 Layer(j) = Rounds 18899 DO WHILE(.TRUE.) 18900 k = UpPointer(j) 18901 IF( k == j ) EXIT 18902 Rounds = Rounds + 1 18903 j = k 18904 Layer(j) = Rounds 18905 END DO 18906 END DO 18907 END IF 18908 18909 NodeLayer => Layer 18910 WRITE(Message,'(A,I0,A,I0,A)') 'Layer range: [',MINVAL(Layer),',',MAXVAL(Layer),']' 18911 CALL Info(Caller,Message,Level=6) 18912 NULLIFY(Layer) 18913 END IF 18914 18915 18916 IF( PRESENT( MidNodePointer ) ) THEN 18917 ALLOCATE( MidPointer( nsize ) ) 18918 MidPointer = 0 18919 MidLayerExists = .FALSE. 18920 18921 DO elem = Mesh % NumberOfBulkElements + 1, & 18922 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 18923 18924 Element => Mesh % Elements(elem) 18925 NodeIndexes => Element % NodeIndexes 18926 18927 DO bc_ind = 1, CurrentModel % NumberOfBCs 18928 IF( Element % BoundaryInfo % Constraint == & 18929 CurrentModel % BCs(bc_ind) % Tag ) THEN 18930 IF( ListCheckPresent( CurrentModel % BCs(bc_ind) % Values,'Mid Surface') ) THEN 18931 MidPointer( NodeIndexes ) = NodeIndexes 18932 MidLayerExists = .TRUE. 18933 END IF 18934 EXIT 18935 END IF 18936 END DO 18937 END DO 18938 18939 IF( MidLayerExists ) THEN 18940 CALL Info(Caller,'determine mid pointers',Level=15) 18941 18942 DO Rounds = 1, nsize 18943 DownHit = 0 18944 UpHit = 0 18945 DO i=1,nsize 18946 IF( MaskExists ) THEN 18947 IF( MaskPerm(i) == 0) CYCLE 18948 END IF 18949 18950 ! We can only start from existing mid pointer 18951 IF( MidPointer(i) == 0 ) CYCLE 18952 IF( UpActive ) THEN 18953 j = UpPointer(i) 18954 IF( MaskExists ) THEN 18955 IF( MidPointer(MaskPerm(j)) == 0 ) THEN 18956 UpHit = UpHit + 1 18957 MidPointer(MaskPerm(j)) = MidPointer(MaskPerm(i)) 18958 END IF 18959 ELSE 18960 IF( MidPointer(j) == 0 ) THEN 18961 UpHit = UpHit + 1 18962 MidPointer(j) = MidPointer(i) 18963 END IF 18964 END IF 18965 END IF 18966 IF( DownActive ) THEN 18967 j = DownPointer(i) 18968 IF( MaskExists ) THEN 18969 IF( MidPointer(MaskPerm(j)) == 0 ) THEN 18970 DownHit = DownHit + 1 18971 MidPointer(MaskPerm(j)) = MidPointer(MaskPerm(i)) 18972 END IF 18973 ELSE 18974 IF( MidPointer(j) == 0 ) THEN 18975 DownHit = DownHit + 1 18976 MidPointer(j) = MidPointer(i) 18977 END IF 18978 END IF 18979 END IF 18980 END DO 18981 IF( UpHit == 0 .AND. DownHit == 0 ) EXIT 18982 END DO 18983 18984 CALL Info(Caller,& 18985 'Mid layer structure detected in '//TRIM(I2S(Rounds-1))//' cycles',Level=9) 18986 MidNodePointer => MidPointer 18987 ELSE 18988 DEALLOCATE( MidPointer ) 18989 MidNodePointer => NULL() 18990 END IF 18991 END IF 18992 18993 18994 ! Count the number of top and bottom nodes, for information only 18995 !--------------------------------------------------------------- 18996 CALL Info(Caller,'Counting top and bottom nodes',Level=15) 18997 IF( UpActive ) THEN 18998 TopNodes = 0 18999 MinTop = HUGE( MinTop ) 19000 MaxTop = -HUGE( MaxTop ) 19001 DO i=1,nnodes 19002 IF( MaskExists ) THEN 19003 j = MaskPerm(i) 19004 IF( j == 0 ) CYCLE 19005 IF(TopPointer(j) == i) THEN 19006 MinTop = MIN( MinTop, Var % Values(j) ) 19007 MaxTop = MAX( MaxTop, Var % Values(j) ) 19008 TopNodes = TopNodes + 1 19009 END IF 19010 ELSE 19011 IF(TopPointer(i) == i) THEN 19012 MinTop = MIN( MinTop, Var % Values(i) ) 19013 MaxTop = MAX( MaxTop, Var % Values(i) ) 19014 TopNodes = TopNodes + 1 19015 END IF 19016 END IF 19017 END DO 19018 END IF 19019 19020 IF( DownActive ) THEN 19021 BotNodes = 0 19022 MinBot = HUGE( MinBot ) 19023 MaxBot = -HUGE( MaxBot ) 19024 DO i=1,nnodes 19025 IF( MaskExists ) THEN 19026 j = MaskPerm(i) 19027 IF( j == 0 ) CYCLE 19028 IF( BotPointer(j) == i) THEN 19029 MinBot = MIN( MinBot, Var % Values(j)) 19030 MaxBot = MAX( MaxBot, Var % Values(j)) 19031 BotNodes = BotNodes + 1 19032 END IF 19033 ELSE 19034 IF(BotPointer(i) == i) THEN 19035 MinBot = MIN( MinBot, Var % Values(i)) 19036 MaxBot = MAX( MaxBot, Var % Values(i)) 19037 BotNodes = BotNodes + 1 19038 END IF 19039 END IF 19040 END DO 19041 END IF 19042 19043 19044 ! Return the requested pointer structures, otherwise deallocate 19045 !--------------------------------------------------------------- 19046 CALL Info(Caller,'Setting pointer structures',Level=15) 19047 IF( UpActive ) THEN 19048 IF( PRESENT( TopNodePointer ) ) THEN 19049 TopNodePointer => TopPointer 19050 NULLIFY( TopPointer ) 19051 ELSE 19052 DEALLOCATE( TopPointer ) 19053 END IF 19054 IF( PRESENT( UpNodePointer ) ) THEN 19055 UpNodePointer => UpPointer 19056 NULLIFY( UpPointer ) 19057 ELSE 19058 DEALLOCATE( UpPointer ) 19059 END IF 19060 END IF 19061 IF( DownActive ) THEN 19062 IF( PRESENT( BotNodePointer ) ) THEN 19063 BotNodePointer => BotPointer 19064 NULLIFY( BotPointer ) 19065 ELSE 19066 DEALLOCATE( BotPointer ) 19067 END IF 19068 IF( PRESENT( DownNodePointer ) ) THEN 19069 DownNodePointer => DownPointer 19070 NULLIFY( DownPointer ) 19071 ELSE 19072 DEALLOCATE( DownPointer ) 19073 END IF 19074 END IF 19075 19076 !--------------------------------------------------------------- 19077 at1 = CPUTime() 19078 WRITE(Message,* ) 'Top and bottom pointer init time: ',at1-at0 19079 CALL Info(Caller,Message,Level=6) 19080 CALL Info(Caller,& 19081 'Top and bottom pointer init rounds: '//TRIM(I2S(Rounds)),Level=5) 19082 IF( UpActive ) THEN 19083 CALL Info(Caller,'Number of nodes at the top: '//TRIM(I2S(TopNodes)),Level=6) 19084 END IF 19085 IF( DownActive ) THEN 19086 CALL Info(Caller,'Number of nodes at the bottom: '//TRIM(I2S(BotNodes)),Level=6) 19087 END IF 19088 19089 19090 CONTAINS 19091 19092 19093 !--------------------------------------------------------------- 19094 SUBROUTINE CoordinateTransformationNodal( CoordTransform, R ) 19095 CHARACTER(LEN=MAX_NAME_LEN) :: CoordTransform 19096 REAL(KIND=dp) :: R(3) 19097 !--------------------------------------------------------------- 19098 REAL(KIND=dp) :: Rtmp(3) 19099 REAL(KIND=dp), SAVE :: Coeff 19100 LOGICAL, SAVE :: Visited = .FALSE. 19101 19102 19103 IF( .NOT. Visited ) THEN 19104 IF( ListGetLogical( Params,'Angles in Degrees') ) THEN 19105 Coeff = 180.0_dp / PI 19106 ELSE 19107 Coeff = 1.0_dp 19108 END IF 19109 Visited = .TRUE. 19110 END IF 19111 19112 SELECT CASE ( CoordTransform ) 19113 19114 CASE('cartesian to cylindrical') 19115 Rtmp(1) = SQRT( R(1)**2 + R(2)**2) 19116 Rtmp(2) = Coeff * ATAN2( R(2), R(1) ) 19117 Rtmp(3) = R(3) 19118 19119 CASE('cylindrical to cartesian') 19120 Rtmp(1) = COS( R(2) / Coeff ) * R(1) 19121 Rtmp(2) = SIN( R(2) / Coeff ) * R(1) 19122 Rtmp(3) = R(3) 19123 19124 CASE DEFAULT 19125 CALL Fatal('CoordinateTransformationNodal','Unknown transformation: '//TRIM(CoordTransform) ) 19126 19127 END SELECT 19128 19129 R = Rtmp 19130 19131 END SUBROUTINE CoordinateTransformationNodal 19132 19133 19134 END SUBROUTINE DetectExtrudedStructure 19135 !--------------------------------------------------------------- 19136 19137 19138 19139!-------------------------------------------------------------------------- 19140!> This subroutine finds the structure of an extruded mesh for elements. 19141!> Otherwise very similar as the DetectExtrudedStructure for nodes. 19142!> Mesh faces may need to be created in order to determine the up and down 19143!> pointers. 19144!----------------------------------------------------------------------------- 19145 SUBROUTINE DetectExtrudedElements( Mesh, Solver, ExtVar, & 19146 TopElemPointer, BotElemPointer, UpElemPointer, DownElemPointer, & 19147 NumberOfLayers, ElemLayer ) 19148 19149 USE CoordinateSystems 19150 IMPLICIT NONE 19151 19152 TYPE(Mesh_t), POINTER :: Mesh 19153 TYPE(Solver_t), POINTER :: Solver 19154 TYPE(Variable_t), POINTER, OPTIONAL :: ExtVar 19155 INTEGER, POINTER, OPTIONAL :: TopElemPointer(:), BotElemPointer(:), & 19156 UpElemPointer(:), DownElemPointer(:) 19157 INTEGER, POINTER, OPTIONAL :: ElemLayer(:) 19158 INTEGER, OPTIONAL :: NumberOfLayers 19159!----------------------------------------------------------------------------- 19160 REAL(KIND=dp) :: Direction(3) 19161 TYPE(ValueList_t), POINTER :: Params 19162 TYPE(Variable_t), POINTER :: Var 19163 REAL(KIND=dp) :: Tolerance 19164 TYPE(Element_t), POINTER :: Element, Parent 19165 TYPE(Nodes_t) :: Nodes 19166 INTEGER :: i,j,k,n,ii,jj,dim, nsize, elem, TopNodes, BotNodes, Rounds, ActiveDirection, & 19167 UpHit, DownHit, bc_ind 19168 INTEGER, POINTER :: NodeIndexes(:) 19169 LOGICAL :: UpActive, DownActive, GotIt, Found 19170 LOGICAL, POINTER :: TopFlag(:), BotFlag(:) 19171 REAL(KIND=dp) :: at0, at1 19172 REAL(KIND=dp) :: FaceCenter(3),FaceDx(3),Height(2),Eps, MinTop, MaxTop, MinBot, MaxBot, Diam 19173 REAL(KIND=dp), POINTER :: Values(:) 19174 INTEGER, POINTER :: TopPointer(:), BotPointer(:), UpPointer(:), DownPointer(:),Layer(:),MidPointer(:) 19175 CHARACTER(LEN=MAX_NAME_LEN) :: VarName 19176 INTEGER :: TestCounter(3),ElementIndex(2) 19177 CHARACTER(LEN=MAX_NAME_LEN) :: Caller="DetectExtrudedElements" 19178 19179 CALL Info(Caller,'Determining extruded element structure',Level=6) 19180 at0 = CPUTime() 19181 19182 DIM = Mesh % MeshDim 19183 19184 IF( DIM /= 3 ) THEN 19185 CALL Fatal(Caller,'Only implemented for 3D cases: '//TRIM(I2S(dim))) 19186 END IF 19187 19188 IF( .NOT. ASSOCIATED( Mesh % Faces ) ) THEN 19189 CALL FindMeshFaces3D( Mesh ) 19190 END IF 19191 19192 19193 Params => Solver % Values 19194 TestCounter = 0 19195 19196 ActiveDirection = ListGetInteger(Params,'Active Coordinate') 19197 IF( ActiveDirection < 1 .OR. ActiveDirection > 3 ) THEN 19198 CALL Fatal(Caller,'Invalid value for Active Coordinate') 19199 END IF 19200 19201 ! Set the dot product tolerance 19202 !----------------------------------------------------------------- 19203 Eps = ListGetConstReal( Params,'Dot Product Tolerance',GotIt) 19204 IF(.NOT. GotIt) Eps = 1.0d-1 19205 19206 nsize = Mesh % NumberOfBulkElements 19207 CALL Info(Caller,'Detecting extrusion in the mesh using coordinate: '& 19208 //TRIM(I2S(ActiveDirection)),Level=8) 19209 19210 IF( ActiveDirection == 1 ) THEN 19211 Var => VariableGet( Mesh % Variables,'Coordinate 1') 19212 ELSE IF( ActiveDirection == 2 ) THEN 19213 Var => VariableGet( Mesh % Variables,'Coordinate 2') 19214 ELSE 19215 Var => VariableGet( Mesh % Variables,'Coordinate 3') 19216 END IF 19217 19218 IF( PRESENT( ExtVar ) ) ExtVar => Var 19219 19220 ! Check which direction is active 19221 !--------------------------------------------------------------------- 19222 UpActive = PRESENT( UpElemPointer) .OR. PRESENT ( TopElemPointer ) 19223 DownActive = PRESENT( DownElemPointer) .OR. PRESENT ( BotElemPointer ) 19224 19225 IF( PRESENT( NumberOfLayers) .OR. PRESENT( ElemLayer ) ) THEN 19226 UpActive = .TRUE. 19227 DownActive = .TRUE. 19228 END IF 19229 19230 IF(.NOT. (UpActive .OR. DownActive ) ) THEN 19231 CALL Warn(Caller,'Either up or down direction should be active') 19232 RETURN 19233 END IF 19234 19235 ! Allocate pointers to top and bottom, and temporary pointers up and down 19236 !------------------------------------------------------------------------ 19237 IF( UpActive ) THEN 19238 ALLOCATE(TopPointer(nsize),UpPointer(nsize)) 19239 DO i=1,nsize 19240 TopPointer(i) = i 19241 UpPointer(i) = i 19242 END DO 19243 END IF 19244 IF( DownActive ) THEN 19245 ALLOCATE(BotPointer(nsize),DownPointer(nsize)) 19246 DO i=1,nsize 19247 BotPointer(i) = i 19248 DownPointer(i) = i 19249 END DO 19250 END IF 19251 19252 CALL Info(Caller,'determine up and down pointers',Level=15) 19253 19254 ! Determine the up and down pointers using dot product as criterion 19255 !----------------------------------------------------------------- 19256 n = Mesh % MaxElementNodes 19257 ALLOCATE( Nodes % x(n), Nodes % y(n),Nodes % z(n) ) 19258 19259 DO elem = 1,Mesh % NumberOfFaces 19260 19261 Element => Mesh % Faces(elem) 19262 NodeIndexes => Element % NodeIndexes 19263 CurrentModel % CurrentElement => Element 19264 19265 n = Element % TYPE % NumberOfNodes 19266 Nodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 19267 Nodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 19268 Nodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 19269 19270 IF( .NOT. ASSOCIATED( Element % BoundaryInfo ) ) CYCLE 19271 IF( .NOT. ASSOCIATED( Element % BoundaryInfo % Left ) ) CYCLE 19272 IF( .NOT. ASSOCIATED( Element % BoundaryInfo % Right ) ) CYCLE 19273 19274 FaceCenter(1) = SUM( Nodes % x(1:n) ) / n 19275 FaceCenter(2) = SUM( Nodes % y(1:n) ) / n 19276 FaceCenter(3) = SUM( Nodes % z(1:n) ) / n 19277 19278 FaceDx(1) = SUM( ABS( Nodes % x(1:n) - FaceCenter(1) ) ) 19279 FaceDx(2) = SUM( ABS( Nodes % y(1:n) - FaceCenter(2) ) ) 19280 FaceDx(3) = SUM( ABS( Nodes % z(1:n) - FaceCenter(3) ) ) 19281 19282 Diam = SQRT( SUM( FaceDx**2 ) ) 19283 19284 ! This is not a face that separates extruded elements 19285 IF( FaceDx(ActiveDirection) > Eps * Diam ) CYCLE 19286 19287 TestCounter(1) = TestCounter(1) + 1 19288 19289 DO k = 1, 2 19290 IF( k == 1 ) THEN 19291 Parent => Element % BoundaryInfo % Left 19292 ELSE 19293 Parent => Element % BoundaryInfo % Right 19294 END IF 19295 IF( .NOT. ASSOCIATED( Parent ) ) CYCLE 19296 19297 n = Parent % TYPE % NumberOfNodes 19298 NodeIndexes => Parent % NodeIndexes 19299 19300 ElementIndex(k) = Parent % ElementIndex 19301 Height(k) = SUM( Var % Values(NodeIndexes) ) / n 19302 END DO 19303 19304 IF( Height(1) > Height(2) ) THEN 19305 IF( UpActive ) UpPointer(ElementIndex(2)) = ElementIndex(1) 19306 IF( DownActive ) DownPointer(ElementIndex(1)) = ElementIndex(2) 19307 ELSE 19308 IF( UpActive ) UpPointer(ElementIndex(1)) = ElementIndex(2) 19309 IF( DownActive ) DownPointer(ElementIndex(2)) = ElementIndex(1) 19310 END IF 19311 END DO 19312 19313 DEALLOCATE( Nodes % x, Nodes % y,Nodes % z ) 19314 19315 19316 ! Pointer to top and bottom are found recursively using up and down 19317 !------------------------------------------------------------------ 19318 CALL Info(Caller,'determine top and bottom pointers',Level=9) 19319 19320 DO Rounds = 1, nsize 19321 DownHit = 0 19322 UpHit = 0 19323 DO i=1,nsize 19324 IF( UpActive ) THEN 19325 j = UpPointer(i) 19326 IF( TopPointer(i) /= TopPointer( j ) ) THEN 19327 UpHit = UpHit + 1 19328 TopPointer(i) = TopPointer( j ) 19329 END IF 19330 END IF 19331 IF( DownActive ) THEN 19332 j = DownPointer(i) 19333 IF( BotPointer(i) /= BotPointer( j ) ) THEN 19334 DownHit = DownHit + 1 19335 BotPointer(i) = BotPointer( j ) 19336 END IF 19337 END IF 19338 END DO 19339 CALL Info(Caller,'Hits in determining structure: '//TRIM(I2S(UpHit+DownHit)),Level=10) 19340 IF( UpHit == 0 .AND. DownHit == 0 ) EXIT 19341 END DO 19342 ! The last round is always a check 19343 Rounds = Rounds - 1 19344 19345 19346 WRITE( Message,'(A,I0,A)') 'Layered elements detected in ',Rounds,' cycles' 19347 CALL Info(Caller,Message,Level=9) 19348 IF( Rounds == 0 ) THEN 19349 CALL Info(Caller,'Try to increase value for > Dot Product Tolerance < ') 19350 CALL Fatal(Caller,'Zero rounds implies unsuccessful operation') 19351 END IF 19352 19353 19354 ! Compute the number of layers. The Rounds above may in some cases 19355 ! be too small. Here just one layer is used to determine the number 19356 ! of layers to save some time. 19357 !------------------------------------------------------------------ 19358 IF( PRESENT( NumberOfLayers ) ) THEN 19359 CALL Info(Caller,'Compute number of layers',Level=15) 19360 19361 ! We start from any bottom row entry 19362 j = BotPointer(1) 19363 19364 NumberOfLayers = 0 19365 DO WHILE(.TRUE.) 19366 k = UpPointer(j) 19367 19368 IF( k == j ) THEN 19369 EXIT 19370 ELSE 19371 NumberOfLayers = NumberOfLayers + 1 19372 j = k 19373 END IF 19374 END DO 19375 19376 IF( NumberOfLayers < Rounds ) THEN 19377 WRITE( Message,'(A,I0,A,I0)') 'There seems to be varying number of layers: ',& 19378 NumberOfLayers,' vs. ',Rounds 19379 CALL Warn(Caller, Message ) 19380 NumberOfLayers = Rounds 19381 END IF 19382 CALL Info(Caller,'Extruded structure layers: '//TRIM(I2S(NumberOfLayers)),Level=6) 19383 END IF 19384 19385 19386 ! Create layer index if requested 19387 !------------------------------------------------------------------ 19388 IF( PRESENT( ElemLayer ) ) THEN 19389 CALL Info(Caller,'creating layer index',Level=9) 19390 19391 NULLIFY(Layer) 19392 ALLOCATE( Layer(nsize) ) 19393 Layer = 1 19394 19395 DO i=1,nsize 19396 Rounds = 1 19397 j = BotPointer(i) 19398 Layer(j) = Rounds 19399 DO WHILE(.TRUE.) 19400 k = UpPointer(j) 19401 IF( k == j ) EXIT 19402 Rounds = Rounds + 1 19403 j = k 19404 Layer(j) = Rounds 19405 END DO 19406 END DO 19407 19408 ElemLayer => Layer 19409 WRITE(Message,'(A,I0,A,I0,A)') 'Layer range: [',MINVAL(Layer),',',MAXVAL(Layer),']' 19410 CALL Info(Caller,Message,Level=6) 19411 NULLIFY(Layer) 19412 END IF 19413 19414 19415 ! Count the number of top and bottom elements, for information only 19416 !--------------------------------------------------------------- 19417 CALL Info(Caller,'Counting top and bottom elements',Level=15) 19418 IF( UpActive ) THEN 19419 TopNodes = 0 19420 MinTop = HUGE( MinTop ) 19421 MaxTop = -HUGE( MaxTop ) 19422 DO i=1,nsize 19423 IF(TopPointer(i) == i) THEN 19424 MinTop = MIN( MinTop, Var % Values(i) ) 19425 MaxTop = MAX( MaxTop, Var % Values(i) ) 19426 TopNodes = TopNodes + 1 19427 END IF 19428 END DO 19429 CALL Info(Caller,'Number of top elements: '//TRIM(I2S(TopNodes)),Level=9) 19430 END IF 19431 19432 IF( DownActive ) THEN 19433 BotNodes = 0 19434 MinBot = HUGE( MinBot ) 19435 MaxBot = -HUGE( MaxBot ) 19436 DO i=1,nsize 19437 IF(BotPointer(i) == i) THEN 19438 MinBot = MIN( MinBot, Var % Values(i)) 19439 MaxBot = MAX( MaxBot, Var % Values(i)) 19440 BotNodes = BotNodes + 1 19441 END IF 19442 END DO 19443 END IF 19444 19445 19446 ! Return the requested pointer structures, otherwise deallocate 19447 !--------------------------------------------------------------- 19448 CALL Info(Caller,'Setting pointer structures',Level=15) 19449 IF( UpActive ) THEN 19450 IF( PRESENT( TopElemPointer ) ) THEN 19451 TopElemPointer => TopPointer 19452 NULLIFY( TopPointer ) 19453 ELSE 19454 DEALLOCATE( TopPointer ) 19455 END IF 19456 IF( PRESENT( UpElemPointer ) ) THEN 19457 UpElemPointer => UpPointer 19458 NULLIFY( UpPointer ) 19459 ELSE 19460 DEALLOCATE( UpPointer ) 19461 END IF 19462 END IF 19463 IF( DownActive ) THEN 19464 IF( PRESENT( BotElemPointer ) ) THEN 19465 BotElemPointer => BotPointer 19466 NULLIFY( BotPointer ) 19467 ELSE 19468 DEALLOCATE( BotPointer ) 19469 END IF 19470 IF( PRESENT( DownElemPointer ) ) THEN 19471 DownElemPointer => DownPointer 19472 NULLIFY( DownPointer ) 19473 ELSE 19474 DEALLOCATE( DownPointer ) 19475 END IF 19476 END IF 19477 19478 !--------------------------------------------------------------- 19479 at1 = CPUTime() 19480 WRITE(Message,'(A,ES12.3)') 'Top and bottom pointer init time: ',at1-at0 19481 CALL Info(Caller,Message,Level=6) 19482 19483 CALL Info(Caller,'Top and bottom pointer init rounds: '//TRIM(I2S(Rounds)),Level=8) 19484 19485 IF( UpActive ) THEN 19486 CALL Info(Caller,'Number of elements at the top: '//TRIM(I2S(TopNodes)),Level=8) 19487 END IF 19488 IF( DownActive ) THEN 19489 CALL Info(Caller,'Number of elements at the bottom: '//TRIM(I2S(BotNodes)),Level=8) 19490 END IF 19491 19492 19493 END SUBROUTINE DetectExtrudedElements 19494 !--------------------------------------------------------------- 19495 19496 19497 19498 !---------------------------------------------------------------- 19499 !> Maps coordinates from the original nodes into a new coordinate 19500 !> system while optionally maintaining the original coordinates. 19501 !> Note that this may be called 19502 !--------------------------------------------------------------- 19503 SUBROUTINE CoordinateTransformation( Mesh, CoordTransform, Params, & 19504 IrreversibleTransformation ) 19505 TYPE(Mesh_t), POINTER :: Mesh 19506 CHARACTER(LEN=MAX_NAME_LEN) :: CoordTransform 19507 TYPE(ValueList_t), POINTER :: Params 19508 LOGICAL, OPTIONAL :: IrreversibleTransformation 19509 !--------------------------------------------------------------- 19510 REAL(KIND=dp) :: R0(3),R1(3),Coeff,Rad0 19511 LOGICAL :: Irreversible,FirstTime,Reuse,UpdateNodes,Found 19512 REAL(KIND=dp), POINTER :: x0(:),y0(:),z0(:),x1(:),y1(:),z1(:) 19513 REAL(KIND=dp), POINTER CONTIG :: NewCoords(:) 19514 INTEGER :: i,j,k,n,Mode 19515 TYPE(Variable_t), POINTER :: Var 19516 19517 ! The coordinate transformation may either be global for all the solvers 19518 ! and this overrides the original nodes permanently. 19519 ! Or it can be a solver specific transformation which saves the initial 19520 ! coordinates. 19521 CALL Info('CoordinateTransformation','Starting') 19522 19523 IF(.NOT. ASSOCIATED(Mesh) ) THEN 19524 CALL Fatal('CoordinateTransformation','Mesh not associated!') 19525 END IF 19526 19527 IF( PRESENT( IrreversibleTransformation ) ) THEN 19528 Irreversible = IrreversibleTransformation 19529 ELSE 19530 Irreversible = .FALSE. 19531 END IF 19532 19533 n = Mesh % NumberOfNodes 19534 19535 x0 => Mesh % Nodes % x 19536 y0 => Mesh % Nodes % y 19537 z0 => Mesh % Nodes % z 19538 19539 IF( Irreversible ) THEN 19540 UpdateNodes = .TRUE. 19541 ! Map to the same nodes 19542 x1 => Mesh % Nodes % x 19543 y1 => Mesh % Nodes % y 19544 z1 => Mesh % Nodes % z 19545 ELSE 19546 ReUse = ListGetLogical(Params,'Coordinate Transformation Reuse',Found ) 19547 FirstTime = .NOT. ASSOCIATED( Mesh % NodesMapped ) 19548 IF( FirstTime ) THEN 19549 ALLOCATE( Mesh % NodesMapped ) 19550 NULLIFY( NewCoords ) 19551 ALLOCATE( NewCoords(3*n) ) 19552 NewCoords = 0.0_dp 19553 Mesh % NodesMapped % x => NewCoords(1:n) 19554 Mesh % NodesMapped % y => NewCoords(n+1:2*n) 19555 Mesh % NodesMapped % z => NewCoords(2*n+1:3*n) 19556 ! Mesh % NodesMapped % x => NewCoords(1::3) 19557 ! Mesh % NodesMapped % y => NewCoords(2::3) 19558 ! Mesh % NodesMapped % z => NewCoords(3::3) 19559 ELSE 19560 IF( n /= SIZE(Mesh % NodesMapped % x) ) THEN 19561 CALL Fatal('CoordinateTransformation','Sizes of original and mapped mesh differ!') 19562 END IF 19563 END IF 19564 19565 IF( CoordTransform == 'previous' ) THEN 19566 IF( FirstTime ) THEN 19567 CALL Fatal('CoordinateTransformation','One cannot reuse unexisting transformation!') 19568 END IF 19569 ReUse = .TRUE. 19570 END IF 19571 19572 ! Note that if many solvers reutilize the same coordinates then they must 19573 ! also have the same coordinate mapping. 19574 !------------------------------------------------------------------------ 19575 UpdateNodes = FirstTime .OR. .NOT. ReUse 19576 ! Map different nodes if the original ones are kept 19577 x1 => Mesh % NodesMapped % x 19578 y1 => Mesh % NodesMapped % y 19579 z1 => Mesh % NodesMapped % z 19580 19581 IF( FirstTime ) THEN 19582 IF( ListGetLogical(Params,'Coordinate Transformation Save',Found ) ) THEN 19583 CALL Info('CoordinateTranformation',& 19584 'Creating variables for > Transformed Coordinate < ') 19585 CALL VariableAdd( Mesh % Variables,Mesh,CurrentModel % Solver,& 19586 'Transformed Coordinate 1',1,x1) 19587 CALL VariableAdd( Mesh % Variables,Mesh,CurrentModel % Solver,& 19588 'Transformed Coordinate 2',1,y1) 19589 CALL VariableAdd( Mesh % Variables,Mesh,CurrentModel % Solver,& 19590 'Transformed Coordinate 3',1,z1) 19591 CALL VariableAdd( Mesh % Variables,Mesh,CurrentModel % Solver,& 19592 'Transformed Coordinate',3,NewCoords) 19593 END IF 19594 END IF 19595 END IF 19596 19597 IF( UpdateNodes ) THEN 19598 IF( ListGetLogical( Params,'Coordinate Transformation Use Degrees',Found) ) THEN 19599 Coeff = 180.0_dp / PI 19600 CALL Info('CoordinateTranformation','Using degrees for angles') 19601 ELSE 19602 Coeff = 1.0_dp 19603 END IF 19604 19605 Rad0 = ListGetConstReal( Params,'Coordinate Transformation Radius',Found ) 19606 19607 SELECT CASE ( CoordTransform ) 19608 19609 CASE('cartesian to polar') 19610 Mode = 1 19611 CASE('cartesian to cylindrical') 19612 Mode = 1 19613 CASE('polar to cartesian') 19614 Mode = -1 19615 CASE('cylindrical to cartesian') 19616 Mode = -1 19617 19618 CASE DEFAULT 19619 CALL Fatal('CoordinateTransformation','Unknown transformation: '//TRIM(CoordTransform) ) 19620 19621 END SELECT 19622 19623 DO i=1,n 19624 R0(1) = x0(i) 19625 R0(2) = y0(i) 19626 R0(3) = z0(i) 19627 19628 IF( Mode == 1 ) THEN 19629 R1(1) = Rad0 + SQRT( R0(1)**2 + R0(2)**2) 19630 R1(2) = Coeff * ATAN2( R0(2), R0(1) ) 19631 R1(3) = R0(3) 19632 19633 ELSE IF( Mode == -1 ) THEN 19634 R1(1) = COS( R0(2) / Coeff ) * ( R0(1) + Rad0 ) 19635 R1(2) = SIN( R0(2) / Coeff ) * ( R0(1) + Rad0 ) 19636 R1(3) = R0(3) 19637 END IF 19638 19639 x1(i) = R1(1) 19640 y1(i) = R1(2) 19641 z1(i) = R1(3) 19642 19643 END DO 19644 END IF 19645 19646 IF( .NOT. Irreversible ) THEN 19647 Mesh % NodesOrig => Mesh % Nodes 19648 Mesh % Nodes => Mesh % NodesMapped 19649 19650 Var => VariableGet( CurrentModel % Variables,'Coordinate 1') 19651 Var % Values => Mesh % Nodes % x 19652 19653 Var => VariableGet( CurrentModel % Variables,'Coordinate 2') 19654 Var % Values => Mesh % Nodes % y 19655 19656 Var => VariableGet( CurrentModel % Variables,'Coordinate 3') 19657 Var % Values => Mesh % Nodes % z 19658 END IF 19659 19660 CALL Info('CoordinateTransformation','All done',Level=8) 19661 19662 END SUBROUTINE CoordinateTransformation 19663!--------------------------------------------------------------- 19664 19665 19666!--------------------------------------------------------------- 19667!> Return back to the original coordinate system. 19668!--------------------------------------------------------------- 19669 SUBROUTINE BackCoordinateTransformation( Mesh, DeleteTemporalMesh ) 19670 TYPE(Mesh_t) :: Mesh 19671 LOGICAL, OPTIONAL :: DeleteTemporalMesh 19672!--------------------------------------------------------------- 19673 TYPE(Variable_t), POINTER :: Var 19674 19675 IF( PRESENT( DeleteTemporalMesh ) ) THEN 19676 IF( DeleteTemporalMesh ) THEN 19677 DEALLOCATE( Mesh % NodesMapped % x, & 19678 Mesh % NodesMapped % y, & 19679 Mesh % NodesMapped % z ) 19680 DEALLOCATE( Mesh % NodesMapped ) 19681 END IF 19682 END IF 19683 19684 IF( .NOT. ASSOCIATED( Mesh % NodesOrig ) ) THEN 19685 CALL Fatal('BackCoordinateTransformation','NodesOrig not associated') 19686 END IF 19687 19688 Mesh % Nodes => Mesh % NodesOrig 19689 19690 Var => VariableGet( CurrentModel % Variables,'Coordinate 1') 19691 Var % Values => Mesh % Nodes % x 19692 19693 Var => VariableGet( CurrentModel % Variables,'Coordinate 2') 19694 Var % Values => Mesh % Nodes % y 19695 19696 Var => VariableGet( CurrentModel % Variables,'Coordinate 3') 19697 Var % Values => Mesh % Nodes % z 19698 19699 END SUBROUTINE BackCoordinateTransformation 19700!--------------------------------------------------------------- 19701 19702 19703!--------------------------------------------------------------- 19704!> This partitions the mesh into a given number of partitions in each 19705!> direction. It may be used in clustering multigrid or similar, 19706!> and also to internal partitioning within ElmerSolver. 19707!--------------------------------------------------------------- 19708 SUBROUTINE ClusterNodesByDirection(Params,Mesh,Clustering,MaskActive) 19709 19710 USE GeneralUtils 19711 19712 TYPE(ValueList_t), POINTER :: Params 19713 TYPE(Mesh_t), POINTER :: Mesh 19714 LOGICAL, OPTIONAL :: MaskActive(:) 19715 INTEGER, POINTER :: Clustering(:) 19716!--------------------------------------------------------------- 19717 LOGICAL :: MaskExists,GotIt,Hit 19718 REAL(KIND=dp), ALLOCATABLE :: Measure(:) 19719 INTEGER :: i,j,k,k0,l,ind,n,dim,dir,divs,nsize,elemsinpart,clusters 19720 INTEGER, POINTER :: Iarray(:),Order(:),NodePart(:),NoPart(:) 19721 INTEGER :: Divisions(3),minpart,maxpart,clustersize 19722 REAL(KIND=dp), POINTER :: PArray(:,:), Arrange(:) 19723 REAL(KIND=dp) :: Normal(3), Tangent1(3), Tangent2(3), Coord(3), Weights(3), & 19724 avepart,devpart 19725!--------------------------------------------------------------- 19726 19727 ! CALL Info('ClusterNodesByDirection','') 19728 19729 MaskExists = PRESENT(MaskActive) 19730 IF( MaskExists ) THEN 19731 nsize = COUNT( MaskActive ) 19732 ELSE 19733 nsize = Mesh % NumberOfNodes 19734 END IF 19735 19736 IF( .NOT. ASSOCIATED( Params ) ) THEN 19737 CALL Fatal('ClusterNodesByDirection','No parameter list associated') 19738 END IF 19739 19740 dim = Mesh % MeshDim 19741 Parray => ListGetConstRealArray( Params,'Clustering Normal Vector',GotIt ) 19742 IF( GotIt ) THEN 19743 Normal = Parray(1:3,1) 19744 ELSE 19745 Normal(1) = 1.0 19746 Normal(2) = 1.0d-2 19747 IF( dim == 3) Normal(3) = 1.0d-4 19748 END IF 19749 Normal = Normal / SQRT( SUM( Normal ** 2) ) 19750 19751 CALL TangentDirections( Normal,Tangent1,Tangent2 ) 19752 19753 19754 IF( .FALSE. ) THEN 19755 PRINT *,'Normal:',Normal 19756 PRINT *,'Tangent1:',Tangent1 19757 PRINT *,'Tangent2:',Tangent2 19758 END IF 19759 19760 19761 Iarray => ListGetIntegerArray( Params,'Partitioning Divisions',GotIt ) 19762 IF(.NOT. GotIt) Iarray => ListGetIntegerArray( Params,'MG Cluster Divisions',GotIt ) 19763 Divisions = 1 19764 IF( GotIt ) THEN 19765 n = MIN( SIZE(Iarray), dim ) 19766 Divisions(1:n) = Iarray(1:n) 19767 ELSE 19768 clustersize = ListGetInteger( Params,'Partitioning Size',GotIt) 19769 IF(.NOT. GotIt) clustersize = ListGetInteger( Params,'MG Cluster Size',GotIt) 19770 IF( GotIt .AND. ClusterSize > 0) THEN 19771 IF( dim == 2 ) THEN 19772 Divisions(1) = ( nsize / clustersize ) ** 0.5_dp 19773 Divisions(2) = ( nsize / ( clustersize * Divisions(1) ) ) 19774 ELSE 19775 Divisions(1:2) = ( nsize / clustersize ) ** (1.0_dp / 3 ) 19776 Divisions(3) = ( nsize / ( clustersize * Divisions(1) * Divisions(2) ) ) 19777 END IF 19778 ELSE 19779 CALL Fatal('ClusterNodesByDirection','Clustering Divisions not given!') 19780 END IF 19781 END IF 19782 19783 Clusters = Divisions(1) * Divisions(2) * Divisions(3) 19784 19785 IF( .FALSE. ) THEN 19786 PRINT *,'dim:',dim 19787 PRINT *,'divisions:',divisions 19788 PRINT *,'clusters:',clusters 19789 PRINT *,'nsize:',nsize 19790 END IF 19791 19792 ALLOCATE(Order(nsize),Arrange(nsize),NodePart(nsize),NoPart(Clusters)) 19793 19794 19795 ! These are needed as an initial value for the loop over dimension 19796 elemsinpart = nsize 19797 nodepart = 1 19798 19799 19800 ! Go through each direction and cumulatively add to the clusters 19801 !----------------------------------------------------------- 19802 19803 DO dir = 1,dim 19804 divs = Divisions(dir) 19805 IF( divs <= 1 ) CYCLE 19806 19807 ! Use the three principal directions as the weight 19808 !------------------------------------------------- 19809 IF( dir == 1 ) THEN 19810 Weights = Normal 19811 ELSE IF( dir == 2 ) THEN 19812 Weights = Tangent1 19813 ELSE 19814 Weights = Tangent2 19815 END IF 19816 19817 ! Initialize ordering for the current direction 19818 !---------------------------------------------- 19819 DO i=1,nsize 19820 Order(i) = i 19821 END DO 19822 19823 19824 ! Now compute the weights for each node 19825 !---------------------------------------- 19826 DO i=1,Mesh % NumberOfNodes 19827 j = i 19828 IF( MaskExists ) THEN 19829 IF( .NOT. MaskActive(j) ) CYCLE 19830 END IF 19831 19832 Coord(1) = Mesh % Nodes % x(i) 19833 Coord(2) = Mesh % Nodes % y(i) 19834 Coord(3) = Mesh % Nodes % z(i) 19835 19836 Arrange(j) = SUM( Weights * Coord ) 19837 END DO 19838 19839 ! Order the nodes for given direction 19840 !---------------------------------------------- 19841 CALL SortR(nsize,Order,Arrange) 19842 19843 ! For each direction the number of elements in cluster becomes smaller 19844 elemsinpart = elemsinpart / divs 19845 19846 ! initialize the counter partition 19847 nopart = 0 19848 19849 19850 ! Go through each node and locate it to a cluster taking into consideration 19851 ! the previous clustering (for 1st direction all one) 19852 !------------------------------------------------------------------------ 19853 j = 1 19854 DO i = 1,nsize 19855 ind = Order(i) 19856 19857 ! the initial partition offset depends on previous partitioning 19858 k0 = (nodepart(ind)-1) * divs 19859 19860 ! Find the correct new partitioning, this loop is just long enough 19861 DO l=1,divs 19862 Hit = .FALSE. 19863 19864 ! test for increase of local partition 19865 IF( j < divs ) THEN 19866 IF( nopart(k0+j) >= elemsinpart ) THEN 19867 j = j + 1 19868 Hit = .TRUE. 19869 END IF 19870 END IF 19871 19872 ! test for decrease of local partition 19873 IF( j > 1 ) THEN 19874 IF( nopart(k0+j-1) < elemsinpart ) THEN 19875 j = j - 1 19876 Hit = .TRUE. 19877 END IF 19878 END IF 19879 19880 ! If either increase or decrease is needed, this must be ok 19881 IF(.NOT. Hit) EXIT 19882 END DO 19883 19884 k = k0 + j 19885 nopart(k) = nopart(k) + 1 19886 nodepart(ind) = k 19887 END DO 19888 19889 END DO 19890 19891 19892 minpart = HUGE(minpart) 19893 maxpart = 0 19894 avepart = 1.0_dp * nsize / clusters 19895 devpart = 0.0_dp 19896 DO i=1,clusters 19897 minpart = MIN( minpart, nopart(i)) 19898 maxpart = MAX( maxpart, nopart(i)) 19899 devpart = devpart + ABS ( nopart(i) - avepart ) 19900 END DO 19901 devpart = devpart / clusters 19902 19903 WRITE(Message,'(A,T25,I10)') 'Min nodes in cluster:',minpart 19904 CALL Info('ClusterNodesByDirection',Message) 19905 WRITE(Message,'(A,T25,I10)') 'Max nodes in cluster:',maxpart 19906 CALL Info('ClusterNodesByDirection',Message) 19907 WRITE(Message,'(A,T28,F10.2)') 'Average nodes in cluster:',avepart 19908 CALL Info('ClusterNodesByDirection',Message) 19909 WRITE(Message,'(A,T28,F10.2)') 'Deviation of nodes:',devpart 19910 CALL Info('ClusterNodesByDirection',Message) 19911 19912 19913 IF( ASSOCIATED(Clustering)) THEN 19914 Clustering = Nodepart 19915 DEALLOCATE(Nodepart) 19916 ELSE 19917 Clustering => Nodepart 19918 NULLIFY( Nodepart ) 19919 END IF 19920 19921 DEALLOCATE(Order,Arrange,NoPart) 19922 19923 19924 END SUBROUTINE ClusterNodesByDirection 19925 19926 19927 19928 SUBROUTINE ClusterElementsByDirection(Params,Mesh,Clustering,MaskActive) 19929 19930 USE GeneralUtils 19931 19932 TYPE(ValueList_t), POINTER :: Params 19933 TYPE(Mesh_t), POINTER :: Mesh 19934 LOGICAL, OPTIONAL :: MaskActive(:) 19935 INTEGER, POINTER :: Clustering(:) 19936!--------------------------------------------------------------- 19937 LOGICAL :: MaskExists,GotIt,Hit 19938 REAL(KIND=dp), ALLOCATABLE :: Measure(:) 19939 INTEGER :: i,j,k,k0,l,ind,n,dim,dir,divs,nsize,elemsinpart,clusters 19940 INTEGER, POINTER :: Iarray(:),Order(:),NodePart(:),NoPart(:) 19941 INTEGER :: Divisions(3),minpart,maxpart,clustersize 19942 REAL(KIND=dp), POINTER :: PArray(:,:), Arrange(:) 19943 REAL(KIND=dp) :: Normal(3), Tangent1(3), Tangent2(3), Coord(3), Weights(3), & 19944 avepart,devpart, dist 19945 TYPE(Element_t), POINTER :: Element 19946 INTEGER, POINTER :: NodeIndexes(:) 19947!--------------------------------------------------------------- 19948 19949 ! CALL Info('ClusterElementsByDirection','') 19950 19951 MaskExists = PRESENT(MaskActive) 19952 IF( MaskExists ) THEN 19953 nsize = COUNT( MaskActive ) 19954 ELSE 19955 nsize = Mesh % NumberOfBulkElements 19956 END IF 19957 19958 IF( .NOT. ASSOCIATED( Params ) ) THEN 19959 CALL Fatal('ClusterElementsByDirection','No parameter list associated') 19960 END IF 19961 19962 dim = Mesh % MeshDim 19963 Parray => ListGetConstRealArray( Params,'Clustering Normal Vector',GotIt ) 19964 IF( GotIt ) THEN 19965 Normal = Parray(1:3,1) 19966 ELSE 19967 Normal(1) = 1.0 19968 Normal(2) = 1.0d-2 19969 IF( dim == 3) THEN 19970 Normal(3) = 1.0d-4 19971 ELSE 19972 Normal(3) = 0.0_dp 19973 END IF 19974 END IF 19975 Normal = Normal / SQRT( SUM( Normal ** 2) ) 19976 19977 CALL TangentDirections( Normal,Tangent1,Tangent2 ) 19978 19979 IF( .FALSE. ) THEN 19980 PRINT *,'Normal:',Normal 19981 PRINT *,'Tangent1:',Tangent1 19982 PRINT *,'Tangent2:',Tangent2 19983 END IF 19984 19985 Iarray => ListGetIntegerArray( Params,'Partitioning Divisions',GotIt ) 19986 IF(.NOT. GotIt ) THEN 19987 Iarray => ListGetIntegerArray( Params,'MG Cluster Divisions',GotIt ) 19988 END IF 19989 19990 Divisions = 1 19991 IF( GotIt ) THEN 19992 n = MIN( SIZE(Iarray), dim ) 19993 Divisions(1:n) = Iarray(1:n) 19994 ELSE 19995 clustersize = ListGetInteger( Params,'Partitioning Size',GotIt) 19996 IF(.NOT. GotIt) clustersize = ListGetInteger( Params,'MG Cluster Size',GotIt) 19997 IF( GotIt .AND. ClusterSize > 0) THEN 19998 IF( dim == 2 ) THEN 19999 Divisions(1) = ( nsize / clustersize ) ** 0.5_dp 20000 Divisions(2) = ( nsize / ( clustersize * Divisions(1) ) ) 20001 ELSE 20002 Divisions(1:2) = ( nsize / clustersize ) ** (1.0_dp / 3 ) 20003 Divisions(3) = ( nsize / ( clustersize * Divisions(1) * Divisions(2) ) ) 20004 END IF 20005 ELSE 20006 CALL Fatal('ClusterElementsByDirection','Clustering Divisions not given!') 20007 END IF 20008 END IF 20009 20010 Clusters = Divisions(1) * Divisions(2) * Divisions(3) 20011 20012 IF( .FALSE. ) THEN 20013 PRINT *,'dim:',dim 20014 PRINT *,'divisions:',divisions 20015 PRINT *,'clusters:',clusters 20016 PRINT *,'nsize:',nsize 20017 END IF 20018 20019 ALLOCATE(Order(nsize),Arrange(nsize),NodePart(nsize),NoPart(Clusters)) 20020 20021 20022 ! These are needed as an initial value for the loop over dimension 20023 elemsinpart = nsize 20024 nodepart = 1 20025 20026 20027 ! Go through each direction and cumulatively add to the clusters 20028 !----------------------------------------------------------- 20029 20030 DO dir = 1,dim 20031 divs = Divisions(dir) 20032 IF( divs <= 1 ) CYCLE 20033 20034 ! Use the three principal directions as the weight 20035 !------------------------------------------------- 20036 IF( dir == 1 ) THEN 20037 Weights = Normal 20038 ELSE IF( dir == 2 ) THEN 20039 Weights = Tangent1 20040 ELSE 20041 Weights = Tangent2 20042 END IF 20043 20044 ! Now compute the weights for each node 20045 !---------------------------------------- 20046 j = 0 20047 DO i=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 20048 IF( MaskExists ) THEN 20049 IF( .NOT. MaskActive( i ) ) CYCLE 20050 ELSE 20051 IF( i > Mesh % NumberOfBulkElements ) EXIT 20052 END IF 20053 20054 Element => Mesh % Elements(i) 20055 NodeIndexes => Element % NodeIndexes 20056 n = Element % TYPE % NumberOfNodes 20057 20058 Coord(1) = SUM( Mesh % Nodes % x( NodeIndexes ) ) / n 20059 Coord(2) = SUM( Mesh % Nodes % y( NodeIndexes ) ) / n 20060 Coord(3) = SUM( Mesh % Nodes % z( NodeIndexes ) ) / n 20061 20062 j = j + 1 20063 Arrange(j) = SUM( Weights * Coord ) 20064 20065 ! Initialize ordering for the current direction 20066 Order(j) = j 20067 END DO 20068 20069 ! Order the distances for given direction, only the active ones 20070 !-------------------------------------------------------------- 20071 CALL SortR(nsize,Order,Arrange) 20072 20073 ! For each direction the number of elements in cluster becomes smaller 20074 elemsinpart = elemsinpart / divs 20075 20076 ! initialize the counter partition 20077 nopart = 0 20078 20079 ! Go through each node and locate it to a cluster taking into consideration 20080 ! the previous clustering (for 1st direction all one) 20081 !------------------------------------------------------------------------ 20082 j = 1 20083 DO i = 1,nsize 20084 ind = Order(i) 20085 20086 ! the initial partition offset depends on previous partitioning 20087 k0 = (nodepart(ind)-1) * divs 20088 20089 ! Find the correct new partitioning, this loop is just long enough 20090 DO l=1,divs 20091 Hit = .FALSE. 20092 20093 ! test for increase of local partition 20094 IF( j < divs ) THEN 20095 IF( nopart(k0+j) >= elemsinpart ) THEN 20096 j = j + 1 20097 Hit = .TRUE. 20098 END IF 20099 END IF 20100 20101 ! test for decrease of local partition 20102 IF( j > 1 ) THEN 20103 IF( nopart(k0+j-1) < elemsinpart ) THEN 20104 j = j - 1 20105 Hit = .TRUE. 20106 END IF 20107 END IF 20108 20109 ! If either increase or decrease is needed, this must be ok 20110 IF(.NOT. Hit) EXIT 20111 END DO 20112 20113 k = k0 + j 20114 nopart(k) = nopart(k) + 1 20115 20116 ! Now set the partition 20117 nodepart(ind) = k 20118 END DO 20119 20120 END DO 20121 20122 20123 minpart = HUGE(minpart) 20124 maxpart = 0 20125 avepart = 1.0_dp * nsize / clusters 20126 devpart = 0.0_dp 20127 DO i=1,clusters 20128 minpart = MIN( minpart, nopart(i)) 20129 maxpart = MAX( maxpart, nopart(i)) 20130 devpart = devpart + ABS ( nopart(i) - avepart ) 20131 END DO 20132 devpart = devpart / clusters 20133 20134 WRITE(Message,'(A,T25,I10)') 'Min nodes in cluster:',minpart 20135 CALL Info('ClusterElementsByDirection',Message) 20136 WRITE(Message,'(A,T25,I10)') 'Max nodes in cluster:',maxpart 20137 CALL Info('ClusterElementsByDirection',Message) 20138 WRITE(Message,'(A,T28,F10.2)') 'Average nodes in cluster:',avepart 20139 CALL Info('ClusterElementsByDirection',Message) 20140 WRITE(Message,'(A,T28,F10.2)') 'Deviation of nodes:',devpart 20141 CALL Info('ClusterElementsByDirection',Message) 20142 20143 20144 IF( ASSOCIATED(Clustering)) THEN 20145 IF( PRESENT( MaskActive ) ) THEN 20146 j = 0 20147 DO i=1, SIZE(MaskActive) 20148 IF( MaskActive(i) ) THEN 20149 j = j + 1 20150 Clustering(i) = Nodepart(j) 20151 END IF 20152 END DO 20153 ELSE 20154 Clustering = Nodepart 20155 END IF 20156 DEALLOCATE(Nodepart) 20157 ELSE 20158 Clustering => Nodepart 20159 NULLIFY( Nodepart ) 20160 END IF 20161 20162 DEALLOCATE(Order,Arrange,NoPart) 20163 20164 END SUBROUTINE ClusterElementsByDirection 20165 20166 20167 20168 SUBROUTINE ClusterElementsUniform(Params,Mesh,Clustering,MaskActive,PartitionDivisions) 20169 20170 USE GeneralUtils 20171 20172 TYPE(ValueList_t), POINTER :: Params 20173 TYPE(Mesh_t), POINTER :: Mesh 20174 INTEGER, POINTER :: Clustering(:) 20175 LOGICAL, OPTIONAL :: MaskActive(:) 20176 INTEGER, OPTIONAL :: PartitionDivisions(3) 20177!--------------------------------------------------------------- 20178 LOGICAL :: MaskExists,UseMaskedBoundingBox,Found 20179 INTEGER :: i,j,k,ind,n,dim,nsize,nmask,clusters 20180 INTEGER, POINTER :: Iarray(:),ElemPart(:) 20181 INTEGER, ALLOCATABLE :: NoPart(:) 20182 INTEGER :: Divisions(3),minpart,maxpart,Inds(3) 20183 REAL(KIND=dp) :: Coord(3), Weights(3), avepart,devpart 20184 TYPE(Element_t), POINTER :: Element 20185 INTEGER, POINTER :: NodeIndexes(:) 20186 REAL(KIND=dp) :: BoundingBox(6) 20187 INTEGER, ALLOCATABLE :: CellCount(:,:,:) 20188 LOGICAL, ALLOCATABLE :: NodeMask(:) 20189 CHARACTER(LEN=MAX_NAME_LEN) :: Caller="ClusterElementsUniform" 20190 20191 CALL Info(Caller,'Clustering elements uniformly in bounding box',Level=6) 20192 20193 IF( Mesh % NumberOfBulkElements == 0 ) RETURN 20194 20195 MaskExists = PRESENT(MaskActive) 20196 IF( MaskExists ) THEN 20197 nsize = SIZE( MaskActive ) 20198 nmask = COUNT( MaskActive ) 20199 CALL Info(Caller,'Applying division to masked element: '//TRIM(I2S(nmask)),Level=8) 20200 ELSE 20201 nsize = Mesh % NumberOfBulkElements 20202 nmask = nsize 20203 CALL Info(Caller,'Applying division to all bulk elements: '//TRIM(I2S(nsize)),Level=8) 20204 END IF 20205 20206 IF( .NOT. ASSOCIATED( Params ) ) THEN 20207 CALL Fatal(Caller,'No parameter list associated') 20208 END IF 20209 20210 dim = Mesh % MeshDim 20211 20212 ! We can use the masked bounding box 20213 UseMaskedBoundingBox = .FALSE. 20214 IF( MaskExists ) UseMaskedBoundingBox = ListGetLogical( Params,& 20215 'Partition Masked Bounding Box',Found ) 20216 20217 IF( UseMaskedBoundingBox ) THEN 20218 ALLOCATE( NodeMask( Mesh % NumberOfNodes ) ) 20219 NodeMask = .FALSE. 20220 20221 ! Add all active nodes to the mask 20222 DO i=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 20223 IF( .NOT. MaskActive( i ) ) CYCLE 20224 Element => Mesh % Elements(i) 20225 NodeIndexes => Element % NodeIndexes 20226 NodeMask( NodeIndexes ) = .TRUE. 20227 END DO 20228 20229 i = COUNT( NodeMask ) 20230 CALL Info(Caller,'Masked elements include nodes: '//TRIM(I2S(i)),Level=8) 20231 20232 ! Define the masked bounding box 20233 BoundingBox(1) = MINVAL( Mesh % Nodes % x, NodeMask ) 20234 BoundingBox(2) = MAXVAL( Mesh % Nodes % x, NodeMask ) 20235 BoundingBox(3) = MINVAL( Mesh % Nodes % y, NodeMask ) 20236 BoundingBox(4) = MAXVAL( Mesh % Nodes % y, NodeMask ) 20237 BoundingBox(5) = MINVAL( Mesh % Nodes % z, NodeMask ) 20238 BoundingBox(6) = MAXVAL( Mesh % Nodes % z, NodeMask ) 20239 20240 DEALLOCATE( NodeMask ) 20241 ELSE 20242 BoundingBox(1) = MINVAL( Mesh % Nodes % x ) 20243 BoundingBox(2) = MAXVAL( Mesh % Nodes % x ) 20244 BoundingBox(3) = MINVAL( Mesh % Nodes % y ) 20245 BoundingBox(4) = MAXVAL( Mesh % Nodes % y ) 20246 BoundingBox(5) = MINVAL( Mesh % Nodes % z ) 20247 BoundingBox(6) = MAXVAL( Mesh % Nodes % z ) 20248 END IF 20249 20250 20251 IF( PRESENT( PartitionDivisions ) ) THEN 20252 Divisions = PartitionDivisions 20253 ELSE 20254 Iarray => ListGetIntegerArray( Params,'Partitioning Divisions',Found) 20255 IF(.NOT. Found ) THEN 20256 CALL Fatal(Caller,'> Partitioning Divisions < not given!') 20257 END IF 20258 Divisions = 1 20259 IF( Found ) THEN 20260 n = MIN( SIZE(Iarray), dim ) 20261 Divisions(1:n) = Iarray(1:n) 20262 END IF 20263 END IF 20264 20265 ALLOCATE( CellCount(Divisions(1), Divisions(2), Divisions(3) ) ) 20266 CellCount = 0 20267 Clusters = 1 20268 DO i=1,dim 20269 Clusters = Clusters * Divisions(i) 20270 END DO 20271 20272 IF( .FALSE. ) THEN 20273 PRINT *,'dim:',dim 20274 PRINT *,'divisions:',divisions 20275 PRINT *,'clusters:',clusters 20276 PRINT *,'nsize:',nsize 20277 END IF 20278 20279 ALLOCATE(ElemPart(nsize),NoPart(Clusters)) 20280 NoPart = 0 20281 ElemPart = 0 20282 20283 !---------------------------------------- 20284 Inds = 1 20285 Coord = 0.0_dp 20286 20287 DO i=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 20288 IF( MaskExists ) THEN 20289 IF( .NOT. MaskActive( i ) ) CYCLE 20290 ELSE 20291 IF( i > Mesh % NumberOfBulkElements ) EXIT 20292 END IF 20293 20294 Element => Mesh % Elements(i) 20295 NodeIndexes => Element % NodeIndexes 20296 n = Element % TYPE % NumberOfNodes 20297 20298 ! Find the center of the element 20299 Coord(1) = SUM( Mesh % Nodes % x( NodeIndexes ) ) / n 20300 Coord(2) = SUM( Mesh % Nodes % y( NodeIndexes ) ) / n 20301 IF( dim == 3 ) THEN 20302 Coord(3) = SUM( Mesh % Nodes % z( NodeIndexes ) ) / n 20303 END IF 20304 20305 Inds = 1 20306 DO j=1,dim 20307 Inds(j) = CEILING( Divisions(j) * & 20308 ( Coord(j) - BoundingBox(2*j-1) ) / & 20309 ( BoundingBox(2*j) - BoundingBox(2*j-1) ) ) 20310 END DO 20311 Inds = MAX( Inds, 1 ) 20312 20313 CellCount(Inds(1),Inds(2),Inds(3)) = & 20314 CellCount(Inds(1),Inds(2),Inds(3)) + 1 20315 20316 ind = (Inds(1)-1)*Divisions(2)*Divisions(3) + & 20317 (Inds(2)-1)*Divisions(3) + & 20318 Inds(3) 20319 ElemPart(i) = ind 20320 NoPart(ind) = NoPart(ind) + 1 20321 END DO 20322 20323 ! Compute statistical information of the partitioning 20324 n = COUNT( NoPart > 0 ) 20325 minpart = HUGE(minpart) 20326 maxpart = 0 20327 avepart = 1.0_dp * nmask / n 20328 devpart = 0.0_dp 20329 DO i=1,clusters 20330 IF( nopart(i) > 0 ) THEN 20331 minpart = MIN( minpart, nopart(i)) 20332 maxpart = MAX( maxpart, nopart(i)) 20333 devpart = devpart + ABS ( nopart(i) - avepart ) 20334 END IF 20335 END DO 20336 devpart = devpart / n 20337 20338 CALL Info(Caller,'Number of partitions: '//TRIM(I2S(n)),Level=8) 20339 CALL Info(Caller,'Min elements in cluster: '//TRIM(I2S(minpart)),Level=8) 20340 CALL Info(Caller,'Max elements in cluster: '//TRIM(I2S(maxpart)),Level=8) 20341 20342 WRITE(Message,'(A,F10.2)') 'Average elements in cluster:',avepart 20343 CALL Info(Caller,Message,Level=8) 20344 WRITE(Message,'(A,F10.2)') 'Average deviation in size:',devpart 20345 CALL Info(Caller,Message,Level=8) 20346 20347 ! Renumber the partitions using only the active ones 20348 n = 0 20349 DO i=1,clusters 20350 IF( NoPart(i) > 0 ) THEN 20351 n = n + 1 20352 NoPart(i) = n 20353 END IF 20354 END DO 20355 20356 ! Renumbering only needed if there are empty cells 20357 IF( n < clusters ) THEN 20358 DO i=1,nsize 20359 j = ElemPart(i) 20360 IF( j > 0 ) ElemPart(i) = NoPart(j) 20361 END DO 20362 END IF 20363 20364 !DO i=1,clusters 20365 ! PRINT *,'count in part:',i,COUNT( ElemPart(1:nsize) == i ) 20366 !END DO 20367 20368 IF( ASSOCIATED( Clustering ) ) THEN 20369 WHERE( ElemPart > 0 ) Clustering = ElemPart 20370 DEALLOCATE( ElemPart ) 20371 ELSE 20372 Clustering => ElemPart 20373 NULLIFY( ElemPart ) 20374 END IF 20375 20376 DEALLOCATE(NoPart,CellCount) 20377 20378 CALL Info(Caller,'Clustering of elements finished',Level=10) 20379 20380 END SUBROUTINE ClusterElementsUniform 20381 20382 20383 !> Find the node closest to the given coordinate. 20384 !> The linear search only makes sense for a small number of points. 20385 !> Users include saving routines of pointwise information. 20386 !----------------------------------------------------------------- 20387 FUNCTION ClosestNodeInMesh(Mesh,Coord,MinDist) RESULT ( NodeIndx ) 20388 TYPE(Mesh_t) :: Mesh 20389 REAL(KIND=dp) :: Coord(3) 20390 REAL(KIND=dp), OPTIONAL :: MinDist 20391 INTEGER :: NodeIndx 20392 20393 REAL(KIND=dp) :: Dist2,MinDist2,NodeCoord(3) 20394 INTEGER :: i 20395 20396 MinDist2 = HUGE( MinDist2 ) 20397 20398 DO i=1,Mesh % NumberOfNodes 20399 20400 NodeCoord(1) = Mesh % Nodes % x(i) 20401 NodeCoord(2) = Mesh % Nodes % y(i) 20402 NodeCoord(3) = Mesh % Nodes % z(i) 20403 20404 Dist2 = SUM( ( Coord - NodeCoord )**2 ) 20405 IF( Dist2 < MinDist2 ) THEN 20406 MinDist2 = Dist2 20407 NodeIndx = i 20408 END IF 20409 END DO 20410 20411 IF( PRESENT( MinDist ) ) MinDist = SQRT( MinDist2 ) 20412 20413 END FUNCTION ClosestNodeInMesh 20414 20415 20416 !> Find the element that owns or is closest to the given coordinate. 20417 !> The linear search only makes sense for a small number of points. 20418 !> Users include saving routines of pointwise information. 20419 !------------------------------------------------------------------- 20420 FUNCTION ClosestElementInMesh(Mesh, Coords) RESULT ( ElemIndx ) 20421 20422 TYPE(Mesh_t) :: Mesh 20423 REAL(KIND=dp) :: Coords(3) 20424 INTEGER :: ElemIndx 20425 20426 REAL(KIND=dp) :: Dist,MinDist,LocalCoords(3) 20427 TYPE(Element_t), POINTER :: Element 20428 INTEGER, POINTER :: NodeIndexes(:) 20429 TYPE(Nodes_t) :: ElementNodes 20430 INTEGER :: k,l,n,istat 20431 REAL(KIND=dp) :: ParallelHits,ParallelCands 20432 LOGICAL :: Hit 20433 20434 n = Mesh % MaxElementNodes 20435 ALLOCATE( ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n), STAT=istat) 20436 IF( istat /= 0 ) CALL Fatal('ClosestElementInMesh','Memory allocation error') 20437 ElemIndx = 0 20438 MinDist = HUGE( MinDist ) 20439 Hit = .FALSE. 20440 l = 0 20441 20442 ! Go through all bulk elements and look for hit in each element. 20443 ! Linear search makes only sense for a small number of nodes 20444 DO k=1,Mesh % NumberOfBulkElements 20445 20446 Element => Mesh % Elements(k) 20447 n = Element % TYPE % NumberOfNodes 20448 NodeIndexes => Element % NodeIndexes 20449 20450 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 20451 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 20452 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 20453 20454 Hit = PointInElement( Element, ElementNodes, & 20455 Coords, LocalCoords, LocalDistance = Dist ) 20456 IF( Dist < MinDist ) THEN 20457 MinDist = Dist 20458 l = k 20459 END IF 20460 IF( Hit ) EXIT 20461 END DO 20462 20463 ! Count the number of parallel hits 20464 !----------------------------------------------------------------------- 20465 IF( Hit ) THEN 20466 ParallelHits = 1.0_dp 20467 ELSE 20468 ParallelHits = 0.0_dp 20469 END IF 20470 ParallelHits = ParallelReduction( ParallelHits ) 20471 20472 ! If there was no proper hit go through the best candidates so far and 20473 ! see if they would give a acceptable hit 20474 !---------------------------------------------------------------------- 20475 IF( ParallelHits < 0.5_dp ) THEN 20476 20477 ! Compute the number of parallel candidates 20478 !------------------------------------------ 20479 IF( l > 0 ) THEN 20480 ParallelCands = 1.0_dp 20481 ELSE 20482 ParallelCands = 0.0_dp 20483 END IF 20484 ParallelCands = ParallelReduction( ParallelCands ) 20485 20486 IF( l > 0 ) THEN 20487 Element => Mesh % Elements(l) 20488 n = Element % TYPE % NumberOfNodes 20489 NodeIndexes => Element % NodeIndexes 20490 20491 ElementNodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 20492 ElementNodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 20493 ElementNodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 20494 20495 ! If there are more than two competing parallel hits then use more stringent conditions 20496 ! since afterwords there is no way of deciding which one was closer. 20497 !-------------------------------------------------------------------------------------- 20498 IF( ParallelCands > 1.5_dp ) THEN 20499 Hit = PointInElement( Element, ElementNodes, & 20500 Coords, LocalCoords, GlobalEps = 1.0d-3, LocalEps=1.0d-4 ) 20501 ELSE 20502 Hit = PointInElement( Element, ElementNodes, & 20503 Coords, LocalCoords, GlobalEps = 1.0_dp, LocalEps=0.1_dp ) 20504 END IF 20505 END IF 20506 END IF 20507 20508 IF( Hit ) ElemIndx = l 20509 20510 IF( ParallelHits < 0.5_dp ) THEN 20511 IF( Hit ) THEN 20512 ParallelHits = 1.0_dp 20513 ELSE 20514 ParallelHits = 0.0_dp 20515 END IF 20516 ParallelHits = ParallelReduction( ParallelHits ) 20517 IF( ParallelHits < 0.5_dp ) THEN 20518 WRITE( Message, * ) 'Coordinate not found in any of the elements!',Coords 20519 CALL Warn( 'ClosestElementInMesh', Message ) 20520 END IF 20521 END IF 20522 20523 DEALLOCATE( ElementNodes % x, ElementNodes % y, ElementNodes % z ) 20524 20525 END FUNCTION ClosestElementInMesh 20526 20527 20528 20529!--------------------------------------------------------------- 20530!> This find two fixing nodes for each coordinate direction 20531!> The indexes are returned in order: x1 x2 y1 y2 z1 z2. 20532!--------------------------------------------------------------- 20533 SUBROUTINE FindRigidBodyFixingNodes(Solver,FixingDofs,MaskPerm) 20534!------------------------------------------------------------------------------ 20535 USE GeneralUtils 20536 20537 TYPE(Solver_t) :: Solver 20538 INTEGER, OPTIONAL :: FixingDofs(0:) 20539 INTEGER, OPTIONAL :: MaskPerm(:) 20540 20541!--------------------------------------------------------------- 20542 20543 TYPE(Mesh_t), POINTER :: Mesh 20544 LOGICAL :: MaskExists,FixBestDirection,FoundBetter, GotIt 20545 INTEGER :: i,j,k,l,ind,n,dim,dir,nsize,Sweep,MaxSweep,DirBest 20546 INTEGER :: PosMeasureIndex, NegMeasureIndex, FixingNodes(0:6) 20547 LOGICAL, ALLOCATABLE :: ForbiddenNodes(:) 20548 REAL(KIND=dp), POINTER :: Parray(:,:) 20549 REAL(KIND=dp) :: Normal(3), Tangent1(3), Tangent2(3), Coord(3), & 20550 SumCoord(3), AveCoord(3), Weights(3), RefScore, Score, & 20551 PosMeasure, NegMeasure, OffLineCoeff, DirDistance, & 20552 InLine, OffLine, Dist, MinDist, InLineMeasure, ScoreLimit 20553 CHARACTER(LEN=MAX_NAME_LEN) :: Method 20554!--------------------------------------------------------------- 20555 20556 CALL Info('FindRigidBodyFixingNodes','Starting',Level=6) 20557 20558 Mesh => Solver % Mesh 20559 dim = Mesh % MeshDim 20560 20561 ALLOCATE( ForbiddenNodes(Mesh % NumberOfNodes) ) 20562 CALL DetermineForbiddenNodes( ) 20563 nsize = COUNT(.NOT. ForbiddenNodes) 20564 20565! PRINT *,'Number of allowed Nodes:',nsize 20566 20567 ! Find the center from the average of node positions 20568 !----------------------------------------------------------- 20569 SumCoord = 0.0_dp 20570 DO i=1,Mesh % NumberOfNodes 20571 IF( ForbiddenNodes( i ) ) CYCLE 20572 20573 Coord(1) = Mesh % Nodes % x(i) 20574 Coord(2) = Mesh % Nodes % y(i) 20575 Coord(3) = Mesh % Nodes % z(i) 20576 20577 SumCoord = SumCoord + Coord 20578 END DO 20579 AveCoord = SumCoord / nsize 20580 20581 20582 ! Find the node closest to center and make that the new center 20583 !-------------------------------------------------------------- 20584 MinDist = HUGE( MinDist ) 20585 20586 DO i=1,Mesh % NumberOfNodes 20587 IF( ForbiddenNodes( i ) ) CYCLE 20588 20589 Coord(1) = Mesh % Nodes % x(i) 20590 Coord(2) = Mesh % Nodes % y(i) 20591 Coord(3) = Mesh % Nodes % z(i) 20592 20593 Dist = SUM( ( Coord - AveCoord )**2 ) 20594 IF( Dist < MinDist ) THEN 20595 MinDist = Dist 20596 k = i 20597 END IF 20598 END DO 20599 20600 AveCoord(1) = Mesh % Nodes % x(k) 20601 AveCoord(2) = Mesh % Nodes % y(k) 20602 AveCoord(3) = Mesh % Nodes % z(k) 20603 IF(PRESENT(FixingDOFs)) FixingDOFs(0)=k 20604 20605 20606! PRINT *,'AveCoord:',AveCoord 20607 20608 ! Parameters of the search 20609 !----------------------------------------------------------- 20610 20611 OffLineCoeff = ListGetConstReal( Solver % Values,'Fixing Nodes Off Line Coefficient',GotIt) 20612 IF(.NOT. GotIt) OffLineCoeff = 1.0_dp 20613 20614 ScoreLimit = ListGetConstReal( Solver % Values,'Fixing Nodes Limit Score',GotIt) 20615 IF(.NOT. GotIt) ScoreLimit = 0.99_dp 20616 20617 FixBestDirection = ListGetLogical( Solver % Values,'Fixing Nodes Axis Freeze',GotIt) 20618 20619 Parray => ListGetConstRealArray( Solver % Values,'Fixing Nodes Normal Vector',GotIt ) 20620 IF( GotIt ) THEN 20621 Normal = Parray(1:3,1) 20622 ELSE 20623 Normal = 0.0_dp 20624 Normal(1) = 1.0 20625 END IF 20626 Normal = Normal / SQRT( SUM( Normal ** 2) ) 20627 CALL TangentDirections( Normal,Tangent1,Tangent2 ) 20628 20629 ! Find the fixing nodes by looping over all nodes 20630 !----------------------------------------------------------- 20631 DirDistance = 0.0_dp 20632 DirBest = 0 20633 DO dir = 1, dim 20634 20635 ! Use the three principal directions as the weight 20636 !------------------------------------------------- 20637 IF( dir == 1 ) THEN 20638 Weights = Normal 20639 ELSE IF( dir == 2 ) THEN 20640 Weights = Tangent1 20641 ELSE 20642 Weights = Tangent2 20643 END IF 20644 20645 PosMeasure = 0.0_dp 20646 PosMeasureIndex = 0 20647 NegMeasure = 0.0_dp 20648 NegMeasureIndex = 0 20649 20650 20651 ! Choose the nodes within the cones in the given three directions 20652 !--------------------------------------------------------------- 20653 DO i=1,Mesh % NumberOfNodes 20654 IF( ForbiddenNodes( i ) ) CYCLE 20655 20656 Coord(1) = Mesh % Nodes % x(i) 20657 Coord(2) = Mesh % Nodes % y(i) 20658 Coord(3) = Mesh % Nodes % z(i) 20659 20660 Coord = Coord - AveCoord 20661 Dist = SQRT( SUM( Coord ** 2 ) ) 20662 20663 ! Signed distance in in-line direction 20664 InLine = SUM( Coord * Weights ) 20665 20666 ! Distance in off-line direction 20667 OffLine = SQRT( Dist**2 - InLine**2 ) 20668 20669 ! This defines a cone within which nodes are accepted 20670 InLineMeasure = ABS( InLine ) - OffLineCoeff * OffLine 20671 IF( InLineMeasure < 0.0_dp ) CYCLE 20672 20673 IF( InLine < 0.0_dp ) THEN 20674 IF( InLineMeasure > NegMeasure ) THEN 20675 NegMeasure = InLineMeasure 20676 NegMeasureIndex = i 20677 END IF 20678 ELSE 20679 IF( InLineMeasure > PosMeasure ) THEN 20680 PosMeasure = InLineMeasure 20681 PosMeasureIndex = i 20682 END IF 20683 END IF 20684 END DO 20685 20686 FixingNodes(2*dir-1) = NegMeasureIndex 20687 FixingNodes(2*dir) = PosMeasureIndex 20688 20689 IF( NegMeasureIndex > 0 .AND. PosMeasureIndex > 0 ) THEN 20690 IF( PosMeasure + NegMeasure > DirDistance ) THEN 20691 DirDistance = PosMeasure + NegMeasure 20692 DirBest = dir 20693 END IF 20694 END IF 20695 20696 END DO 20697 20698 20699 20700 ! To be on the safe side check that no node is used twice 20701 ! However, do not break the best direction 20702 !----------------------------------------------------------------------------------- 20703 DO i=1,2*dim 20704 DO j=1,2*dim 20705 IF( FixBestDirection ) THEN 20706 IF( j == 2*DirBest-1 .OR. j == 2*DirBest ) CYCLE 20707 END IF 20708 IF( FixingNodes(j) == FixingNodes(i) ) FixingNodes(j) = 0 20709 END DO 20710 END DO 20711 20712 20713 ! Go through the fixing nodes one-by-one and set the node so that the harmonic sum 20714 ! is minimized. This means that small distances are hopefully eliminated. 20715 !----------------------------------------------------------------------------------- 20716 MaxSweep = ListGetInteger( Solver % Values,'Fixing Nodes Search Loops',GotIt) 20717 DO Sweep = 0,MaxSweep 20718 FoundBetter = .FALSE. 20719 DO j=1,2*dim 20720 RefScore = FixingNodesScore(j,FixingNodes(j)) 20721 20722 ! The first round set the unfixed nodes 20723 IF( Sweep == 0 ) THEN 20724! PRINT *,'Initial Score:',j,RefScore 20725 IF( FixingNodes(j) /= 0 ) CYCLE 20726 END IF 20727 20728 ! Fir the best direction because otherwise there are too 20729 ! many moving parts. 20730 IF( FixBestDirection ) THEN 20731 IF( j == 2*DirBest-1 .OR. j == 2*DirBest ) CYCLE 20732 END IF 20733 20734 RefScore = FixingNodesScore(j,FixingNodes(j)) 20735 20736 DO i=1,Mesh % NumberOfNodes 20737 IF( ForbiddenNodes(i) ) CYCLE 20738 Score = FixingNodesScore(j,i) 20739 IF( Score < ScoreLimit * RefScore ) THEN 20740 RefScore = Score 20741 FixingNodes(j) = i 20742 FoundBetter = .TRUE. 20743 END IF 20744 END DO 20745 END DO 20746 IF(.NOT. FoundBetter ) EXIT 20747 END DO 20748 20749 DO j=1,2*dim 20750 RefScore = FixingNodesScore(j,FixingNodes(j)) 20751! PRINT *,'Final Score:',j,RefScore 20752 END DO 20753 20754 ! Output the selected nodes 20755 !----------------------------------------------------------------------------------- 20756 DO i=1,2*dim 20757 j = FixingNodes(i) 20758 WRITE(Message,'(A,I0,3ES10.2)') 'Fixing Node: ',j,& 20759 Mesh % Nodes % x( j ), & 20760 Mesh % Nodes % y( j ), & 20761 Mesh % Nodes % z( j ) 20762 CALL Info('FindRigidBodyFixingNodes',Message,Level=6) 20763 IF( PRESENT( FixingDofs ) ) FixingDofs(i) = j 20764 END DO 20765 20766 DEALLOCATE( ForbiddenNodes ) 20767 20768 20769 CONTAINS 20770 20771 !> Find the nodes that are either on interface, boundary or do not belong to the field. 20772 !----------------------------------------------------------------------------------- 20773 SUBROUTINE DetermineForbiddenNodes() 20774 20775 TYPE(Element_t), POINTER :: Element 20776 LOGICAL, POINTER :: ig(:) 20777 INTEGER :: t 20778 20779 ! Mark all interface nodes as forbidden nodes 20780 !----------------------------------------------- 20781 IF( ParEnv % PEs > 1 ) THEN 20782 ig => Mesh % ParallelInfo % INTERFACE 20783 ForbiddenNodes = ig(1:Mesh % NumberOfNodes) 20784 END IF 20785 20786 ! Mark all nodes on boundary elements as forbidden nodes 20787 !-------------------------------------------------------- 20788 DO t=Mesh % NumberOfBulkElements + 1, & 20789 Mesh % NumberOfBoundaryElements + Mesh % NumberOfBulkElements 20790 20791 Element => Mesh % Elements( t ) 20792 ForbiddenNodes( Element % NodeIndexes ) = .TRUE. 20793 END DO 20794 20795 ! If mask exists then add all nodes not in mask to forbidden nodes 20796 !----------------------------------------------------------------- 20797 IF( PRESENT( MaskPerm) ) THEN 20798 DO i=1,Mesh % NumberOfNodes 20799 IF( MaskPerm(i) == 0 ) ForbiddenNodes(i) = .TRUE. 20800 END DO 20801 END IF 20802 20803 END SUBROUTINE DetermineForbiddenNodes 20804 20805 20806 !> Give a value of goodness to the chosen fixing node. 20807 !----------------------------------------------------------------------------------- 20808 FUNCTION FixingNodesScore(direction,cand) RESULT ( Score ) 20809 20810 INTEGER :: direction, cand 20811 INTEGER :: i,j 20812 REAL(KIND=dp) :: Score 20813 20814 REAL(KIND=dp) :: x0(3), x1(3), Dist 20815 20816 IF( cand == 0 ) THEN 20817 Score = HUGE( Score ) 20818 RETURN 20819 END IF 20820 20821 Score = 0.0_dp 20822 x0(1) = Mesh % Nodes % x( cand ) 20823 x0(2) = Mesh % Nodes % y( cand ) 20824 x0(3) = Mesh % Nodes % z( cand ) 20825 20826 DO i=1,2*dim 20827 IF( i == direction ) CYCLE 20828 j = FixingNodes( i ) 20829 20830 ! Do not measure distance to unset nodes! 20831 IF( j == 0 ) CYCLE 20832 20833 ! This would lead to division by zero later on 20834 IF( cand == j ) THEN 20835 Score = HUGE( Score ) 20836 RETURN 20837 END IF 20838 20839 x1(1) = Mesh % Nodes % x( j ) 20840 x1(2) = Mesh % Nodes % y( j ) 20841 x1(3) = Mesh % Nodes % z( j ) 20842 20843 Dist = SQRT( SUM( (x0 - x1 ) ** 2 ) ) 20844 Score = Score + 1 / Dist 20845 END DO 20846 20847 END FUNCTION FixingNodesScore 20848 20849 20850!------------------------------------------------------------------------------ 20851 END SUBROUTINE FindRigidBodyFixingNodes 20852!------------------------------------------------------------------------------ 20853 20854 20855!------------------------------------------------------------------------------ 20856!> Create a 1D mesh, may be used in 1D outlet conditions, for example. 20857!------------------------------------------------------------------------------ 20858 FUNCTION CreateLineMesh( Params ) RESULT( Mesh ) 20859!------------------------------------------------------------------------------ 20860 TYPE(ValueList_t), POINTER :: Params 20861 TYPE(Mesh_t), POINTER :: Mesh 20862!------------------------------------------------------------------------------ 20863 REAL(KIND=dp), POINTER :: x(:),y(:),z(:) 20864 INTEGER :: i, j, k, n, NoNodes, NoElements, ActiveDirection, Order, BodyId, ne 20865 LOGICAL :: Found 20866 TYPE(Element_t), POINTER :: Element 20867 TYPE(ElementType_t),POINTER :: elmt 20868 REAL(KIND=dp) :: MeshVector(3), Length, Coord(3) 20869 CHARACTER(LEN=MAX_NAME_LEN) :: MeshName 20870 REAL(KIND=dp), ALLOCATABLE :: w(:) 20871 20872!------------------------------------------------------------------------------ 20873 Mesh => NULL() 20874 IF ( .NOT. ASSOCIATED( Params ) ) RETURN 20875 Mesh => AllocateMesh() 20876 20877 CALL Info('CreateLineMesh','Creating 1D mesh on-the-fly') 20878 20879! Read in the parameters defining a uniform 1D mesh 20880!-------------------------------------------------------------- 20881 Order = ListGetInteger( Params,'1D Element Order',Found,minv=1,maxv=2) 20882 NoElements = ListGetInteger( Params,'1D Number Of Elements',minv=1) 20883 Length = ListGetConstReal( Params,'1D Mesh Length',Found) 20884 IF(.NOT. Found) Length = 1.0_dp 20885 ActiveDirection = ListGetInteger( Params,'1D Active Direction',Found,minv=-3,maxv=3) 20886 IF(.NOT.Found) ActiveDirection = 1 20887 BodyId = ListGetInteger( Params,'1D Body Id',Found,minv=1) 20888 IF(.NOT. Found) BodyId = 1 20889 MeshName = ListGetString( Params,'1D Mesh Name',Found) 20890 IF(.NOT. Found) MeshName = '1d_mesh' 20891 20892 Mesh % Name = MeshName 20893 Mesh % OutputActive = .FALSE. 20894 20895! Compute the resulting mesh parameters 20896!-------------------------------------------------------------- 20897 ne = Order + 1 20898 NoNodes = NoElements + 1 + NoElements * (Order - 1) 20899 MeshVector = 0.0_dp 20900 MeshVector( ABS( ActiveDirection ) ) = 1.0_dp 20901 IF( ActiveDirection < 0 ) MeshVector = -MeshVector 20902 MeshVector = MeshVector * Length 20903 20904! Define nodal coordinates 20905! ------------------------------- 20906 CALL AllocateVector( Mesh % Nodes % x, NoNodes ) 20907 CALL AllocateVector( Mesh % Nodes % y, NoNodes ) 20908 CALL AllocateVector( Mesh % Nodes % z, NoNodes ) 20909 20910 x => Mesh % Nodes % x 20911 y => Mesh % Nodes % y 20912 z => Mesh % Nodes % z 20913 20914 ALLOCATE( w(0:NoNodes-1) ) 20915 20916 CALL UnitSegmentDivision( w, NoNodes-1, Params ) 20917 20918 DO i=1, NoNodes 20919 Coord = MeshVector * w(i-1) 20920 20921 x(i) = Coord(1) 20922 y(i) = Coord(2) 20923 z(i) = Coord(3) 20924 END DO 20925 20926 20927! Define elements 20928! ------------------------------- 20929 CALL AllocateVector( Mesh % Elements, NoElements ) 20930 20931 Elmt => GetElementType( 200 + ne ) 20932 20933 DO i=1,NoElements 20934 Element => Mesh % Elements(i) 20935 Element % TYPE => Elmt 20936 Element % EdgeIndexes => NULL() 20937 Element % FaceIndexes => NULL() 20938 Element % ElementIndex = i 20939 20940 CALL AllocateVector( Element % NodeIndexes, ne ) 20941 Element % Ndofs = ne 20942 20943 Element % NodeIndexes(1) = (i-1)*Order + 1 20944 Element % NodeIndexes(2) = i*Order + 1 20945 20946 DO j=3,ne 20947 Element % NodeIndexes(j) = (i-1)*Order + j-1 20948 END DO 20949 20950 Element % BodyId = BodyId 20951 Element % PartIndex = ParEnv % myPE 20952 END DO 20953 20954! Update new mesh node count: 20955! --------------------------- 20956 20957 Mesh % NumberOfNodes = NoNodes 20958 Mesh % Nodes % NumberOfNodes = NoNodes 20959 Mesh % NumberOfBulkElements = NoElements 20960 Mesh % MaxElementNodes = ne 20961 Mesh % MaxElementDOFs = ne 20962 Mesh % MeshDim = 1 20963 20964 WRITE(Message,'(A,I0)') 'Number of elements created: ',NoElements 20965 CALL Info('CreateLineMesh',Message) 20966 20967 WRITE(Message,'(A,I0)') 'Number of nodes created: ',NoNodes 20968 CALL Info('CreateLineMesh',Message) 20969 20970 CALL Info('CreateLineMesh','All done') 20971 20972 END FUNCTION CreateLineMesh 20973 20974 !Creates a regular 2D mesh of 404 elements 20975 !The resulting mesh has no boundary elements etc for now 20976 !Should only be used for e.g. mesh to mesh interpolation 20977 FUNCTION CreateRectangularMesh(Params) RESULT(Mesh) 20978 20979!------------------------------------------------------------------------------ 20980 TYPE(ValueList_t), POINTER :: Params 20981 TYPE(Mesh_t), POINTER :: Mesh 20982!------------------------------------------------------------------------------ 20983 REAL(KIND=dp), POINTER :: x(:),y(:),z(:) 20984 REAL(KIND=dp) :: min_x, max_x, min_y, max_y, dx, dy 20985 INTEGER :: i, j, k, n, counter, nnx, nny, nex, ney, & 20986 NoNodes, NoElements, col, row 20987 LOGICAL :: Found 20988 TYPE(Element_t), POINTER :: Element 20989 TYPE(ElementType_t),POINTER :: elmt 20990 REAL(KIND=dp) :: MeshVector(3), Length, Coord(3) 20991 CHARACTER(LEN=MAX_NAME_LEN) :: MeshName, FuncName="CreateRectangularMesh" 20992 20993!------------------------------------------------------------------------------ 20994 Mesh => NULL() 20995 IF ( .NOT. ASSOCIATED( Params ) ) RETURN 20996 Mesh => AllocateMesh() 20997 20998 CALL Info(FuncName,'Creating 2D mesh on-the-fly') 20999 21000 !Get parameters from valuelist 21001 min_x = ListGetConstReal(Params, "Grid Mesh Min X",UnfoundFatal=.TRUE.) 21002 max_x = ListGetConstReal(Params, "Grid Mesh Max X",UnfoundFatal=.TRUE.) 21003 min_y = ListGetConstReal(Params, "Grid Mesh Min Y",UnfoundFatal=.TRUE.) 21004 max_y = ListGetConstReal(Params, "Grid Mesh Max Y",UnfoundFatal=.TRUE.) 21005 dx = ListGetConstReal(Params, "Grid Mesh dx",UnfoundFatal=.TRUE.) 21006 dy = ListGetConstReal(Params, "Grid Mesh dy",Found) 21007 IF(.NOT. Found) dy = dx 21008 21009 IF(max_x <= min_x .OR. max_y <= min_y .OR. dx <= 0.0_dp .OR. dy <= 0.0_dp) & 21010 CALL Fatal(FuncName, "Bad Grid Mesh parameters!") 21011 21012 !number of nodes in x and y direction (and total) 21013 nnx = FLOOR((max_x - min_x) / dx) + 1 21014 nny = FLOOR((max_y - min_y) / dy) + 1 21015 NoNodes = nnx * nny 21016 21017 !number of elements in x and y direction (and total) 21018 nex = nnx - 1 21019 ney = nny - 1 21020 NoElements = nex * ney 21021 21022 21023! Define nodal coordinates 21024! ------------------------------- 21025 CALL AllocateVector( Mesh % Nodes % x, NoNodes ) 21026 CALL AllocateVector( Mesh % Nodes % y, NoNodes ) 21027 CALL AllocateVector( Mesh % Nodes % z, NoNodes ) 21028 x => Mesh % Nodes % x 21029 y => Mesh % Nodes % y 21030 z => Mesh % Nodes % z 21031 21032 z = 0.0_dp !2D 21033 21034 !Define node positions 21035 counter = 0 21036 DO i=1,nnx 21037 DO j=1,nny 21038 counter = counter + 1 21039 x(counter) = min_x + (i-1)*dx 21040 y(counter) = min_y + (j-1)*dy 21041 END DO 21042 END DO 21043 21044! Define elements 21045! ------------------------------- 21046 CALL AllocateVector( Mesh % Elements, NoElements ) 21047 21048 Elmt => GetElementType( 404 ) 21049 21050 DO i=1,NoElements 21051 Element => Mesh % Elements(i) 21052 Element % TYPE => Elmt 21053 Element % EdgeIndexes => NULL() 21054 Element % FaceIndexes => NULL() 21055 Element % ElementIndex = i 21056 CALL AllocateVector( Element % NodeIndexes, 4 ) 21057 Element % Ndofs = 4 21058 21059 col = MOD(i-1,ney) 21060 row = (i-1)/ney 21061 21062 !THIS HERE NEEDS FIXED!!!!! 21063 Element % NodeIndexes(1) = (row * nny) + col + 1 21064 Element % NodeIndexes(2) = (row * nny) + col + 2 21065 Element % NodeIndexes(4) = ((row+1) * nny) + col + 1 21066 Element % NodeIndexes(3) = ((row+1) * nny) + col + 2 21067 21068 Element % BodyId = 1 21069 Element % PartIndex = ParEnv % myPE 21070 END DO 21071 21072! Update new mesh node count: 21073! --------------------------- 21074 21075 Mesh % NumberOfNodes = NoNodes 21076 Mesh % Nodes % NumberOfNodes = NoNodes 21077 Mesh % NumberOfBulkElements = NoElements 21078 Mesh % MaxElementNodes = 4 21079 Mesh % MaxElementDOFs = 4 21080 Mesh % MeshDim = 2 21081 21082 END FUNCTION CreateRectangularMesh 21083 21084 SUBROUTINE ElmerMeshToDualGraph(Mesh, DualGraph, UseBoundaryMesh) 21085 IMPLICIT NONE 21086 21087 TYPE(Mesh_t) :: Mesh 21088 TYPE(Graph_t) :: DualGraph 21089 LOGICAL, OPTIONAL :: UseBoundaryMesh 21090 21091 TYPE(Element_t), POINTER :: Element, Elements(:) 21092 21093 ! MESH DATA 21094 ! Mesh (CRS format) 21095 INTEGER, ALLOCATABLE :: eptr(:), eind(:) 21096 INTEGER :: nelem 21097 ! Vertex to element map (CRS format) 21098 INTEGER, ALLOCATABLE :: vptr(:), vind(:) 21099 INTEGER :: nvertex 21100 21101 ! WORK ARRAYS 21102 ! Pointers to vertex-element maps of the current element 21103 INTEGER, ALLOCATABLE :: ptrli(:), ptrti(:) 21104 ! Neighbour indices 21105 INTEGER, ALLOCATABLE :: neighind(:) 21106 ! ARRAY MERGE: map for merge 21107 INTEGER, ALLOCATABLE :: wrkmap(:) 21108 21109 TYPE :: IntTuple_t 21110 INTEGER :: i1, i2 21111 END type IntTuple_t 21112 21113 TYPE(IntTuple_t), ALLOCATABLE :: wrkheap(:) 21114 21115 ! OpenMP thread block leads for work division 21116 INTEGER, ALLOCATABLE :: thrblk(:) 21117 ! Work indices 21118 INTEGER, ALLOCATABLE :: wrkind(:), wrkindresize(:) 21119 INTEGER :: nwrkind 21120 21121 ! Variables 21122 INTEGER :: i, dnnz, eid, nl, nli, nti, nn, nv, nthr, & 21123 te, thrli, thrti, vli, vti, TID, allocstat 21124 INTEGER :: mapSizePad, maxNodesPad, neighSizePad 21125 LOGICAL :: Boundary 21126 21127 INTEGER, PARAMETER :: HEAPALG_THRESHOLD = 24 21128 21129 CALL Info('ElmerMeshToDualGraph','Creating a dual graph for the mesh',Level=8) 21130 21131 Boundary = .FALSE. 21132 IF (Present(UseBoundaryMesh)) Boundary = UseBoundaryMesh 21133 21134 ! Pointers to mesh data 21135 IF (.NOT. Boundary) THEN 21136 nelem = Mesh % NumberOfBulkElements 21137 nvertex = Mesh % NumberOfNodes 21138 Elements => Mesh % Elements 21139 ELSE 21140 nelem = Mesh % NumberOfBoundaryElements 21141 nvertex = Mesh % NumberOfNodes 21142 Elements => Mesh % Elements(& 21143 Mesh % NumberOfBulkElements+1:Mesh % NumberOfBulkElements+nelem) 21144 END IF 21145 21146 ! Initialize dual mesh size and number of nonzeroes 21147 DualGraph % n = nelem 21148 dnnz = 0 21149 21150 ! Copy mesh to CRS structure 21151 ALLOCATE(eptr(nelem+1), eind(nelem*Mesh % MaxElementNodes), STAT=allocstat) 21152 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21153 'Unable to allocate mesh structure!') 21154 21155 eptr(1)=1 ! Fortran numbering 21156 DO i=1, nelem 21157 Element => Elements(i) 21158 nl = Element % TYPE % NumberOfNodes 21159 nli = eptr(i) ! Fortran numbering 21160 nti = nli+nl-1 21161 eind(nli:nti) = Element % NodeIndexes(1:nl) ! Fortran numbering 21162 eptr(i+1) = nli+nl 21163 END DO 21164 21165 ! Construct vertex to element list (in serial!) 21166 CALL VertexToElementList(nelem, nvertex, eptr, eind, vptr, vind) 21167 21168 ! Allocate pointers to dual mesh 21169 ALLOCATE(DualGraph % ptr(nelem+1), STAT=allocstat) 21170 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21171 'Unable to allocate dual mesh!') 21172 21173 ! Divide work by number of rows in the vertex graph 21174 nthr = 1 21175 !$ nthr = omp_get_max_threads() 21176 21177 ! Load balance the actual work done by threads (slow) 21178 ! CALL ThreadLoadBalanceElementNeighbour(nthr, nelem, eptr, eind, vptr, thrblk) 21179 CALL ThreadStaticWorkShare(nthr, nelem, thrblk) 21180 21181 !$OMP PARALLEL SHARED(nelem, nvertex, eptr, eind, & 21182 !$OMP vptr, vind, Mesh, DualGraph, & 21183 !$OMP nthr, thrblk, dnnz) & 21184 !$OMP PRIVATE(i, eid, nli, nti, nn, nv, vli, vti, te, & 21185 !$OMP maxNodesPad, neighSizePad, ptrli, ptrti, & 21186 !$OMP wrkheap, wrkmap, neighind, & 21187 !$OMP wrkind, nwrkind, wrkindresize, allocstat, & 21188 !$OMP mapSizePad, thrli, thrti, TID) NUM_THREADS(nthr) & 21189 !$OMP DEFAULT(NONE) 21190 21191 TID = 1 21192 !$ TID = OMP_GET_THREAD_NUM()+1 21193 21194 ! Ensure that the vertex to element lists are sorted 21195 !$OMP DO 21196 DO i=1,nvertex 21197 vli = vptr(i) 21198 vti = vptr(i+1)-1 21199 21200 CALL Sort(vti-vli+1, vind(vli:vti)) 21201 END DO 21202 !$OMP END DO NOWAIT 21203 21204 ! Allocate work array (local to each thread) 21205 maxNodesPad = IntegerNBytePad(Mesh % MaxElementNodes, 8) 21206 neighSizePad = IntegerNBytePad(Mesh % MaxElementNodes*20, 8) 21207 21208 ! Pointers to vertex maps 21209 ALLOCATE(neighind(neighSizePad), & 21210 ptrli(maxNodesPad), ptrti(maxNodesPad), STAT=allocstat) 21211 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21212 'Unable to allocate local workspace!') 21213 ! Initialize neighbour indices 21214 neighind = 0 21215 21216 IF (nthr >= HEAPALG_THRESHOLD) THEN 21217 ! With multiple threads, use heap based merge 21218 ALLOCATE(wrkheap(maxNodesPad), STAT=allocstat) 21219 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21220 'Unable to allocate local workspace!') 21221 ELSE 21222 ! With a small number of threads, use map -based merge 21223 mapSizePad = IntegerNBytePad(nelem, 8) 21224 ALLOCATE(wrkmap(mapSizePad), STAT=allocstat) 21225 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21226 'Unable to allocate local workspace!') 21227 ! Initialize local map 21228 wrkmap=0 21229 END IF 21230 21231 ! Allocate local list for results 21232 nwrkind = 0 21233 ALLOCATE(wrkind(nelem/nthr*20), STAT=allocstat) 21234 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21235 'Unable to allocate local workspace!') 21236 21237 ! Ensure that all the threads have finished sorting the vertex indices 21238 !$OMP BARRIER 21239 21240 ! Get thread indices 21241 thrli = thrblk(TID) 21242 thrti = thrblk(TID+1) 21243 21244 ! For each element 21245 DO eid=thrli,thrti-1 21246 nli = eptr(eid) 21247 nti = eptr(eid+1)-1 21248 nv = nti-nli+1 21249 21250 ! Get pointers to vertices related to the nodes of the element 21251 te = 0 21252 DO i=nli,nti 21253 ptrli(i-nli+1)=vptr(eind(i)) 21254 ptrti(i-nli+1)=vptr(eind(i)+1) ! NOTE: This is to make comparison cheaper 21255 te = te + ptrti(i-nli+1)-ptrli(i-nli+1) 21256 END DO 21257 21258 ! Allocate neighind large enough 21259 IF (SIZE(neighind)<te) THEN 21260 DEALLOCATE(neighind) 21261 neighSizePad = IntegerNBytePad(te,8) 21262 ALLOCATE(neighind(neighSizePad), STAT=allocstat) 21263 neighind = 0 21264 END IF 21265 21266 ! Merge vertex lists (multi-way merge of ordered lists) 21267 IF (nthr >= HEAPALG_THRESHOLD) THEN 21268 CALL kWayMergeHeap(eid, nv, ptrli, ptrti, & 21269 te, vind, nn, neighind, wrkheap) 21270 ELSE 21271 CALL kWayMergeArray(eid, nv, ptrli, ptrti, & 21272 te, vind, nn, neighind, wrkmap) 21273 END IF 21274 21275 ! Add merged list to final list of vertices 21276 IF (nn+nwrkind>SIZE(wrkind)) THEN 21277 ALLOCATE(wrkindresize(MAX(nn+nwrkind,2*SIZE(wrkind))), STAT=allocstat) 21278 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21279 'Unable to allocate local workspace!') 21280 wrkindresize(1:nwrkind)=wrkind(1:nwrkind) 21281 DEALLOCATE(wrkind) 21282 CALL MOVE_ALLOC(wrkindresize, wrkind) 21283 END IF 21284 wrkind(nwrkind+1:nwrkind+nn) = neighind(1:nn) 21285 nwrkind = nwrkind + nn 21286 21287 ! Store number of row nonzeroes 21288 DualGraph % ptr(eid)=nn 21289 END DO 21290 21291 ! Get the global size of the dual mesh 21292 !$OMP DO REDUCTION(+:dnnz) 21293 DO i=1,nthr 21294 dnnz = nwrkind 21295 END DO 21296 !$OMP END DO 21297 21298 ! Allocate memory for dual mesh indices 21299 !$OMP SINGLE 21300 ALLOCATE(DualGraph % ind(dnnz), STAT=allocstat) 21301 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21302 'Unable to allocate dual mesh!') 21303 ! ptr stores row counts, build crs pointers from them 21304 CALL ComputeCRSIndexes(nelem, DualGraph % ptr) 21305 !$OMP END SINGLE 21306 21307 DualGraph % ind(& 21308 DualGraph % ptr(thrli):DualGraph % ptr(thrti)-1)=wrkind(1:nwrkind) 21309 21310 IF (nthr >= HEAPALG_THRESHOLD) THEN 21311 DEALLOCATE(wrkheap, STAT=allocstat) 21312 ELSE 21313 DEALLOCATE(wrkmap, STAT=allocstat) 21314 END IF 21315 IF (allocstat /= 0) CALL Fatal('ElmerMeshToDualGraph', & 21316 'Unable to deallocate local workspace!') 21317 DEALLOCATE(neighind, ptrli, ptrti, wrkind) 21318 21319 !$OMP END PARALLEL 21320 21321 ! Deallocate the rest of memory 21322 DEALLOCATE(eind, eptr, vptr, vind, thrblk) 21323 21324 CALL Info('ElmerMeshToDualGraph','Dual graph created with size '//TRIM(I2S(dnnz)),Level=8) 21325 21326 21327 CONTAINS 21328 21329 SUBROUTINE VertexToElementList(nelem, nvertex, eptr, eind, vptr, vind) 21330 IMPLICIT NONE 21331 21332 INTEGER, INTENT(IN) :: nelem, nvertex 21333 INTEGER :: eptr(:), eind(:) 21334 INTEGER, ALLOCATABLE :: vptr(:), vind(:) 21335 21336 INTEGER :: i, j, v, eli, eti, ind, tmpi, tmpip, allocstat 21337 21338 ! Initialize vertex structure (enough storage for nvertex vertices 21339 ! having eptr(nelem+1) elements) 21340 ALLOCATE(vptr(nvertex+1), STAT=allocstat) 21341 IF (allocstat /= 0) CALL Fatal('VertexToElementList', & 21342 'Vertex allocation failed!') 21343 vptr = 0 21344 21345 ! For each element 21346 21347 ! Compute number of elements attached to each vertex (size of lists) 21348 DO i=1,nelem 21349 eli = eptr(i) 21350 eti = eptr(i+1)-1 21351 21352 DO j=eli, eti 21353 vptr(eind(j))=vptr(eind(j))+1 21354 END DO 21355 END DO 21356 21357 ! Compute in-place cumulative sum (row pointers!) 21358 CALL ComputeCRSIndexes(nvertex, vptr) 21359 21360 ! Allocate vertex to element lists 21361 ALLOCATE(vind(vptr(nvertex+1)), STAT=allocstat) 21362 IF (allocstat /= 0) CALL Fatal('VertexToElementList', & 21363 'Vertex allocation failed!') 21364 21365 ! Construct element lists for each vertex 21366 DO i=1,nelem 21367 eli = eptr(i) 21368 eti = eptr(i+1)-1 21369 21370 ! For each vertex in element 21371 DO j=eli, eti 21372 ! Add connection to vertex eind(j) 21373 ind = eind(j) 21374 vind(vptr(ind))=i 21375 vptr(ind)=vptr(ind)+1 21376 END DO 21377 END DO 21378 21379 ! Correct row pointers 21380 DO i=nvertex,2,-1 21381 vptr(i)=vptr(i-1) 21382 END DO 21383 vptr(1)=1 21384 END SUBROUTINE VertexToElementList 21385 21386 ! k-way merge with an array 21387 SUBROUTINE kWayMergeArray(node, nv, ptrli, ptrti, te, vind, & 21388 nn, neighind, map) 21389 IMPLICIT NONE 21390 21391 INTEGER, INTENT(IN) :: node, nv 21392 INTEGER :: ptrli(:) 21393 INTEGER, INTENT(IN) ::ptrti(:), te 21394 INTEGER, INTENT(IN) :: vind(:) 21395 INTEGER, INTENT(OUT) :: nn 21396 INTEGER :: neighind(:) 21397 INTEGER :: map(:) 21398 21399 INTEGER :: i, j, k, vindi 21400 21401 ! Merge nv lists using a map (i.e. an array) 21402 nn = 1 21403 DO i=1,nv 21404 DO j=ptrli(i), ptrti(i)-1 21405 vindi = vind(j) 21406 ! Put element to map if it is not already there 21407 IF (map(vindi)==0 .AND. vindi /= node) THEN 21408 neighind(nn)=vindi 21409 ! Increase counter 21410 map(vindi)=1 21411 nn=nn+1 21412 END IF 21413 END DO 21414 END DO 21415 nn=nn-1 21416 21417 ! Clear map 21418 DO i=1,nn 21419 map(neighind(i)) = 0 21420 END DO 21421 END SUBROUTINE kWayMergeArray 21422 21423 ! k-way merge with an actual heap 21424 SUBROUTINE kWayMergeHeap(node, nv, ptrli, ptrti, te, vind, & 21425 nn, neighind, heap) 21426 IMPLICIT NONE 21427 21428 INTEGER, INTENT(IN) :: node, nv 21429 INTEGER :: ptrli(:) 21430 INTEGER, INTENT(IN) ::ptrti(:), te 21431 INTEGER, INTENT(IN) :: vind(:) 21432 INTEGER, INTENT(OUT) :: nn 21433 INTEGER :: neighind(:) 21434 TYPE(IntTuple_t) :: heap(:) 21435 21436 TYPE(IntTuple_t) :: tmp 21437 INTEGER :: ii, l, r, mind, ll, tmpval, tmpind 21438 21439 ! Local variables 21440 INTEGER :: i, e, nzheap, vindi, lindi, pind 21441 21442 ! Put elements to heap 21443 nzheap = 0 21444 DO i=1,nv 21445 IF (ptrli(i)<ptrti(i)) THEN 21446 heap(i) % i1 = vind(ptrli(i)) 21447 heap(i) % i2= i 21448 ptrli(i) = ptrli(i)+1 21449 nzheap = nzheap+1 21450 END IF 21451 END DO 21452 21453 ! Build heap 21454 DO ii=(nzheap/2), 1, -1 21455 i = ii 21456 ! CALL BinaryHeapHeapify(heap, nzheap, i) 21457 DO 21458 ! Find index of the minimum element 21459 IF (2*i<=nzheap) THEN 21460 IF (heap(2*i) % i1 < heap(i) % i1) THEN 21461 mind = 2*i 21462 ELSE 21463 mind = i 21464 END IF 21465 IF (2*i+1<=nzheap) THEN 21466 IF (heap(2*i+1) % i1 < heap(mind) % i1) mind = 2*i+1 21467 END IF 21468 ELSE 21469 mind = i 21470 END IF 21471 21472 IF (mind == i) EXIT 21473 21474 tmp = heap(i) 21475 heap(i) = heap(mind) 21476 heap(mind) = tmp 21477 i = mind 21478 END DO 21479 END DO 21480 21481 pind = -1 21482 nn = 1 21483 DO e=1,te 21484 ! Pick the first element from heap 21485 vindi = heap(1) % i1 21486 lindi = heap(1) % i2 21487 21488 ! Remove duplicates 21489 IF (vindi /= pind .AND. vindi /= node) THEN 21490 neighind(nn) = vindi 21491 pind = vindi 21492 nn = nn+1 21493 END IF 21494 21495 ! Add new element from list (if any) 21496 IF (ptrli(lindi) < ptrti(lindi)) THEN 21497 heap(1) % i1 = vind(ptrli(lindi)) 21498 heap(1) % i2 = lindi 21499 ptrli(lindi) = ptrli(lindi)+1 21500 ELSE 21501 heap(1) % i1 = heap(nzheap) % i1 21502 heap(1) % i2 = heap(nzheap) % i2 21503 nzheap=nzheap-1 21504 END IF 21505 ! CALL BinaryHeapHeapify(heap, nzheap, 1) 21506 i = 1 21507 21508 DO 21509 ! Find the index of the minimum element 21510 ii = 2*i 21511 mind = i 21512 IF (ii+1<=nzheap) THEN 21513 ! Elements 2*i and 2*i+1 can be tested 21514 IF (heap(ii) % i1 < heap(i) % i1) mind = ii 21515 IF (heap(ii+1) % i1 < heap(mind) % i1) mind = ii+1 21516 ELSE IF (ii<=nzheap) THEN 21517 ! Element ii can be tested 21518 IF (heap(ii) % i1 < heap(i) % i1) mind = ii 21519 END IF 21520 21521 IF (mind == i) EXIT 21522 21523 ! Bubble down the element 21524 tmp = heap(i) 21525 heap(i) = heap(mind) 21526 heap(mind) = tmp 21527 i = mind 21528 END DO 21529 21530 END DO 21531 nn=nn-1 21532 END SUBROUTINE kWayMergeHeap 21533 21534 SUBROUTINE BinaryHeapHeapify(heap, nelem, sind) 21535 IMPLICIT NONE 21536 TYPE(IntTuple_t) :: heap(:) 21537 INTEGER, INTENT(IN) :: nelem 21538 INTEGER, INTENT(IN) :: sind 21539 21540 INTEGER :: i, l, r, mind 21541 TYPE(IntTuple_t) :: tmp 21542 21543 i = sind 21544 DO 21545 l = 2*i 21546 r = 2*i+1 21547 ! Find index of the minimum element 21548 mind = i 21549 IF (l <= nelem) THEN 21550 IF (heap(l) % i1 < heap(i) % i1) mind = l 21551 END IF 21552 IF (r <= nelem) THEN 21553 IF (heap(r) % i1 < heap(mind) % i1) mind = r 21554 END IF 21555 21556 IF (mind /= i) THEN 21557 tmp = heap(i) 21558 heap(i) = heap(mind) 21559 heap(mind) = tmp 21560 i = mind 21561 ELSE 21562 EXIT 21563 END IF 21564 END DO 21565 END SUBROUTINE BinaryHeapHeapify 21566 21567 FUNCTION BinaryHeapIsHeap(heap, nelem) RESULT(heaporder) 21568 IMPLICIT NONE 21569 TYPE(IntTuple_t) :: heap(:) 21570 INTEGER, INTENT(IN) :: nelem 21571 LOGICAL :: heaporder 21572 21573 INTEGER :: i, l, r 21574 21575 heaporder = .TRUE. 21576 21577 DO i=(nelem/2), 1, -1 21578 l = 2*i 21579 r = 2*i+1 21580 IF (l <= nelem) THEN 21581 IF (heap(l) % i1 < heap(i) % i1) THEN 21582 heaporder = .FALSE. 21583 write (*,*) 'left: ', l, i 21584 EXIT 21585 END IF 21586 END IF 21587 IF (r <= nelem) THEN 21588 IF (heap(r) % i1 < heap(i) % i1) THEN 21589 heaporder = .FALSE. 21590 write (*,*) 'right: ', r, i 21591 EXIT 21592 END IF 21593 END IF 21594 END DO 21595 END FUNCTION BinaryHeapIsHeap 21596 21597 END SUBROUTINE ElmerMeshToDualGraph 21598 21599 SUBROUTINE Graph_Deallocate(Graph) 21600 IMPLICIT NONE 21601 TYPE(Graph_t) :: Graph 21602 21603 DEALLOCATE(Graph % ptr) 21604 DEALLOCATE(Graph % ind) 21605 Graph % n = 0 21606 END SUBROUTINE Graph_Deallocate 21607 21608 SUBROUTINE ElmerGraphColour(Graph, Colouring, ConsistentColours) 21609 IMPLICIT NONE 21610 21611 TYPE(Graph_t), INTENT(IN) :: Graph 21612 TYPE(Graphcolour_t) :: Colouring 21613 LOGICAL, OPTIONAL :: ConsistentColours 21614 21615 INTEGER, ALLOCATABLE :: uncolored(:) 21616 INTEGER, ALLOCATABLE :: fc(:), ucptr(:), rc(:), rcnew(:) 21617 21618 INTEGER :: nc, dualmaxdeg, i, v, w, uci, wci, vli, vti, vcol, wcol, & 21619 nrc, nunc, nthr, TID, allocstat, gn 21620 INTEGER, ALLOCATABLE :: colours(:) 21621 INTEGER, PARAMETER :: VERTEX_PER_THREAD = 100 21622 LOGICAL :: consistent 21623 21624 ! Iterative parallel greedy algorithm (Alg 2.) from 21625 ! U. V. Catalyurek, J. Feo, A.H. Gebremedhin, M. Halappanavar, A. Pothen. 21626 ! "Graph coloring algorithms for multi-core and massively multithreaded systems". 21627 ! Parallel computing, 38, 2012, pp. 576--594. 21628 21629 ! Initialize number of colours, maximum degree of graph and number of 21630 ! uncolored vertices 21631 nc = 0 21632 dualmaxdeg = 0 21633 gn = Graph % n 21634 nunc = gn 21635 21636 ! Check if a reproducible colouring is being requested 21637 consistent = .FALSE. 21638 IF (PRESENT(ConsistentColours)) consistent = ConsistentColours 21639 21640 ! Get maximum vertex degree of the given graph 21641 !$OMP PARALLEL DO SHARED(Graph) & 21642 !$OMP PRIVATE(v) REDUCTION(max:dualmaxdeg) DEFAULT(NONE) 21643 DO v=1,Graph % n 21644 dualmaxdeg = MAX(dualmaxdeg, Graph % ptr(v+1)- Graph % ptr(v)) 21645 END DO 21646 !$OMP END PARALLEL DO 21647 21648 nthr = 1 21649 ! Ensure that each vertex has at most one thread attached to it 21650 !$ IF (.NOT. consistent) nthr = MIN(omp_get_max_threads(), gn) 21651 21652 ! Allocate memory for colours of vertices and thread colour pointers 21653 ALLOCATE(colours(gn), uncolored(gn), ucptr(nthr+1), STAT=allocstat) 21654 IF (allocstat /= 0) CALL Fatal('ElmerDualGraphColour', & 21655 'Unable to allocate colour maps!') 21656 21657 !$OMP PARALLEL SHARED(gn, dualmaxdeg, Graph, colours, nunc, & 21658 !$OMP uncolored, ucptr, nthr) & 21659 !$OMP PRIVATE(uci, vli, vti, v, w, wci, vcol, wcol, fc, nrc, rc, rcnew, & 21660 !$OMP allocstat, TID) & 21661 !$OMP REDUCTION(max:nc) DEFAULT(NONE) NUM_THREADS(nthr) 21662 21663 TID=1 21664 !$ TID=OMP_GET_THREAD_NUM()+1 21665 21666 ! Greedy algorithm colours a given graph with at 21667 ! most max_{v\in V} deg(v)+1 colours 21668 ALLOCATE(fc(dualmaxdeg+1), rc((gn/nthr)+1), STAT=allocstat) 21669 IF (allocstat /= 0) CALL Fatal('ElmerDualGraphColour', & 21670 'Unable to allocate local workspace!') 21671 ! Initialize forbidden colour array (local to thread) 21672 fc = 0 21673 21674 ! Initialize colours and uncolored entries 21675 !$OMP DO 21676 DO v=1,gn 21677 colours(v)=0 21678 ! U <- V 21679 uncolored(v)=v 21680 END DO 21681 !$OMP END DO 21682 21683 DO 21684 ! For each v\in U in parallel do 21685 !$OMP DO 21686 DO uci=1,nunc 21687 v = uncolored(uci) 21688 vli = Graph % ptr(v) 21689 vti = Graph % ptr(v+1)-1 21690 21691 ! For each w\in adj(v) do 21692 DO w=vli, vti 21693 ! fc[colour[w]]<-v 21694 !$OMP ATOMIC READ 21695 wcol = colours(Graph % ind(w)) 21696 IF (wcol /= 0) fc(wcol) = v 21697 END DO 21698 21699 ! Find smallest permissible colour for vertex 21700 ! c <- min\{i>0: fc[i]/=v \} 21701 DO i=1,dualmaxdeg+1 21702 IF (fc(i) /= v) THEN 21703 !$OMP ATOMIC WRITE 21704 colours(v) = i 21705 ! Maintain maximum colour 21706 nc = MAX(nc, i) 21707 EXIT 21708 END IF 21709 END DO 21710 END DO 21711 !$OMP END DO 21712 21713 nrc = 0 21714 ! For each v\in U in parallel do 21715 !$OMP DO 21716 DO uci=1,nunc 21717 v = uncolored(uci) 21718 vli = Graph % ptr(v) 21719 vti = Graph % ptr(v+1)-1 21720 vcol = colours(v) 21721 21722 ! Make sure that recolour array has enough storage for 21723 ! the worst case (all elements need to be added) 21724 IF (SIZE(rc)<nrc+(vti-vli)+1) THEN 21725 ALLOCATE(rcnew(MAX(SIZE(rc)*2, nrc+(vti-vli)+1)), STAT=allocstat) 21726 IF (allocstat /= 0) CALL Fatal('ElmerDualGraphColour', & 21727 'Unable to allocate local workspace!') 21728 rcnew(1:nrc)=rc(1:nrc) 21729 DEALLOCATE(rc) 21730 CALL MOVE_ALLOC(rcnew, rc) 21731 END IF 21732 21733 ! For each w\in adj(v) do 21734 DO wci=vli,vti 21735 w = Graph % ind(wci) 21736 IF (colours(w)==vcol .AND. v>w) THEN 21737 ! R <- R\bigcup {v} (thread local) 21738 nrc = nrc + 1 21739 rc(nrc)=v 21740 EXIT 21741 END IF 21742 END DO 21743 END DO 21744 !$OMP END DO NOWAIT 21745 21746 ucptr(TID)=nrc 21747 !$OMP BARRIER 21748 21749 !$OMP SINGLE 21750 CALL ComputeCRSIndexes(nthr, ucptr) 21751 nunc = ucptr(nthr+1)-1 21752 !$OMP END SINGLE 21753 21754 ! U <- R 21755 uncolored(ucptr(TID):ucptr(TID+1)-1)=rc(1:nrc) 21756 !$OMP BARRIER 21757 21758 ! Colour the remaining vertices sequentially if the 21759 ! size of the set of uncoloured vertices is small enough 21760 IF (nunc < nthr*VERTEX_PER_THREAD) THEN 21761 !$OMP SINGLE 21762 DO uci=1,nunc 21763 v = uncolored(uci) 21764 vli = Graph % ptr(v) 21765 vti = Graph % ptr(v+1)-1 21766 21767 ! For each w\in adj(v) do 21768 DO w=vli, vti 21769 ! fc[colour[w]]<-v 21770 wcol = colours(Graph % ind(w)) 21771 IF (wcol /= 0) fc(wcol) = v 21772 END DO 21773 21774 ! Find smallest permissible colour for vertex 21775 ! c <- min\{i>0: fc[i]/=v \} 21776 DO i=1,dualmaxdeg+1 21777 IF (fc(i) /= v) THEN 21778 ! Single thread, no collisions possible 21779 colours(v) = i 21780 ! Maintain maximum colour 21781 nc = MAX(nc, i) 21782 EXIT 21783 END IF 21784 END DO 21785 END DO 21786 !$OMP END SINGLE NOWAIT 21787 21788 EXIT 21789 END IF 21790 21791 END DO 21792 21793 ! Deallocate thread local storage 21794 DEALLOCATE(fc, rc) 21795 !$OMP END PARALLEL 21796 21797 DEALLOCATE(uncolored, ucptr) 21798 21799 ! Set up colouring data structure 21800 Colouring % nc = nc 21801 CALL MOVE_ALLOC(colours, Colouring % colours) 21802 END SUBROUTINE ElmerGraphColour 21803 21804 SUBROUTINE Colouring_Deallocate(Colours) 21805 IMPLICIT NONE 21806 TYPE(GraphColour_t) :: Colours 21807 21808 DEALLOCATE(Colours % colours) 21809 Colours % nc = 0 21810 END SUBROUTINE Colouring_Deallocate 21811 21812 SUBROUTINE ElmerColouringToGraph(Colours, PackedList) 21813 IMPLICIT NONE 21814 21815 TYPE(GraphColour_t), INTENT(IN) :: Colours 21816 TYPE(Graph_t) :: PackedList 21817 21818 INTEGER, ALLOCATABLE :: cptr(:), cind(:) 21819 21820 INTEGER :: nc, c, i, n, allocstat 21821 21822 nc = Colours % nc 21823 n = size(Colours % colours) 21824 ALLOCATE(cptr(nc+1), cind(n), STAT=allocstat) 21825 IF (allocstat /= 0) CALL Fatal('ElmerGatherColourLists','Memory allocation failed.') 21826 cptr = 0 21827 ! Count number of elements in each colour 21828 DO i=1,n 21829 cptr(Colours % colours(i))=cptr(Colours % colours(i))+1 21830 END DO 21831 21832 CALL ComputeCRSIndexes(nc, cptr) 21833 21834 DO i=1,n 21835 c=Colours % colours(i) 21836 cind(cptr(c))=i 21837 cptr(c)=cptr(c)+1 21838 END DO 21839 21840 DO i=nc,2,-1 21841 cptr(i)=cptr(i-1) 21842 END DO 21843 cptr(1)=1 21844 21845 ! Set up graph data structure 21846 PackedList % n = nc 21847 CALL MOVE_ALLOC(cptr, PackedList % ptr) 21848 CALL MOVE_ALLOC(cind, PackedList % ind) 21849 END SUBROUTINE ElmerColouringToGraph 21850 21851 ! Routine constructs colouring for boundary mesh based on colours of main mesh 21852 SUBROUTINE ElmerBoundaryGraphColour(Mesh, Colours, BoundaryColours) 21853 IMPLICIT NONE 21854 21855 TYPE(Mesh_t), INTENT(IN) :: Mesh 21856 TYPE(GraphColour_t), INTENT(IN) :: Colours 21857 TYPE(GraphColour_t) :: BoundaryColours 21858 21859 TYPE(Element_t), POINTER :: Element 21860 INTEGER :: elem, nelem, nbelem, astat, lcolour, rcolour, nbc 21861 INTEGER, ALLOCATABLE :: bcolours(:) 21862 21863 nelem = Mesh % NumberOfBulkElements 21864 nbelem = Mesh % NumberOfBoundaryElements 21865 21866 ! Allocate boundary colouring 21867 ALLOCATE(bcolours(nbelem), STAT=astat) 21868 IF (astat /= 0) THEN 21869 CALL Fatal('ElmerBoundaryGraphColour','Unable to allocate boundary colouring') 21870 END IF 21871 21872 nbc = 0 21873 ! Loop over boundary mesh 21874 !$OMP PARALLEL DO & 21875 !$OMP SHARED(Mesh, nelem, nbelem, Colours, bcolours) & 21876 !$OMP PRIVATE(Element, lcolour, rcolour) & 21877 !$OMP REDUCTION(max:nbc) & 21878 !$OMP DEFAULT(NONE) 21879 DO elem=1,nbelem 21880 Element => Mesh % Elements(nelem+elem) 21881 21882 ! Try to find colour for boundary element based on left / right parent 21883 lcolour = 0 21884 IF (ASSOCIATED(Element % BoundaryInfo % Left)) THEN 21885 lcolour = Colours % colours(Element % BoundaryInfo % Left % ElementIndex) 21886 END IF 21887 rcolour = 0 21888 IF (ASSOCIATED(Element % BoundaryInfo % Right)) THEN 21889 rcolour = Colours % colours(Element % BoundaryInfo % Right % ElementIndex) 21890 END IF 21891 21892 ! Sanity check for debug 21893 IF (ASSOCIATED(Element % BoundaryInfo % Left) .AND. & 21894 ASSOCIATED(Element % BoundaryInfo % Right) .AND. & 21895 lcolour /= rcolour) THEN 21896 CALL Warn('ElmerBoundaryGraphColour','Inconsistent colours for boundary element: ' & 21897 // TRIM(i2s(elem)) // "=>" & 21898 // TRIM(i2s(lcolour))// " | "//TRIM(i2s(rcolour))) 21899 WRITE (*,*) Element % BoundaryInfo % Left % ElementIndex, Element % BoundaryInfo % Right % ElementIndex 21900 END IF 21901 21902 bcolours(elem)=MAX(lcolour,rcolour) 21903 nbc=MAX(nbc,bcolours(elem)) 21904 END DO 21905 !$OMP END PARALLEL DO 21906 21907 ! Set up colouring data structure 21908 BoundaryColours % nc = nbc 21909 CALL MOVE_ALLOC(bcolours, BoundaryColours % colours) 21910 END SUBROUTINE ElmerBoundaryGraphColour 21911 21912 ! Given CRS indices, referenced indirectly from graph, 21913 ! evenly load balance the work among the nthr threads 21914 SUBROUTINE ThreadLoadBalanceElementNeighbour(nthr, gn, gptr, gind, & 21915 rptr, blkleads) 21916 IMPLICIT NONE 21917 21918 INTEGER :: nthr 21919 INTEGER, INTENT(IN) :: gn 21920 INTEGER :: gptr(:), gind(:), rptr(:) 21921 INTEGER, ALLOCATABLE :: blkleads(:) 21922 21923 INTEGER :: i, j, k, wrk, gwrk, thrwrk, allocstat 21924 21925 ! Compute number of nonzeroes / thread 21926 !$ nthr = MIN(nthr,gn) 21927 21928 ALLOCATE(blkleads(nthr+1), STAT=allocstat) 21929 IF (allocstat /= 0) CALL Fatal('ThreadLoadBalanceElementNeighbour', & 21930 'Unable to allocate blkleads!') 21931 21932 ! Special case of just one thread 21933 IF (nthr == 1) THEN 21934 blkleads(1)=1 21935 blkleads(2)=gn+1 21936 RETURN 21937 END IF 21938 21939 ! Compute total global work 21940 gwrk = 0 21941 DO i=1,gn 21942 DO j=gptr(i),gptr(i+1)-1 21943 gwrk = gwrk + (rptr(gind(j)+1)-rptr(gind(j))) 21944 END DO 21945 END DO 21946 21947 ! Amount of work per thread 21948 thrwrk = CEILING(REAL(gwrk,dp) / nthr) 21949 21950 ! Find rows for each thread to compute 21951 blkleads(1)=1 21952 DO i=1,nthr 21953 wrk = 0 21954 ! Acquire enough work for thread i 21955 DO j=blkleads(i),gn 21956 DO k=gptr(j),gptr(j+1)-1 21957 wrk = wrk + (rptr(gind(j)+1)-rptr(gind(j))) 21958 END DO 21959 IF (wrk >= thrwrk) EXIT 21960 END DO 21961 21962 blkleads(i+1)=j+1 21963 ! Check if we have run out of rows 21964 IF (j+1>gn) EXIT 21965 END DO 21966 ! Reset number of rows (may be less than or equal to original number) 21967 nthr = i 21968 ! Assign what is left of the matrix to the final thread 21969 blkleads(nthr+1)=gn+1 21970 END SUBROUTINE ThreadLoadBalanceElementNeighbour 21971 21972 SUBROUTINE ThreadStaticWorkShare(nthr, gn, blkleads) 21973 IMPLICIT NONE 21974 21975 INTEGER :: nthr 21976 INTEGER, INTENT(IN) :: gn 21977 INTEGER, ALLOCATABLE :: blkleads(:) 21978 21979 INTEGER :: i, rem, thrwrk, allocstat 21980 INTEGER :: totelem 21981 21982 ! Compute number of nonzeroes / thread 21983 !$ nthr = MIN(nthr,gn) 21984 21985 ALLOCATE(blkleads(nthr+1), STAT=allocstat) 21986 IF (allocstat /= 0) CALL Fatal('ThreadStaticWorkShare', & 21987 'Unable to allocate blkleads!') 21988 21989 ! Special case of just one thread 21990 IF (nthr == 1) THEN 21991 blkleads(1)=1 21992 blkleads(2)=gn+1 21993 RETURN 21994 END IF 21995 21996 ! Assuming even distribution of nodes / element, 21997 ! distribute rows for each thread to compute 21998 blkleads(1)=1 21999 thrwrk = gn / nthr 22000 rem = gn-nthr*thrwrk 22001 ! totelem = 0 22002 DO i=1,nthr-1 22003 IF (i<rem) THEN 22004 blkleads(i+1)=blkleads(i)+thrwrk+1 22005 ELSE 22006 blkleads(i+1)=blkleads(i)+thrwrk 22007 END IF 22008 END DO 22009 ! Assign what is left of the matrix to the final thread 22010 blkleads(nthr+1)=gn+1 22011 END SUBROUTINE ThreadStaticWorkShare 22012 22013 ! Given row counts, in-place compute CRS indices to data 22014 SUBROUTINE ComputeCRSIndexes(n, arr) 22015 IMPLICIT NONE 22016 22017 INTEGER, INTENT(IN) :: n 22018 INTEGER :: arr(:) 22019 22020 INTEGER :: i, indi, indip 22021 22022 indi = arr(1) 22023 arr(1)=1 22024 DO i=1,n-1 22025 indip=arr(i+1) 22026 arr(i+1)=arr(i)+indi 22027 indi=indip 22028 END DO 22029 arr(n+1)=arr(n)+indi 22030 END SUBROUTINE ComputeCRSIndexes 22031 22032 !> Calcalate body average for a discontinuous galerkin field. 22033 !> The intended use is in conjunction of saving the results. 22034 !> This tampers the field and therefore may have unwanted side effects 22035 !> if the solution is to be used for something else too. 22036 !------------------------------------------------------------------- 22037 SUBROUTINE CalculateBodyAverage( Mesh, Var, BodySum ) 22038 22039 TYPE(Variable_t), POINTER :: Var 22040 TYPE(Mesh_t), POINTER :: Mesh 22041 LOGICAL :: BodySum 22042 22043 TYPE(Element_t), POINTER :: Element 22044 REAL(KIND=dp), ALLOCATABLE :: BodyAverage(:) 22045 INTEGER, ALLOCATABLE :: BodyCount(:) 22046 INTEGER :: n,i,j,k,l,nodeind,dgind, Nneighbours 22047 REAL(KIND=dp) :: AveHits 22048 LOGICAL, ALLOCATABLE :: IsNeighbour(:) 22049 22050 IF(.NOT. ASSOCIATED(var)) RETURN 22051 IF( SIZE(Var % Perm) <= Mesh % NumberOfNodes ) RETURN 22052 22053 IF( BodySum ) THEN 22054 CALL Info('CalculateBodyAverage','Calculating bodywise nodal sum for: '& 22055 //TRIM(Var % Name), Level=8) 22056 ELSE 22057 CALL Info('CalculateBodyAverage','Calculating bodywise nodal average for: '& 22058 //TRIM(Var % Name), Level=8) 22059 END IF 22060 22061 n = Mesh % NumberOfNodes 22062 ALLOCATE( BodyCount(n), BodyAverage(n), IsNeighbour(Parenv % PEs) ) 22063 22064 22065 DO i=1,CurrentModel % NumberOfBodies 22066 22067 DO k=1,Var % Dofs 22068 BodyCount = 0 22069 BodyAverage = 0.0_dp 22070 22071 DO j=1,Mesh % NumberOfBulkElements 22072 Element => Mesh % Elements(j) 22073 IF( Element % BodyId /= i ) CYCLE 22074 DO l = 1, Element % TYPE % NumberOfNodes 22075 nodeind = Element % NodeIndexes(l) 22076 dgind = Var % Perm(Element % DGIndexes(l) ) 22077 IF( dgind > 0 ) THEN 22078 BodyAverage( nodeind ) = BodyAverage( nodeind ) + & 22079 Var % Values( Var % DOFs*( dgind-1)+k ) 22080 BodyCount( nodeind ) = BodyCount( nodeind ) + 1 22081 END IF 22082 END DO 22083 END DO 22084 22085 IF( k == 1 ) THEN 22086 AveHits = 1.0_dp * SUM( BodyCount ) / COUNT( BodyCount > 0 ) 22087 !PRINT *,'AveHits:',i,AveHits 22088 END IF 22089 22090 IF(ParEnv % Pes>1) THEN 22091 Nneighbours = MeshNeighbours(Mesh, IsNeighbour) 22092 CALL SendInterface(); CALL RecvInterface() 22093 END IF 22094 22095 ! Do not average weighted quantities. They should only be summed, I guess... 22096 22097 IF( .NOT. BodySum ) THEN 22098 DO j=1,n 22099 IF( BodyCount(j) > 0 ) BodyAverage(j) = BodyAverage(j) / BodyCount(j) 22100 END DO 22101 END IF 22102 22103 DO j=1,Mesh % NumberOfBulkElements 22104 Element => Mesh % Elements(j) 22105 IF( Element % BodyId /= i ) CYCLE 22106 DO l = 1, Element % TYPE % NumberOfNodes 22107 nodeind = Element % NodeIndexes(l) 22108 dgind = Var % Perm(Element % DGIndexes(l) ) 22109 IF( dgind > 0 ) THEN 22110 Var % Values( Var % DOFs*( dgind-1)+k ) = BodyAverage( nodeind ) 22111 END IF 22112 END DO 22113 END DO 22114 END DO 22115 END DO 22116 22117CONTAINS 22118 22119 SUBROUTINE SendInterface() 22120 TYPE buf_t 22121 REAL(KIND=dp), ALLOCATABLE :: dval(:) 22122 INTEGER, ALLOCATABLE :: gdof(:), ival(:) 22123 END TYPE buf_t 22124 22125 INTEGER, ALLOCATABLE :: cnt(:) 22126 TYPE(buf_t), ALLOCATABLE :: buf(:) 22127 22128 INTEGER :: i,j,k,ierr 22129 22130 ALLOCATE(cnt(ParEnv % PEs), buf(ParEnv % PEs)) 22131 22132 cnt = 0 22133 DO i=1,Mesh % NumberOfNodes 22134 IF(.NOT.Mesh % ParallelInfo % Interface(i)) CYCLE 22135 IF(BodyCount(i) <= 0 ) CYCLE 22136 22137 DO j=1,SIZE(Mesh % ParallelInfo % NeighbourList(i) % Neighbours) 22138 k = Mesh % ParallelInfo % NeighbourList(i) % Neighbours(j)+1 22139 cnt(k) = cnt(k) + 1 22140 END DO 22141 END DO 22142 22143 DO i=1,ParEnv % PEs 22144 ALLOCATE(buf(i) % gdof(cnt(i)), buf(i) % ival(cnt(i)), buf(i) % dval(cnt(i))) 22145 END DO 22146 22147 cnt = 0 22148 DO i=1,Mesh % NumberOfNodes 22149 IF(.NOT.Mesh % ParallelInfo % Interface(i)) CYCLE 22150 IF(BodyCount(i) <= 0 ) CYCLE 22151 22152 DO j=1,SIZE(Mesh % ParallelInfo % NeighbourList(i) % Neighbours) 22153 k = Mesh % ParallelInfo % NeighbourList(i) % Neighbours(j)+1 22154 cnt(k) = cnt(k) + 1 22155 buf(k) % gdof(cnt(k)) = Mesh % ParallelInfo % GlobalDOFs(i) 22156 buf(k) % ival(cnt(k)) = BodyCount(i) 22157 buf(k) % dval(cnt(k)) = BodyAverage(i) 22158 END DO 22159 END DO 22160 22161 DO i=1,ParEnv % PEs 22162 IF(.NOT. isNeighbour(i)) CYCLE 22163 22164 CALL MPI_BSEND( cnt(i),1,MPI_INTEGER,i-1,1310,ELMER_COMM_WORLD,ierr ) 22165 IF(cnt(i)>0) THEN 22166 CALL MPI_BSEND( buf(i) % gdof,cnt(i),MPI_INTEGER,i-1,1311,ELMER_COMM_WORLD,ierr ) 22167 CALL MPI_BSEND( buf(i) % ival,cnt(i),MPI_INTEGER,i-1,1312,ELMER_COMM_WORLD,ierr ) 22168 CALL MPI_BSEND( buf(i) % dval,cnt(i),MPI_DOUBLE_PRECISION,i-1,1313,ELMER_COMM_WORLD,ierr ) 22169 END IF 22170 END DO 22171 END SUBROUTINE SendInterface 22172 22173 22174 SUBROUTINE RecvInterface() 22175 INTEGER, ALLOCATABLE :: gdof(:), ival(:) 22176 REAL(KIND=dp), ALLOCATABLE :: dval(:) 22177 INTEGER :: i,j,k,ierr, cnt, status(MPI_STATUS_SIZE) 22178 22179 DO i=1,ParEnv % PEs 22180 22181 IF(.NOT.isNeighbour(i)) CYCLE 22182 22183 CALL MPI_RECV( cnt,1,MPI_INTEGER,i-1,1310,ELMER_COMM_WORLD,status,ierr ) 22184 IF(cnt>0) THEN 22185 ALLOCATE( gdof(cnt), ival(cnt), dval(cnt) ) 22186 CALL MPI_RECV( gdof,cnt,MPI_INTEGER,i-1,1311,ELMER_COMM_WORLD,status,ierr ) 22187 CALL MPI_RECV( ival,cnt,MPI_INTEGER,i-1,1312,ELMER_COMM_WORLD,status,ierr ) 22188 CALL MPI_RECV( dval,cnt,MPI_DOUBLE_PRECISION,i-1,1313,ELMER_COMM_WORLD,status,ierr ) 22189 22190 DO j=1,cnt 22191 k = SearchNode(Mesh % ParallelInfo, gdof(j)) 22192 IF (k>0) THEN 22193 BodyCount(k) = BodyCount(k) + ival(j) 22194 BodyAverage(k) = BodyAverage(k) + dval(j) 22195 END IF 22196 END DO 22197 DEALLOCATE( gdof, ival, dval ) 22198 END IF 22199 END DO 22200 CALL MPI_BARRIER(ELMER_COMM_WORLD,ierr) 22201 END SUBROUTINE RecvInterface 22202 22203 END SUBROUTINE CalculateBodyAverage 22204 22205 22206 22207 !> Given an elemental DG field create a minimal reduced set of it that maintains 22208 !> the necessary continuities. The continuities may be requested between bodies 22209 !> or materials. Optionally the user may give a boundary mask which defines the 22210 !> potential discontinuous nodes that may be greedy or not. 22211 !------------------------------------------------------------------------------- 22212 FUNCTION MinimalElementalSet( Mesh, JumpMode, VarPerm, BcFlag, & 22213 NonGreedy ) RESULT ( SetPerm ) 22214 22215 TYPE(Mesh_t), POINTER :: Mesh 22216 CHARACTER(LEN=*) :: JumpMode 22217 INTEGER, POINTER, OPTIONAL :: VarPerm(:) 22218 CHARACTER(LEN=*), OPTIONAL :: BcFlag 22219 LOGICAL, OPTIONAL :: NonGreedy 22220 INTEGER, POINTER :: SetPerm(:) 22221 22222 TYPE(Element_t), POINTER :: Element, Left, Right 22223 INTEGER :: n,i,j,k,l,bc_id,mat_id,body_id,NoElimNodes,nodeind,JumpModeIndx,& 22224 LeftI,RightI,NumberOfBlocks 22225 LOGICAL, ALLOCATABLE :: JumpNodes(:) 22226 INTEGER, ALLOCATABLE :: NodeVisited(:) 22227 INTEGER, POINTER :: NodeIndexes(:) 22228 LOGICAL :: Found 22229 22230 22231 CALL Info('MinimalElementalSet','Creating discontinuous subset from DG field',Level=5) 22232 22233 ! Calculate size of permutation vector 22234 ALLOCATE( NodeVisited( Mesh % NumberOfNodes ) ) 22235 NodeVisited = 0 22236 22237 NULLIFY( SetPerm ) 22238 k = 0 22239 DO i=1,Mesh % NumberOfBulkElements 22240 Element => Mesh % Elements(i) 22241 k = k + Element % TYPE % NumberOfNodes 22242 END DO 22243 CALL Info('MinimalElementalSet','Maximum number of dofs in DG: '//TRIM(I2S(k)),Level=12) 22244 ALLOCATE( SetPerm(k) ) 22245 SetPerm = 0 22246 l = 0 22247 NoElimNodes = 0 22248 22249 CALL Info('MinimalElementalSet','Reducing elemental discontinuity with mode: '//TRIM(JumpMode),Level=7) 22250 22251 SELECT CASE ( JumpMode ) 22252 22253 CASE('db') ! discontinuous bodies 22254 NumberOfBlocks = CurrentModel % NumberOfBodies 22255 JumpModeIndx = 1 22256 22257 CASE('dm') ! discontinuous materials 22258 NumberOfBlocks = CurrentModel % NumberOfMaterials 22259 JumpModeIndx = 2 22260 22261 CASE DEFAULT 22262 CALL Fatal('MinimalElementalSet','Unknown JumpMode: '//TRIM(JumpMode)) 22263 22264 END SELECT 22265 22266 22267 IF( PRESENT( BcFlag ) ) THEN 22268 ALLOCATE( JumpNodes( Mesh % NumberOfNodes ) ) 22269 END IF 22270 22271 22272 DO i=1,NumberOfBlocks 22273 22274 ! Before the 1st block no numbers have been given. 22275 ! Also if we want discontinuous blocks on all sides initialize the whole list to zero. 22276 IF( i == 1 .OR. .NOT. PRESENT( BcFlag ) ) THEN 22277 NodeVisited = 0 22278 22279 ELSE 22280 ! Vector indicating the disontinuous nodes 22281 ! If this is not given all interface nodes are potentially discontinuous 22282 JumpNodes = .FALSE. 22283 22284 DO j=Mesh % NumberOfBulkElements + 1, & 22285 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 22286 Element => Mesh % Elements(j) 22287 22288 DO bc_id=1,CurrentModel % NumberOfBCs 22289 IF ( Element % BoundaryInfo % Constraint == CurrentModel % BCs(bc_id) % Tag ) EXIT 22290 END DO 22291 IF ( bc_id > CurrentModel % NumberOfBCs ) CYCLE 22292 IF( .NOT. ListCheckPresent( CurrentModel % BCs(bc_id) % Values, BcFlag ) ) CYCLE 22293 22294 Left => Element % BoundaryInfo % Left 22295 Right => Element % BoundaryInfo % Right 22296 IF(.NOT. ASSOCIATED( Left ) .OR. .NOT. ASSOCIATED( Right ) ) CYCLE 22297 22298 IF( JumpModeIndx == 1 ) THEN 22299 LeftI = Left % BodyId 22300 RightI = Right % BodyId 22301 ELSE 22302 LeftI = ListGetInteger( CurrentModel % Bodies(Left % BodyId) % Values,'Material',Found) 22303 RightI = ListGetInteger( CurrentModel % Bodies(Right % BodyId) % Values,'Material',Found) 22304 END IF 22305 22306 IF( LeftI /= i .AND. RightI /= i ) CYCLE 22307 JumpNodes( Element % NodeIndexes ) = .TRUE. 22308 END DO 22309 22310 IF( PRESENT( NonGreedy ) ) THEN 22311 IF( NonGreedy ) THEN 22312 DO j=Mesh % NumberOfBulkElements + 1, & 22313 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 22314 Element => Mesh % Elements(j) 22315 22316 DO bc_id=1,CurrentModel % NumberOfBCs 22317 IF ( Element % BoundaryInfo % Constraint == CurrentModel % BCs(bc_id) % Tag ) EXIT 22318 END DO 22319 IF ( bc_id > CurrentModel % NumberOfBCs ) CYCLE 22320 22321 IF( ListCheckPresent( CurrentModel % BCs(bc_id) % Values, BcFlag ) ) CYCLE 22322 22323 Left => Element % BoundaryInfo % Left 22324 Right => Element % BoundaryInfo % Right 22325 22326 ! External BCs don't have a concept of jump, so no need to treat them 22327 IF(.NOT. ASSOCIATED( Left ) .OR. .NOT. ASSOCIATED( Right ) ) CYCLE 22328 22329 JumpNodes( Element % NodeIndexes ) = .FALSE. 22330 END DO 22331 END IF 22332 END IF 22333 22334 ! Initialize new potential nodes for the block where we found discontinuity 22335 WHERE( JumpNodes ) NodeVisited = 0 22336 END IF 22337 22338 22339 ! Now do the real thing. 22340 ! Add new dofs such that minimal discontinuity is maintained 22341 DO j=1,Mesh % NumberOfBulkElements 22342 Element => Mesh % Elements(j) 22343 22344 Body_Id = Element % BodyId 22345 IF( JumpModeIndx == 1 ) THEN 22346 IF( Body_id /= i ) CYCLE 22347 ELSE 22348 Mat_Id = ListGetInteger( CurrentModel % Bodies(Body_Id) % Values,'Material',Found) 22349 IF( Mat_Id /= i ) CYCLE 22350 END IF 22351 22352 NodeIndexes => Element % NodeIndexes 22353 22354 DO k=1,Element % TYPE % NumberOfNodes 22355 nodeind = NodeIndexes(k) 22356 IF( PRESENT( VarPerm ) ) THEN 22357 IF( VarPerm( nodeind ) == 0 ) CYCLE 22358 END IF 22359 IF( NodeVisited( nodeind ) > 0 ) THEN 22360 SetPerm( Element % DGIndexes(k) ) = NodeVisited( nodeind ) 22361 NoElimNodes = NoElimNodes + 1 22362 ELSE 22363 l = l + 1 22364 NodeVisited(nodeind) = l 22365 SetPerm( Element % DGIndexes(k) ) = l 22366 END IF 22367 END DO 22368 END DO 22369 END DO 22370 22371 CALL Info('MinimalElementalSet','Independent dofs in elemental field: '//TRIM(I2S(l)),Level=7) 22372 CALL Info('MinimalElementalSet','Redundant dofs in elemental field: '//TRIM(I2S(NoElimNodes)),Level=7) 22373 22374 END FUNCTION MinimalElementalSet 22375 22376 22377 !> Calculate the reduced DG field given the reduction permutation. 22378 !> The permutation must be predefined. This may be called repeatedly 22379 !> for different variables. Optionally one may take average, or 22380 !> a plain sum over the shared nodes. 22381 !------------------------------------------------------------------- 22382 SUBROUTINE ReduceElementalVar( Mesh, Var, SetPerm, TakeAverage ) 22383 22384 TYPE(Variable_t), POINTER :: Var 22385 TYPE(Mesh_t), POINTER :: Mesh 22386 INTEGER, POINTER :: SetPerm(:) 22387 LOGICAL :: TakeAverage 22388 22389 TYPE(Element_t), POINTER :: Element 22390 REAL(KIND=dp), ALLOCATABLE :: SetSum(:) 22391 INTEGER, ALLOCATABLE :: SetCount(:) 22392 INTEGER :: dof,n,m,i,j,k,l,nodeind,dgind 22393 REAL(KIND=dp) :: AveHits 22394 22395 IF(.NOT. ASSOCIATED(var)) THEN 22396 CALL Warn('ReduceElementalVar','Variable not associated!') 22397 RETURN 22398 END IF 22399 22400 IF( SIZE(Var % Perm) <= Mesh % NumberOfNodes ) THEN 22401 CALL Warn('ReduceElementalVar','Var % Perm too small!') 22402 RETURN 22403 END IF 22404 22405 IF( TakeAverage ) THEN 22406 CALL Info('ReduceElementalVar','Calculating reduced set average for: '& 22407 //TRIM(Var % Name), Level=7) 22408 ELSE 22409 CALL Info('ReduceElementalVar','Calculating reduced set sum for: '& 22410 //TRIM(Var % Name), Level=7) 22411 END IF 22412 22413 n = Mesh % NumberOfNodes 22414 22415 m = MAXVAL( SetPerm ) 22416 ALLOCATE( SetCount(m), SetSum(m) ) 22417 SetCount = 0 22418 SetSum = 0.0_dp 22419 22420 ! Take the sum to nodes, and calculate average if requested 22421 DO dof=1,Var % Dofs 22422 SetCount = 0 22423 SetSum = 0.0_dp 22424 22425 DO i=1,SIZE(SetPerm) 22426 j = SetPerm(i) 22427 l = Var % Perm(i) 22428 SetSum(j) = SetSum(j) + Var % Values( Var % DOFs * (l-1) + dof ) 22429 SetCount(j) = SetCount(j) + 1 22430 END DO 22431 22432 m = SUM( SetCount ) 22433 IF( m == 0 ) RETURN 22434 22435 IF( TakeAverage ) THEN 22436 WHERE( SetCount > 0 ) SetSum = SetSum / SetCount 22437 END IF 22438 22439 IF( dof == 1 ) THEN 22440 AveHits = 1.0_dp * SUM( SetCount ) / COUNT( SetCount > 0 ) 22441 WRITE(Message,'(A,ES15.4)') 'Average number of hits: ',AveHits 22442 CALL Info('ReduceElementalVar',Message,Level=10) 22443 END IF 22444 22445 ! Copy the reduced set back to the original elemental field 22446 DO i=1,SIZE(SetPerm) 22447 j = SetPerm(i) 22448 l = Var % Perm(i) 22449 Var % Values( Var % DOFs * (l-1) + dof ) = SetSum(j) 22450 END DO 22451 END DO 22452 22453 END SUBROUTINE ReduceElementalVar 22454 22455 22456 !> Given a elemental DG field and a reduction permutation compute the 22457 !> body specific lumped sum. The DG field may be either original one 22458 !> or already summed up. In the latter case only one incident of the 22459 !> redundant nodes is set. 22460 !--------------------------------------------------------------------- 22461 SUBROUTINE LumpedElementalVar( Mesh, Var, SetPerm, AlreadySummed ) 22462 TYPE(Variable_t), POINTER :: Var 22463 TYPE(Mesh_t), POINTER :: Mesh 22464 INTEGER, POINTER :: SetPerm(:) 22465 LOGICAL :: AlreadySummed 22466 22467 TYPE(Element_t), POINTER :: Element 22468 LOGICAL, ALLOCATABLE :: NodeVisited(:) 22469 INTEGER :: dof,n,m,i,j,k,l,nodeind,dgind 22470 REAL(KIND=dp), ALLOCATABLE :: BodySum(:) 22471 22472 IF(.NOT. ASSOCIATED(var)) RETURN 22473 IF( SIZE(Var % Perm) <= Mesh % NumberOfNodes ) RETURN 22474 22475 CALL Info('LumpedElementalVar','Calculating lumped sum for: '& 22476 //TRIM(Var % Name), Level=8) 22477 22478 n = Mesh % NumberOfNodes 22479 22480 m = MAXVAL( SetPerm ) 22481 IF( AlreadySummed ) THEN 22482 ALLOCATE( NodeVisited(m) ) 22483 END IF 22484 ALLOCATE( BodySum( CurrentModel % NumberOfBodies ) ) 22485 22486 ! Take the sum to nodes, and calculate average if requested 22487 DO dof=1,Var % Dofs 22488 22489 BodySum = 0.0_dp 22490 22491 DO i=1,CurrentModel % NumberOfBodies 22492 22493 IF( AlreadySummed ) THEN 22494 NodeVisited = .FALSE. 22495 END IF 22496 22497 DO j=1,Mesh % NumberOfBulkElements 22498 Element => Mesh % Elements(j) 22499 IF( Element % BodyId /= i ) CYCLE 22500 22501 DO k=1,Element % TYPE % NumberOfNodes 22502 dgind = Element % DGIndexes(k) 22503 l = SetPerm(dgind) 22504 IF( l == 0 ) CYCLE 22505 22506 IF( AlreadySummed ) THEN 22507 IF( NodeVisited(l) ) CYCLE 22508 NodeVisited(l) = .TRUE. 22509 END IF 22510 22511 BodySum(i) = BodySum(i) + & 22512 Var % Values( Var % Dofs * ( Var % Perm( dgind )-1) + dof ) 22513 END DO 22514 END DO 22515 END DO 22516 22517 IF( Var % Dofs > 1 ) THEN 22518 CALL Info('LumpedElementalVar','Lumped sum for component: '//TRIM(I2S(dof)),Level=6) 22519 END IF 22520 DO i=1,CurrentModel % NumberOfBodies 22521 WRITE(Message,'(A,ES15.4)') 'Body '//TRIM(I2S(i))//' sum:',BodySum(i) 22522 CALL Info('LumpedElementalVar',Message,Level=10) 22523 END DO 22524 22525 END DO 22526 22527 DEALLOCATE( NodeVisited, BodySum ) 22528 22529 END SUBROUTINE LumpedElementalVar 22530 22531 22532 22533!------------------------------------------------------------------------------ 22534 SUBROUTINE SaveParallelInfo( Solver ) 22535!------------------------------------------------------------------------------ 22536 TYPE( Solver_t ), POINTER :: Solver 22537!------------------------------------------------------------------------------ 22538 TYPE(ParallelInfo_t), POINTER :: ParInfo=>NULL() 22539 TYPE(ValueList_t), POINTER :: Params 22540 CHARACTER(LEN=MAX_NAME_LEN) :: dumpfile 22541 INTEGER :: i,j,k,n,maxnei 22542 LOGICAL :: Found, MeshMode, MatrixMode 22543 CHARACTER(*), PARAMETER :: Caller = "SaveParallelInfo" 22544 TYPE(Nodes_t), POINTER :: Nodes 22545 22546 Params => Solver % Values 22547 22548 MeshMode = ListGetLogical( Params,'Save Parallel Matrix Info',Found ) 22549 MatrixMode = ListGetLogical( Params,'Save Parallel Mesh Info',Found ) 22550 22551 IF( .NOT. ( MeshMode .OR. MatrixMode ) ) RETURN 22552 2255310 IF( MeshMode ) THEN 22554 CALL Info(Caller,'Saving parallel mesh info',Level=8 ) 22555 ELSE 22556 CALL Info(Caller,'Saving parallel matrix info',Level=8 ) 22557 END IF 22558 22559 IF( MeshMode ) THEN 22560 ParInfo => Solver % Mesh % ParallelInfo 22561 Nodes => Solver % Mesh % Nodes 22562 dumpfile = 'parinfo_mesh.dat' 22563 ELSE 22564 ParInfo => Solver % Matrix % ParallelInfo 22565 dumpfile = 'parinfo_mat.dat' 22566 END IF 22567 22568 IF( .NOT. ASSOCIATED( ParInfo ) ) THEN 22569 CALL Warn(Caller,'Parallel info not associated!') 22570 RETURN 22571 END IF 22572 22573 n = SIZE( ParInfo % GlobalDOFs ) 22574 IF( n <= 0 ) THEN 22575 CALL Warn(Caller,'Parallel info size is invalid!') 22576 RETURN 22577 END IF 22578 22579 ! memorize the maximum number of parallel neighbours 22580 maxnei = 0 22581 IF( ASSOCIATED( ParInfo % NeighbourList ) ) THEN 22582 DO i=1,n 22583 IF( ASSOCIATED( ParInfo % NeighbourList(i) % Neighbours ) ) THEN 22584 j = SIZE( ParInfo % NeighbourList(i) % Neighbours ) 22585 maxnei = MAX( j, maxnei ) 22586 END IF 22587 END DO 22588 END IF 22589 CALL Info(Caller,'Maximum number of parallel neighbours:'//TRIM(I2S(maxnei))) 22590 22591 IF(ParEnv % PEs > 1) dumpfile = TRIM(dumpfile)//'.'//TRIM(I2S(ParEnv % myPE)) 22592 CALL Info(Caller,'Saving parallel info to: '//TRIM(dumpfile),Level=8) 22593 22594 OPEN(1,FILE=dumpfile, STATUS='Unknown') 22595 DO i=1,n 22596 j = ParInfo % GlobalDOFs(i) 22597 IF( ParInfo % INTERFACE(i) ) THEN 22598 k = 1 22599 ELSE 22600 k = 0 22601 END IF 22602 WRITE(1,'(3I6)',ADVANCE='NO') i,j,k 22603 IF( ASSOCIATED( ParInfo % NeighbourList(i) % Neighbours ) ) THEN 22604 k = SIZE( ParInfo % NeighbourList(i) % Neighbours ) 22605 ELSE 22606 k = 0 22607 END IF 22608 DO j=1,k 22609 WRITE(1,'(I6)',ADVANCE='NO') ParInfo % NeighbourList(i) % Neighbours(j) 22610 END DO 22611 DO j=k+1,maxnei 22612 WRITE(1,'(I6)',ADVANCE='NO') -1 22613 END DO 22614 IF( MeshMode ) THEN 22615 WRITE(1,'(3ES12.3)',ADVANCE='NO') & 22616 Nodes % x(i), Nodes % y(i), Nodes % z(i) 22617 END IF 22618 WRITE(1,'(A)') ' ' ! finish the line 22619 END DO 22620 CLOSE(1) 22621 22622 ! Redo with matrix if both modes are requested 22623 IF( MeshMode .AND. MatrixMode ) THEN 22624 MeshMode = .FALSE. 22625 GOTO 10 22626 END IF 22627 22628 CALL Info(Caller,'Finished saving parallel info',Level=10) 22629 22630!------------------------------------------------------------------------------ 22631 END SUBROUTINE SaveParallelInfo 22632!------------------------------------------------------------------------------ 22633 22634 22635 22636 22637!------------------------------------------------------------------------------ 22638END MODULE MeshUtils 22639!------------------------------------------------------------------------------ 22640 22641!> \} 22642 22643