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! * Utilities for *Solver - routines 27! * 28! ****************************************************************************** 29! * 30! * Authors: Juha Ruokolainen 31! * Email: Juha.Ruokolainen@csc.fi 32! * Web: http://www.csc.fi/elmer 33! * Address: CSC - IT Center for Science Ltd. 34! * Keilaranta 14 35! * 02101 Espoo, Finland 36! * 37! * Original Date: 28 Sep 1998 38! * 39! *****************************************************************************/ 40 41!> Basic utilities used by individual solvers. 42!------------------------------------------------------------------------------ 43 44!> \ingroup ElmerLib 45!> \{ 46 47 48MODULE SolverUtils 49 50#include "../config.h" 51 52 USE LoadMod 53 USE DirectSolve 54 USE Multigrid 55 USE IterSolve 56 USE ElementUtils 57 USE ComponentUtils 58 USE TimeIntegrate 59 USE ModelDescription 60 USE MeshUtils 61 USE ParallelUtils 62 USE ParallelEigenSolve 63 USE ListMatrix 64 USE CRSMatrix 65 66 IMPLICIT NONE 67 68 INTERFACE CondensateP 69 MODULE PROCEDURE CondensatePR, CondensatePC 70 END INTERFACE CondensateP 71 72 CHARACTER(LEN=MAX_NAME_LEN), PRIVATE :: NormalTangentialName 73 INTEGER, PRIVATE :: NormalTangentialNOFNodes 74 INTEGER, POINTER, PRIVATE :: NTelement(:,:) 75 LOGICAL, POINTER, PRIVATE :: NTzeroing_done(:,:) 76 INTEGER, POINTER, PRIVATE :: BoundaryReorder(:) 77 REAL(KIND=dp), POINTER, PRIVATE :: BoundaryNormals(:,:), & 78 BoundaryTangent1(:,:), & 79 BoundaryTangent2(:,:) 80 81 SAVE BoundaryReorder, NormalTangentialNOFNodes, BoundaryNormals, & 82 BoundaryTangent1, BoundaryTangent2, NormalTangentialName 83 84CONTAINS 85 86!> Initialize matrix structure and vector to zero initial value. 87!------------------------------------------------------------------------------ 88 SUBROUTINE InitializeToZero( A, ForceVector ) 89!------------------------------------------------------------------------------ 90 TYPE(Matrix_t), POINTER :: A !< Matrix to be initialized 91 REAL(KIND=dp) :: ForceVector(:) !< vector to be initialized 92!------------------------------------------------------------------------------ 93 INTEGER :: i,dim 94 LOGICAL :: Found, AnyNT, AnyProj, DoDisplaceMesh 95 TYPE(Solver_t), POINTER :: Solver 96!------------------------------------------------------------------------------ 97 98 CALL Info('InitializeToZero','Initializing the linear system to zero',Level=12) 99 100 IF ( ASSOCIATED( A ) ) THEN 101 SELECT CASE( A % FORMAT ) 102 CASE( MATRIX_CRS ) 103 CALL CRS_ZeroMatrix( A ) 104 105 CASE( MATRIX_BAND,MATRIX_SBAND ) 106 CALL Band_ZeroMatrix( A ) 107 END SELECT 108 109 IF ( ASSOCIATED(A % PrecValues) ) THEN 110 A % PrecValues(:) = 0._dp 111 END IF 112 113 IF ( ASSOCIATED( A % MassValues ) ) THEN 114 A % MassValues(:) = 0.d0 115 END IF 116 117 IF ( ASSOCIATED( A % DampValues ) ) THEN 118 A % DampValues(:) = 0.d0 119 END IF 120 121 IF ( ASSOCIATED( A % Force ) ) THEN 122 A % Force(:,1) = 0.0d0 123 END IF 124 125 IF ( ASSOCIATED( A % RHS_im ) ) THEN 126 A % RHS_im(:) = 0.0d0 127 END IF 128 END IF 129 130 ForceVector = 0.0d0 131 Solver => CurrentModel % Solver 132 133 NormalTangentialNOFNodes = 0 134 IF ( Solver % Variable % DOFs <= 1 ) RETURN 135 136 NormalTangentialName = 'Normal-Tangential' 137 IF ( SEQL(Solver % Variable % Name, 'flow solution') ) THEN 138 NormalTangentialName = TRIM(NormalTangentialName) // ' Velocity' 139 ELSE 140 NormalTangentialName = TRIM(NormalTangentialName) // ' ' // & 141 GetVarName(Solver % Variable) 142 END IF 143 144 AnyNT = ListGetLogicalAnyBC( CurrentModel, NormalTangentialName ) 145 AnyProj = ListGetLogicalAnyBC( CurrentModel, 'Mortar BC Nonlinear') 146 IF( .NOT. (AnyNT .OR. AnyProj ) ) RETURN 147 148 DoDisplaceMesh = ListGetLogical( Solver % Values,'Displace Mesh At Init',Found ) 149 IF( DoDisplaceMesh ) THEN 150 CALL Info('InitializeToZero','Displacing mesh for nonlinear projectors',Level=8) 151 CALL DisplaceMesh( Solver % Mesh, Solver % variable % Values, 1, & 152 Solver % Variable % Perm, Solver % variable % Dofs ) 153 END IF 154 155 IF( AnyNT ) THEN 156 dim = CoordinateSystemDimension() 157 CALL CheckNormalTangentialBoundary( CurrentModel, NormalTangentialName, & 158 NormalTangentialNOFNodes, BoundaryReorder, & 159 BoundaryNormals, BoundaryTangent1, BoundaryTangent2, dim ) 160 161 CALL AverageBoundaryNormals( CurrentModel, NormalTangentialName, & 162 NormalTangentialNOFNodes, BoundaryReorder, & 163 BoundaryNormals, BoundaryTangent1, BoundaryTangent2, & 164 dim ) 165 END IF 166 167 IF( AnyProj ) THEN 168 CALL GenerateProjectors(CurrentModel,Solver,Nonlinear = .TRUE. ) 169 END IF 170 171 IF( DoDisplaceMesh ) THEN 172 CALL DisplaceMesh( Solver % Mesh, Solver % variable % Values, -1, & 173 Solver % Variable % Perm, Solver % variable % Dofs ) 174 END IF 175!------------------------------------------------------------------------------ 176 END SUBROUTINE InitializeToZero 177!------------------------------------------------------------------------------ 178 179 180!> Sets the matrix element to a desired value. 181!------------------------------------------------------------------------------ 182 SUBROUTINE SetMatrixElement( A, i, j, VALUE ) 183!------------------------------------------------------------------------------ 184 TYPE(Matrix_t) :: A !< Structure holding the matrix 185 INTEGER :: i !< Row index 186 INTEGER :: j !< Column index 187 REAL(KIND=dp) :: VALUE !< Value to be obtained 188!------------------------------------------------------------------------------ 189 190 SELECT CASE( A % FORMAT ) 191 CASE( MATRIX_CRS ) 192 CALL CRS_SetMatrixElement( A, i, j, VALUE ) 193 IF(A % FORMAT == MATRIX_LIST) THEN 194 CALL List_toListMatrix(A) 195 CALL List_SetMatrixElement( A % ListMatrix, i, j, VALUE ) 196 END IF 197 198 CASE( MATRIX_LIST ) 199 CALL List_SetMatrixElement( A % ListMatrix, i, j, VALUE ) 200 201 CASE( MATRIX_BAND,MATRIX_SBAND ) 202 CALL Band_SetMatrixElement( A, i, j, VALUE ) 203 END SELECT 204!------------------------------------------------------------------------------ 205 END SUBROUTINE SetMatrixElement 206!------------------------------------------------------------------------------ 207 208!> Gets a matrix element. 209!------------------------------------------------------------------------------ 210 FUNCTION GetMatrixElement( A, i, j ) RESULT ( VALUE ) 211!------------------------------------------------------------------------------ 212 TYPE(Matrix_t) :: A !< Structure holding the matrix 213 INTEGER :: i !< Row index 214 INTEGER :: j !< Column index 215 REAL(KIND=dp) :: VALUE !< Value to be obtained 216!------------------------------------------------------------------------------ 217 218 SELECT CASE( A % FORMAT ) 219 CASE( MATRIX_CRS ) 220 VALUE = CRS_GetMatrixElement( A, i, j ) 221 222 CASE( MATRIX_LIST ) 223 VALUE = List_GetMatrixElement( A % ListMatrix, i, j ) 224 225 CASE( MATRIX_BAND,MATRIX_SBAND ) 226 VALUE = Band_GetMatrixElement( A, i, j ) 227 END SELECT 228!------------------------------------------------------------------------------ 229 END FUNCTION GetMatrixElement 230!------------------------------------------------------------------------------ 231 232!> Changes the value of a given matrix element. 233!------------------------------------------------------------------------------ 234 FUNCTION ChangeMatrixElement( A, i, j, NewValue ) RESULT ( OldValue ) 235!------------------------------------------------------------------------------ 236 TYPE(Matrix_t) :: A 237 INTEGER :: i,j 238 REAL(KIND=dp) :: NewValue, OldValue 239!------------------------------------------------------------------------------ 240 241 SELECT CASE( A % FORMAT ) 242 CASE( MATRIX_CRS ) 243 OldValue = CRS_ChangeMatrixElement( A, i, j, NewValue ) 244 245 CASE DEFAULT 246 CALL Warn('ChangeMatrixElement','Not implemented for this type') 247 248 END SELECT 249!------------------------------------------------------------------------------ 250 END FUNCTION ChangeMatrixElement 251!------------------------------------------------------------------------------ 252 253 254!> Adds to the value of a given matrix element. 255!------------------------------------------------------------------------------ 256 SUBROUTINE AddToMatrixElement( A, i, j,VALUE ) 257!------------------------------------------------------------------------------ 258 TYPE(Matrix_t) :: A 259 INTEGER :: i,j 260 REAL(KIND=dp) :: VALUE 261!------------------------------------------------------------------------------ 262 263 SELECT CASE( A % FORMAT ) 264 CASE( MATRIX_CRS ) 265 CALL CRS_AddToMatrixElement( A, i, j, VALUE ) 266 IF(A % FORMAT == MATRIX_LIST) THEN 267 CALL List_toListMatrix(A) 268 CALL List_AddToMatrixElement( A % ListMatrix, i, j, VALUE ) 269 END IF 270 271 CASE( MATRIX_LIST ) 272 CALL List_AddToMatrixElement( A % ListMatrix, i, j, VALUE ) 273 274 CASE( MATRIX_BAND,MATRIX_SBAND ) 275 CALL Band_AddToMatrixElement( A, i, j, VALUE ) 276 END SELECT 277!------------------------------------------------------------------------------ 278 END SUBROUTINE AddToMatrixElement 279!------------------------------------------------------------------------------ 280 281!> Adds CMPLX value to the value of a given CMPLX matrix element. -ettaka 282!------------------------------------------------------------------------------ 283 SUBROUTINE AddToCmplxMatrixElement(CM, RowId, ColId, Re, Im) 284!------------------------------------------------------------------------------ 285 IMPLICIT NONE 286 TYPE(Matrix_t), POINTER :: CM 287 INTEGER :: RowId, ColId 288 REAL(KIND=dp) :: Re, Im 289 290 CALL AddToMatrixElement(CM, RowId, ColId, Re) 291 CALL AddToMatrixElement(CM, RowId, ColId+1, -Im) 292 CALL AddToMatrixElement(CM, RowId+1, ColId, Im) 293 CALL AddToMatrixElement(CM, RowId+1, ColId+1, Re) 294 295!------------------------------------------------------------------------------ 296 END SUBROUTINE AddToCmplxMatrixElement 297!------------------------------------------------------------------------------ 298 299!> Moves a matrix element from one position adding it to the value of another one. 300!------------------------------------------------------------------------------ 301 SUBROUTINE MoveMatrixElement( A, i1, j1, i2, j2 ) 302!------------------------------------------------------------------------------ 303 TYPE(Matrix_t) :: A 304 INTEGER :: i1,j1,i2,j2 305!------------------------------------------------------------------------------ 306 REAL(KIND=dp) :: VALUE 307 308 VALUE = ChangeMatrixElement(A, i1, j1, 0.0_dp) 309 CALL AddToMatrixElement(A, i2, j2, VALUE ) 310 311!------------------------------------------------------------------------------ 312 END SUBROUTINE MoveMatrixElement 313!------------------------------------------------------------------------------ 314 315 316!> Zeros a row in matrix. 317!------------------------------------------------------------------------------ 318 SUBROUTINE ZeroRow( A, n ) 319!------------------------------------------------------------------------------ 320 TYPE(Matrix_t) :: A !< Structure holding the matrix 321 INTEGER :: n !< Row to be zerored. 322!------------------------------------------------------------------------------ 323 324 SELECT CASE( A % FORMAT ) 325 CASE( MATRIX_CRS ) 326 CALL CRS_ZeroRow( A,n ) 327 328 CASE( MATRIX_LIST ) 329 CALL List_ZeroRow( A % ListMatrix, n ) 330 331 CASE( MATRIX_BAND,MATRIX_SBAND ) 332 CALL Band_ZeroRow( A,n ) 333 END SELECT 334!------------------------------------------------------------------------------ 335 END SUBROUTINE ZeroRow 336!------------------------------------------------------------------------------ 337 338!> Moves a row and and sums it with the values of a second one, optionally 339!> multiplying with a constant. 340!------------------------------------------------------------------------------ 341 SUBROUTINE MoveRow( A, n1, n2, Coeff, StayCoeff, MoveCoeff ) 342!------------------------------------------------------------------------------ 343 TYPE(Matrix_t) :: A 344 INTEGER :: n1, n2 345 REAL(KIND=dp), OPTIONAL :: Coeff, StayCoeff, MoveCoeff 346!------------------------------------------------------------------------------ 347 348 SELECT CASE( A % FORMAT ) 349 CASE( MATRIX_CRS ) 350 CALL CRS_MoveRow( A,n1,n2,Coeff,StayCoeff ) 351 352 ! If entries are not found the format is changed on-the-fly 353 IF( A % FORMAT == MATRIX_LIST ) THEN 354 CALL CRS_MoveRow( A,n1,n2,Coeff,StayCoeff ) ! does this make sense? 355 END IF 356 357 CASE( MATRIX_LIST ) 358 CALL List_MoveRow( A % ListMatrix,n1,n2,Coeff,StayCoeff ) 359 360 CASE DEFAULT 361 CALL Warn('MoveRow','Not implemented for this type') 362 363 END SELECT 364!------------------------------------------------------------------------------ 365 END SUBROUTINE MoveRow 366!------------------------------------------------------------------------------ 367 368 369!--------------------------------------------------------------------------- 370!> If we have antiperiodic DOFs in periodic system and want to do elimination 371!> for conforming mesh, then we need to flip entries in stiffness/mass matrix. 372!--------------------------------------------------------------------------- 373 SUBROUTINE FlipPeriodicLocalMatrix( Solver, n, Indexes, dofs, A ) 374 TYPE(Solver_t), POINTER :: Solver 375 INTEGER :: n, dofs 376 INTEGER :: Indexes(:) 377 REAL(KIND=dp) :: A(:,:) 378 379 LOGICAL, POINTER :: PerFlip(:) 380 INTEGER :: i,j,k,l 381 382 IF( .NOT. Solver % PeriodicFlipActive ) RETURN 383 384 PerFlip => Solver % Mesh % PeriodicFlip 385 386 IF( .NOT. ANY( PerFlip( Indexes(1:n) ) ) ) RETURN 387 388 IF( dofs == 1 ) THEN 389 DO i=1,n 390 DO j=1,n 391 IF( XOR(PerFlip(Indexes(i)),PerFlip(Indexes(j))) ) THEN 392 A(i,j) = -A(i,j) 393 END IF 394 END DO 395 END DO 396 ELSE 397 DO i=1,n 398 DO j=1,n 399 IF( XOR(PerFlip(Indexes(i)),PerFlip(Indexes(j))) ) THEN 400 DO k=1,dofs 401 DO l=1,dofs 402 A(dofs*(i-1)+k,dofs*(j-1)+l) = -A(dofs*(i-1)+k,dofs*(j-1)+l) 403 END DO 404 END DO 405 END IF 406 END DO 407 END DO 408 END IF 409 410 END SUBROUTINE FlipPeriodicLocalMatrix 411 412 413!--------------------------------------------------------------------------- 414!> If we have antiperiodic DOFs in periodic system and want to do elimination 415!> for conforming mesh, then we need to flip entries in local force. 416!--------------------------------------------------------------------------- 417 SUBROUTINE FlipPeriodicLocalForce( Solver, n, Indexes, dofs, F ) 418 TYPE(Solver_t), POINTER :: Solver 419 INTEGER :: n, dofs 420 INTEGER :: Indexes(:) 421 REAL(KIND=dp) :: F(:) 422 423 LOGICAL, POINTER :: PerFlip(:) 424 INTEGER :: i,j 425 426 IF( .NOT. Solver % PeriodicFlipActive ) RETURN 427 428 PerFlip => Solver % Mesh % PeriodicFlip 429 430 IF( .NOT. ANY( PerFlip( Indexes(1:n) ) ) ) RETURN 431 432 IF( dofs == 1 ) THEN 433 DO i=1,n 434 IF( PerFlip(Indexes(i))) F(i) = -F(i) 435 END DO 436 ELSE 437 DO i=1,n 438 IF( PerFlip(Indexes(i))) THEN 439 DO j=1,dofs 440 F(dofs*(i-1)+j) = -F(dofs*(i-1)+j) 441 END DO 442 END IF 443 END DO 444 END IF 445 446 END SUBROUTINE FlipPeriodicLocalForce 447 448 449!--------------------------------------------------------------------------- 450!> Check if there is something to flip. 451!--------------------------------------------------------------------------- 452 FUNCTION AnyFlipPeriodic( Solver, n, Indexes ) RESULT ( DoFlip ) 453 TYPE(Solver_t), POINTER :: Solver 454 INTEGER :: n 455 INTEGER :: Indexes(:) 456 LOGICAL :: DoFlip 457 458 LOGICAL, POINTER :: PerFlip(:) 459 460 DoFlip = .FALSE. 461 IF( .NOT. Solver % PeriodicFlipActive ) RETURN 462 463 PerFlip => Solver % Mesh % PeriodicFlip 464 DoFlip = ANY( PerFlip(Indexes(1:n))) 465 466 END FUNCTION AnyFlipPeriodic 467 468 469 470!> Glues a local matrix to the global one. 471!------------------------------------------------------------------------------ 472 SUBROUTINE GlueLocalSubMatrix( A,row0,col0,Nrow,Ncol,RowInds,ColInds,& 473 RowDofs,ColDofs,LocalMatrix ) 474!------------------------------------------------------------------------------ 475 REAL(KIND=dp) :: LocalMatrix(:,:) 476 TYPE(Matrix_t) :: A 477 INTEGER :: Nrow,Ncol,RowDofs,ColDofs,Col0,Row0,RowInds(:),ColInds(:) 478!------------------------------------------------------------------------------ 479 480 SELECT CASE( A % FORMAT ) 481 482 CASE( MATRIX_CRS ) 483 CALL CRS_GlueLocalSubMatrix( A,row0,col0,Nrow,Ncol,RowInds,ColInds,& 484 RowDofs,ColDofs,LocalMatrix ) 485 486 CASE( MATRIX_LIST ) 487 CALL List_GlueLocalSubMatrix( A % ListMatrix,row0,col0,Nrow,Ncol,RowInds,ColInds,& 488 RowDofs,ColDofs,LocalMatrix ) 489 490 CASE DEFAULT 491 CALL Warn('GlueLocalSubMatrix','Not implemented for this type') 492 493 END SELECT 494!------------------------------------------------------------------------------ 495 END SUBROUTINE GlueLocalSubMatrix 496!------------------------------------------------------------------------------ 497 498 499!> Matrix vector multiplication of sparse matrices. 500!------------------------------------------------------------------------------ 501 SUBROUTINE MatrixVectorMultiply( A,u,v ) 502!------------------------------------------------------------------------------ 503 TYPE(Matrix_t) :: A 504 INTEGER :: n 505 REAL(KIND=dp), DIMENSION(:) CONTIG :: u,v 506!------------------------------------------------------------------------------ 507 508 SELECT CASE( A % FORMAT ) 509 CASE( MATRIX_CRS ) 510 CALL CRS_MatrixVectorMultiply( A,u,v ) 511 512 CASE( MATRIX_BAND,MATRIX_SBAND ) 513 CALL Band_MatrixVectorMultiply( A,u,v ) 514 515 CASE( MATRIX_LIST ) 516 CALL Warn('MatrixVectorMultiply','Not implemented for List matrix type') 517 518 END SELECT 519!------------------------------------------------------------------------------ 520 END SUBROUTINE MatrixVectorMultiply 521 522 523!------------------------------------------------------------------------------ 524!> Matrix vector multiplication of sparse matrices. 525!------------------------------------------------------------------------------ 526 SUBROUTINE MaskedMatrixVectorMultiply( A,u,v,ActiveRow,ActiveCol ) 527!------------------------------------------------------------------------------ 528 TYPE(Matrix_t) :: A 529 INTEGER :: n 530 REAL(KIND=dp), DIMENSION(:) CONTIG :: u,v 531 LOGICAL, DIMENSION(:) :: ActiveRow 532 LOGICAL, DIMENSION(:) :: ActiveCol 533!------------------------------------------------------------------------------ 534 535 SELECT CASE( A % FORMAT ) 536 CASE( MATRIX_CRS ) 537 CALL CRS_MaskedMatrixVectorMultiply( A,u,v,ActiveRow, ActiveCol ) 538 539 CASE DEFAULT 540 CALL Fatal('MaskedMatrixVectorMultiply','Not implemented for List matrix type') 541 542 END SELECT 543!------------------------------------------------------------------------------ 544 END SUBROUTINE MaskedMatrixVectorMultiply 545!------------------------------------------------------------------------------ 546 547 548!> Matrix vector multiplication of sparse matrices. 549!------------------------------------------------------------------------------ 550 SUBROUTINE TransposeMatrixVectorMultiply( A,u,v ) 551!------------------------------------------------------------------------------ 552 TYPE(Matrix_t) :: A 553 INTEGER :: n 554 REAL(KIND=dp), DIMENSION(:) CONTIG :: u,v 555!------------------------------------------------------------------------------ 556 557 SELECT CASE( A % FORMAT ) 558 CASE( MATRIX_CRS ) 559 CALL CRS_TransposeMatrixVectorMultiply( A,u,v ) 560 561 CASE DEFAULT 562 CALL Fatal('TransposeMatrixVectorMultiply','Not implemented for other than CRS type') 563 564 END SELECT 565!------------------------------------------------------------------------------ 566 END SUBROUTINE TransposeMatrixVectorMultiply 567!------------------------------------------------------------------------------ 568 569 570!> Create a copy of the linear system (Values,Rhs) to (BulkValues,BulkRhs). 571!------------------------------------------------------------------------------ 572 SUBROUTINE CopyBulkMatrix( A, BulkMass, BulkDamp ) 573!------------------------------------------------------------------------------ 574 TYPE(Matrix_t) :: A 575 INTEGER :: i,n 576 LOGICAL, OPTIONAL :: BulkMass, BulkDamp 577 578 n = SIZE( A % Rhs ) 579 IF( ASSOCIATED( A % BulkRhs ) ) THEN 580 IF( SIZE( A % BulkRhs ) /= n ) THEN 581 DEALLOCATE( A % BulkRhs ) 582 A % BulkRHS => NULL() 583 END IF 584 END IF 585 IF ( .NOT. ASSOCIATED( A % BulkRHS ) ) THEN 586 ALLOCATE( A % BulkRHS( n ) ) 587 END IF 588 DO i=1,n 589 A % BulkRHS(i) = A % Rhs(i) 590 END DO 591 592 n = SIZE( A % Values ) 593 IF( ASSOCIATED( A % BulkValues ) ) THEN 594 IF( SIZE( A % BulkValues ) /= n ) THEN 595 DEALLOCATE( A % BulkValues ) 596 A % BulkValues => NULL() 597 END IF 598 END IF 599 IF ( .NOT. ASSOCIATED( A % BulkValues ) ) THEN 600 ALLOCATE( A % BulkValues( n ) ) 601 END IF 602 603 DO i=1,n 604 A % BulkValues(i) = A % Values(i) 605 END DO 606 607 IF( PRESENT( BulkMass ) .AND. ASSOCIATED( A % MassValues) ) THEN 608 IF( BulkMass ) THEN 609 n = SIZE( A % MassValues ) 610 IF( ASSOCIATED( A % BulkMassValues ) ) THEN 611 IF( SIZE( A % BulkMassValues ) /= n ) THEN 612 DEALLOCATE( A % BulkMassValues ) 613 A % BulkMassValues => NULL() 614 END IF 615 END IF 616 IF ( .NOT. ASSOCIATED( A % BulkMassValues ) ) THEN 617 ALLOCATE( A % BulkMassValues( n ) ) 618 END IF 619 620 DO i=1,n 621 A % BulkMassValues(i) = A % MassValues(i) 622 END DO 623 END IF 624 END IF 625 626 IF( PRESENT( BulkDamp ) .AND. ASSOCIATED( A % DampValues) ) THEN 627 IF( BulkDamp ) THEN 628 n = SIZE( A % DampValues ) 629 IF( ASSOCIATED( A % BulkDampValues ) ) THEN 630 IF( SIZE( A % BulkDampValues ) /= n ) THEN 631 DEALLOCATE( A % BulkDampValues ) 632 A % BulkDampValues => NULL() 633 END IF 634 END IF 635 IF ( .NOT. ASSOCIATED( A % BulkDampValues ) ) THEN 636 ALLOCATE( A % BulkDampValues( n ) ) 637 END IF 638 639 DO i=1,n 640 A % BulkDampValues(i) = A % DampValues(i) 641 END DO 642 END IF 643 END IF 644 645 END SUBROUTINE CopyBulkMatrix 646!------------------------------------------------------------------------------ 647 648 649!> Restores the saved bulk after 650!------------------------------------------------------------------------------ 651 SUBROUTINE RestoreBulkMatrix( A ) 652!------------------------------------------------------------------------------ 653 TYPE(Matrix_t) :: A 654 INTEGER :: i,n 655 656 IF( ASSOCIATED( A % BulkRhs ) ) THEN 657 n = SIZE( A % Rhs ) 658 IF( SIZE( A % BulkRhs ) /= n ) THEN 659 CALL Fatal('RestoreBulkMatrix','Cannot restore rhs of different size!') 660 END IF 661 A % Rhs(1:n) = A % BulkRhs(1:n) 662 END IF 663 664 IF( ASSOCIATED( A % BulkValues ) ) THEN 665 n = SIZE( A % Values ) 666 IF( SIZE( A % BulkValues ) /= n ) THEN 667 CALL Fatal('RestoreBulkMatrix','Cannot restore matrix of different size!') 668 END IF 669 DO i=1,n 670 A % Values(i) = A % BulkValues(i) 671 END DO 672 END IF 673 674 IF( ASSOCIATED( A % BulkMassValues ) ) THEN 675 n = SIZE( A % MassValues ) 676 IF( SIZE( A % BulkMassValues ) /= n ) THEN 677 CALL Fatal('RestoreBulkMatrix','Cannot restore mass matrix of different size!') 678 END IF 679 DO i=1,n 680 A % MassValues(i) = A % BulkMassValues(i) 681 END DO 682 END IF 683 684 IF( ASSOCIATED( A % BulkDampValues ) ) THEN 685 n = SIZE( A % DampValues ) 686 IF( SIZE( A % BulkDampValues ) /= n ) THEN 687 CALL Fatal('RestoreBulkMatrix','Cannot restore damp matrix of different size!') 688 END IF 689 DO i=1,n 690 A % DampValues(i) = A % BulkDampValues(i) 691 END DO 692 END IF 693 694 END SUBROUTINE RestoreBulkMatrix 695!------------------------------------------------------------------------------ 696 697 698 699 700!> Create a child matrix of same toopology but optioanally different size than the 701!> parent matrix. 702!------------------------------------------------------------------------------ 703 704 FUNCTION CreateChildMatrix( ParentMat, ParentDofs, Dofs, ColDofs, CreateRhs, & 705 NoReuse, Diagonal ) RESULT ( ChildMat ) 706 TYPE(Matrix_t) :: ParentMat 707 INTEGER :: ParentDofs 708 INTEGER :: Dofs 709 TYPE(Matrix_t), POINTER :: ChildMat 710 INTEGER, OPTIONAL :: ColDofs 711 LOGICAL, OPTIONAL :: CreateRhs 712 LOGICAL, OPTIONAL :: NoReuse 713 LOGICAL, OPTIONAL :: Diagonal 714 INTEGER :: i,j,ii,jj,k,l,m,n,nn,Cdofs 715 LOGICAL :: ReuseMatrix 716 717 IF( ParentMat % FORMAT /= MATRIX_CRS ) THEN 718 CALL Fatal('CreateChildMatrix','Only available for CRS matrix format!') 719 END IF 720 721 ChildMat => AllocateMatrix() 722 723 CALL CRS_CreateChildMatrix( ParentMat, ParentDofs, ChildMat, Dofs, ColDofs, CreateRhs, & 724 NoReuse, Diagonal ) 725 726 END FUNCTION CreateChildMatrix 727 728 729 730!> Search faces between passive / non-passive domains; add to boundary 731!> elements with given bc-id. 732!------------------------------------------------------------------------------ 733 SUBROUTINE GetPassiveBoundary(Model,Mesh,BcId) 734!------------------------------------------------------------------------------ 735 TYPE(Model_t) :: Model 736 INTEGER :: BcId 737 TYPE(Mesh_t) :: Mesh 738 739 INTEGER, ALLOCATABLE :: arr(:) 740 INTEGER :: i,j,n,cnt,ind, sz 741 LOGICAL :: L1,L2 742 TYPE(Element_t), POINTER :: Faces(:), Telems(:), Face, P1, P2 743 744 CALL FindMeshEdges(Mesh,.FALSE.) 745 SELECT CASE(Mesh % MeshDim) 746 CASE(2) 747 Faces => Mesh % Edges 748 n = Mesh % NumberOfEdges 749 CASE(3) 750 Faces => Mesh % Faces 751 n = Mesh % NumberOfFaces 752 END SELECT 753 754 ALLOCATE(arr(n)); cnt=0 755 DO i=1,n 756 P1 => Faces(i) % BoundaryInfo % Right 757 P2 => Faces(i) % BoundaryInfo % Left 758 IF ( .NOT. ASSOCIATED(P1) .OR. .NOT. ASSOCIATED(P2) ) CYCLE 759 760 L1 = CheckPassiveElement(P1) 761 L2 = CheckPassiveElement(P2) 762 763 IF ( L1.NEQV.L2) THEN 764 cnt = cnt+1 765 arr(cnt) = i 766 END IF 767 END DO 768 769 sz = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements - & 770 Mesh % PassBCcnt 771 IF ( sz+cnt>SIZE(Mesh % Elements) ) THEN 772 Telems => Mesh % Elements 773 ALLOCATE(Mesh % Elements(sz+cnt)) 774 IF ( ASSOCIATED(Model % Elements,Telems) ) & 775 Model % Elements => Mesh % Elements 776 777 Mesh % Elements(1:sz) = Telems 778 779 ! fix boundary element parent pointers to use new array ... 780 ! -------------------------------------------------------- 781 DO i=1,Mesh % NumberOfBoundaryElements-Mesh % PassBCcnt 782 ind = i+Mesh % NumberOfBulkElements 783 Face => Mesh % Elements(ind) 784 IF ( ASSOCIATED(Face % BoundaryInfo % Left) ) & 785 Face % BoundaryInfo % Left => & 786 Mesh % Elements(Face % BoundaryInfo % Left % ElementIndex) 787 IF ( ASSOCIATED(Face % BoundaryInfo % Right ) ) & 788 Face % BoundaryInfo % Right => & 789 Mesh % Elements(Face % BoundaryInfo % Right % ElementIndex) 790 END DO 791 792 ! ...likewise for faces (edges). 793 ! ------------------------------- 794 DO i=1,n 795 Face => Faces(i) 796 IF ( ASSOCIATED(Face % BoundaryInfo % Left) ) & 797 Face % BoundaryInfo % Left => & 798 Mesh % Elements(Face % BoundaryInfo % Left % ElementIndex) 799 IF ( ASSOCIATED(Face % BoundaryInfo % Right ) ) & 800 Face % BoundaryInfo % Right => & 801 Mesh % Elements(Face % BoundaryInfo % Right % ElementIndex) 802 END DO 803 804 DEALLOCATE(Telems) 805 END IF 806 807 DO i=1,cnt 808 sz = sz+1 809 Mesh % Elements(sz) = Faces(arr(i)) 810 Mesh % Elements(sz) % Copy = .TRUE. 811 Mesh % Elements(sz) % ElementIndex = sz 812 Mesh % Elements(sz) % BoundaryInfo % Constraint = BcId 813 END DO 814 Mesh % NumberOfBoundaryElements = Mesh % NumberOfBoundaryElements - & 815 Mesh % PassBCcnt + cnt 816 Mesh % PassBCcnt = cnt 817 IF ( ASSOCIATED(Model % Elements,Mesh % Elements) ) & 818 Model % NumberOfBoundaryElements = Mesh % NumberOfBoundaryElements 819!------------------------------------------------------------------------------ 820 END SUBROUTINE GetPassiveBoundary 821!------------------------------------------------------------------------------ 822 823 824!------------------------------------------------------------------------------ 825!> For time dependent simulations add the time derivative coefficient terms 826!> to the local matrix containing other coefficients. 827!------------------------------------------------------------------------------ 828 SUBROUTINE Add1stOrderTime( MassMatrix, StiffMatrix, & 829 Force, dt, n, DOFs, NodeIndexes, Solver, UElement ) 830!------------------------------------------------------------------------------ 831 REAL(KIND=dp) :: MassMatrix(:,:) !< Local mass matrix. 832 REAL(KIND=dp) :: StiffMatrix(:,:) !< Local stiffness matrix. 833 REAL(KIND=dp) :: Force(:) !< Local right-hand-side vector. 834 REAL(KIND=dp) :: dt !< Simulation timestep size 835 INTEGER :: n !< number of element nodes 836 INTEGER :: DOFs !< variable degrees of freedom 837 INTEGER :: NodeIndexes(:) !< element nodes 838 TYPE(Solver_t) :: Solver !< Solver structure. 839 TYPE(Element_t), TARGET, OPTIONAL :: UElement !< Element structure 840!------------------------------------------------------------------------------ 841 LOGICAL :: GotIt 842 INTEGER :: i,j,k,l,m,Order 843 REAL(KIND=dp) :: s, t, zeta 844 CHARACTER(LEN=MAX_NAME_LEN) :: Method 845 REAL(KIND=dp) :: PrevSol(DOFs*n,Solver % Order), CurSol(DOFs*n), LForce(n*DOFs) 846 TYPE(Variable_t), POINTER :: DtVar 847 REAL(KIND=dp) :: Dts(Solver % Order) 848 LOGICAL :: ConstantDt 849 TYPE(Element_t), POINTER :: Element 850!------------------------------------------------------------------------------ 851 INTEGER :: PredCorrOrder !< Order of predictor-corrector scheme 852 853 IF ( PRESENT(UElement) ) THEN 854 Element => UElement 855 ELSE 856 Element => CurrentModel % CurrentElement 857 END IF 858 859 IF ( Solver % Matrix % Lumped ) THEN 860#ifndef OLD_LUMPING 861 s = 0.d0 862 t = 0.d0 863 DO i=1,n*DOFs 864 DO j=1,n*DOFs 865 s = s + MassMatrix(i,j) 866 IF (i /= j) THEN 867 MassMatrix(i,j) = 0.d0 868 END IF 869 END DO 870 t = t + MassMatrix(i,i) 871 END DO 872 873 DO i=1,n 874 DO j=1,DOFs 875 K = DOFs * (i-1) + j 876 L = DOFs * (NodeIndexes(i)-1) + j 877 IF ( t /= 0.d0 ) THEN 878 MassMatrix(K,K) = MassMatrix(K,K) * s / t 879 END IF 880 END DO 881 END DO 882#else 883 DO i=1,n*DOFs 884 s = 0.0d0 885 DO j = 1,n*DOFs 886 s = s + MassMatrix(i,j) 887 MassMatrix(i,j) = 0.0d0 888 END DO 889 MassMatrix(i,i) = s 890 END DO 891 892 DO i=1,n 893 DO j=1,DOFs 894 K = DOFs * (i-1) + j 895 L = DOFs * (NodeIndexes(i)-1) + j 896 END DO 897 END DO 898#endif 899 END IF 900!------------------------------------------------------------------------------ 901 Order = MIN(Solver % DoneTime, Solver % Order) 902 903 DO i=1,n 904 DO j=1,DOFs 905 K = DOFs * (i-1) + j 906 L = DOFs * (NodeIndexes(i)-1) + j 907 DO m=1, Order 908 PrevSol(K,m) = Solver % Variable % PrevValues(L,m) 909 END DO 910 CurSol(K) = Solver % Variable % Values(L) 911 END DO 912 END DO 913 914 LForce(1:n*DOFs) = Force(1:n*DOFs) 915 CALL UpdateGlobalForce( Solver % Matrix % Force(:,1), LForce, & 916 n, DOFs, NodeIndexes, UElement=Element ) 917!------------------------------------------------------------------------------ 918!PrevSol(:,Order) needed for BDF 919 Method = ListGetString( Solver % Values, 'Timestepping Method', GotIt ) 920 921 SELECT CASE( Method ) 922 CASE( 'fs' ) 923 CALL FractionalStep( n*DOFs, dt, MassMatrix, StiffMatrix, Force, & 924 PrevSol(:,1), Solver % Beta, Solver ) 925 926 CASE('bdf') 927 Dts(1) = Dt 928 ConstantDt = .TRUE. 929 IF(Order > 1) THEN 930 DtVar => VariableGet( Solver % Mesh % Variables, 'Timestep size' ) 931 DO i=2,Order 932 Dts(i) = DtVar % PrevValues(1,i-1) 933 IF(ABS(Dts(i)-Dts(1)) > 1.0d-6 * Dts(1)) ConstantDt = .FALSE. 934 END DO 935 END IF 936 937 IF(ConstantDt) THEN 938 CALL BDFLocal( n*DOFs, dt, MassMatrix, StiffMatrix, Force, PrevSol, & 939 Order ) 940 ELSE 941 CALL VBDFLocal( n*DOFs, dts, MassMatrix, StiffMatrix, Force, PrevSol, & 942 Order ) 943 END IF 944 945 CASE('runge-kutta') 946 CALL RungeKutta( n*DOFs, dt, MassMatrix, StiffMatrix, Force, & 947 PrevSol(:,1), CurSol ) 948 949 CASE('adams-bashforth') 950 zeta = ListGetConstReal( Solver % Values, 'Adams Zeta', GotIt ) 951 IF ( .NOT. Gotit) zeta = 1.0_dp 952 PredCorrOrder = ListGetInteger( Solver % Values, & 953 'Predictor-Corrector Scheme Order', GotIt) 954 IF (.NOT. GotIt) PredCorrOrder = 2 955 PredCorrOrder = MIN(PredCorrOrder, Solver % DoneTime /2) 956 CALL AdamsBashforth( n*DOFs, dt, MassMatrix, StiffMatrix, Force, & 957 PrevSol(:,1), zeta, PredCorrOrder) 958 959 CASE('adams-moulton') 960 PredCorrOrder = ListGetInteger( Solver % Values, & 961 'Predictor-Corrector Scheme Order', GotIt) 962 IF (.NOT. GotIt) PredCorrOrder = 2 963 PredCorrOrder = MIN(PredCorrOrder, Solver % DoneTime /2) 964 CALL AdamsMoulton( n*DOFs, dt, MassMatrix, StiffMatrix, Force, & 965 PrevSol, PredCorrOrder ) 966 967 CASE DEFAULT 968 CALL NewmarkBeta( n*DOFs, dt, MassMatrix, StiffMatrix, Force, & 969 PrevSol(:,1), Solver % Beta ) 970 END SELECT 971 972!------------------------------------------------------------------------------ 973 END SUBROUTINE Add1stOrderTime 974!------------------------------------------------------------------------------ 975 976!------------------------------------------------------------------------------ 977!> For time dependent simulations add the time derivative coefficient terms 978!> to the global matrix containing other coefficients. 979!------------------------------------------------------------------------------ 980 SUBROUTINE Add1stOrderTime_CRS( Matrix, Force, dt, Solver ) 981!------------------------------------------------------------------------------ 982 TYPE(Matrix_t), POINTER :: Matrix !< Global matrix (including stiffness and mass) 983 REAL(KIND=dp) :: Force(:) !< Global right-hand-side vector. 984 REAL(KIND=dp) :: dt !< Simulation timestep size 985 TYPE(Solver_t) :: Solver !< Solver structure. 986!------------------------------------------------------------------------------ 987 LOGICAL :: GotIt 988 INTEGER :: i,j,k,l,m,n,Order 989 REAL(KIND=dp) :: s, t, msum 990 CHARACTER(LEN=MAX_NAME_LEN) :: Method 991 TYPE(Variable_t), POINTER :: DtVar 992 REAL(KIND=dp) :: Dts(Solver % Order) 993 REAL(KIND=dp), POINTER :: PrevSol(:,:), ML(:), CurrSol(:) 994 INTEGER, POINTER :: Rows(:), Cols(:) 995 LOGICAL :: ConstantDt, Lumped, Found 996!------------------------------------------------------------------------------ 997 998 CALL Info('Add1stOrderTime_CRS','Adding time discretization to CRS matrix',Level=20) 999 1000!------------------------------------------------------------------------------ 1001 Order = MIN(Solver % DoneTime, Solver % Order) 1002 Method = ListGetString( Solver % Values, 'Timestepping Method', GotIt ) 1003 CurrSol => Solver % Variable % Values 1004 PrevSol => Solver % Variable % PrevValues 1005 1006 1007 SELECT CASE( Method ) 1008 1009 CASE( 'fs' ) 1010 CALL FractionalStep_CRS( dt, Matrix, Force, PrevSol(:,1), Solver ) 1011 1012 CASE('bdf') 1013 ConstantDt = .TRUE. 1014 IF(Order > 1) THEN 1015 Dts(1) = Dt 1016 DtVar => VariableGet( Solver % Mesh % Variables, 'Timestep size' ) 1017 DO i=2,Order 1018 Dts(i) = DtVar % PrevValues(1,i-1) 1019 IF(ABS(Dts(i)-Dts(1)) > 1.0d-6 * Dts(1)) ConstantDt = .FALSE. 1020 END DO 1021 END IF 1022 1023 IF(ConstantDt) THEN 1024 CALL BDF_CRS( dt, Matrix, Force, PrevSol, Order ) 1025 ELSE 1026 CALL VBDF_CRS( dts, Matrix, Force, PrevSol, Order ) 1027 END IF 1028 1029 CASE('runge-kutta') 1030 CALL RungeKutta_CRS( dt, Matrix, Force, PrevSol(:,1), CurrSol ) 1031 1032 CASE DEFAULT 1033 CALL NewmarkBeta_CRS( dt, Matrix, Force, PrevSol(:,1), & 1034 Solver % Beta ) 1035 1036 END SELECT 1037 1038!------------------------------------------------------------------------------ 1039 END SUBROUTINE Add1stOrderTime_CRS 1040!------------------------------------------------------------------------------ 1041 1042 1043!------------------------------------------------------------------------------ 1044!> For time dependent simulations add the time derivative coefficient terms 1045!> to the matrix containing other coefficients. 1046!------------------------------------------------------------------------------ 1047 SUBROUTINE Add2ndOrderTime( MassMatrix, DampMatrix, StiffMatrix, & 1048 Force, dt, n, DOFs, NodeIndexes, Solver ) 1049!------------------------------------------------------------------------------ 1050 REAL(KIND=dp) :: MassMatrix(:,:) !< Local mass matrix. 1051 REAL(KIND=dp) :: DampMatrix(:,:) !< Local damping matrix. 1052 REAL(KIND=dp) :: StiffMatrix(:,:) !< Local stiffness matrix. 1053 REAL(KIND=dp) :: Force(:) !< Local right-hand-side vector. 1054 REAL(KIND=dp) :: dt !< Simulation timestep size 1055 INTEGER :: n !< number of element nodes 1056 INTEGER :: DOFs !< variable degrees of freedom 1057 INTEGER :: NodeIndexes(:) !< element nodes 1058 TYPE(Solver_t) :: Solver !< Solver structure. 1059!------------------------------------------------------------------------------ 1060 LOGICAL :: GotIt 1061 INTEGER :: i,j,k,l 1062 CHARACTER(LEN=MAX_NAME_LEN) :: Method 1063 REAL(KIND=dp) :: s,t 1064 REAL(KIND=dp) :: X(DOFs*n),V(DOFs*N),A(DOFs*N),LForce(n*DOFs) 1065 1066!------------------------------------------------------------------------------ 1067 1068 IF ( Solver % Matrix % Lumped ) THEN 1069!------------------------------------------------------------------------------ 1070#ifndef OLD_LUMPING 1071 s = 0.d0 1072 t = 0.d0 1073 DO i=1,n*DOFs 1074 DO j=1,n*DOFs 1075 s = s + MassMatrix(i,j) 1076 IF (i /= j) THEN 1077 MassMatrix(i,j) = 0.d0 1078 END IF 1079 END DO 1080 t = t + MassMatrix(i,i) 1081 END DO 1082 1083 DO i=1,n 1084 DO j=1,DOFs 1085 K = DOFs * (i-1) + j 1086 IF ( t /= 0.d0 ) THEN 1087 MassMatrix(K,K) = MassMatrix(K,K) * s / t 1088 END IF 1089 END DO 1090 END DO 1091 1092 s = 0.d0 1093 t = 0.d0 1094 DO i=1,n*DOFs 1095 DO j=1,n*DOFs 1096 s = s + DampMatrix(i,j) 1097 IF (i /= j) THEN 1098 DampMatrix(i,j) = 0.d0 1099 END IF 1100 END DO 1101 t = t + DampMatrix(i,i) 1102 END DO 1103 1104 DO i=1,n 1105 DO j=1,DOFs 1106 K = DOFs * (i-1) + j 1107 IF ( t /= 0.d0 ) THEN 1108 DampMatrix(K,K) = DampMatrix(K,K) * s / t 1109 END IF 1110 END DO 1111 END DO 1112#else 1113!------------------------------------------------------------------------------ 1114! Lump the second order time derivative terms ... 1115!------------------------------------------------------------------------------ 1116 DO i=1,n*DOFs 1117 s = 0.0D0 1118 DO j=1,n*DOFs 1119 s = s + MassMatrix(i,j) 1120 MassMatrix(i,j) = 0.0d0 1121 END DO 1122 MassMatrix(i,i) = s 1123 END DO 1124 1125!------------------------------------------------------------------------------ 1126! ... and the first order terms. 1127!------------------------------------------------------------------------------ 1128 DO i=1,n*DOFs 1129 s = 0.0D0 1130 DO j=1,n*DOFs 1131 s = s + DampMatrix(i,j) 1132 DampMatrix(i,j) = 0.0d0 1133 END DO 1134 DampMatrix(i,i) = s 1135 END DO 1136#endif 1137!------------------------------------------------------------------------------ 1138 END IF 1139!------------------------------------------------------------------------------ 1140 1141!------------------------------------------------------------------------------ 1142! Get previous solution vectors and update current force 1143!----------------------------------------------------------------------------- 1144 DO i=1,n 1145 DO j=1,DOFs 1146 K = DOFs * (i-1) + j 1147 IF ( NodeIndexes(i) > 0 ) THEN 1148 L = DOFs * (NodeIndexes(i)-1) + j 1149 SELECT CASE(Method) 1150 CASE DEFAULT 1151 X(K) = Solver % Variable % PrevValues(L,3) 1152 V(K) = Solver % Variable % PrevValues(L,4) 1153 A(K) = Solver % Variable % PrevValues(L,5) 1154 END SELECT 1155 END IF 1156 END DO 1157 END DO 1158 1159 LForce(1:n*DOFs) = Force(1:n*DOFs) 1160 CALL UpdateGlobalForce( Solver % Matrix % Force(:,1), LForce, & 1161 n, DOFs, NodeIndexes ) 1162!------------------------------------------------------------------------------ 1163 Method = ListGetString( Solver % Values, 'Timestepping Method', GotIt ) 1164 SELECT CASE(Method) 1165 CASE DEFAULT 1166 CALL Bossak2ndOrder( n*DOFs, dt, MassMatrix, DampMatrix, StiffMatrix, & 1167 Force, X, V, A, Solver % Alpha ) 1168 END SELECT 1169!------------------------------------------------------------------------------ 1170 END SUBROUTINE Add2ndOrderTime 1171!------------------------------------------------------------------------------ 1172 1173 1174!------------------------------------------------------------------------------ 1175!> Update the right-hand-side of the global equation by adding the local entry. 1176!------------------------------------------------------------------------------ 1177 SUBROUTINE UpdateTimeForce( StiffMatrix, & 1178 ForceVector, LocalForce, n, NDOFs, NodeIndexes ) 1179!------------------------------------------------------------------------------ 1180 TYPE(Matrix_t), POINTER :: StiffMatrix !< Global stiffness matrix. 1181 REAL(KIND=dp) :: LocalForce(:) !< Local right-hand-side vector. 1182 REAL(KIND=dp) :: ForceVector(:) !< Global right-hand-side vector. 1183 INTEGER :: n !< number of element nodes 1184 INTEGER :: nDOFs !< variable degrees of freedom 1185 INTEGER :: NodeIndexes(:) !< Element node to global node numbering mapping. 1186!------------------------------------------------------------------------------ 1187 INTEGER :: i,j,k 1188!------------------------------------------------------------------------------ 1189 CALL UpdateGlobalForce( StiffMatrix % Force(:,1), LocalForce, & 1190 n, NDOFs, NodeIndexes ) 1191 LocalForce = 0.0d0 1192!------------------------------------------------------------------------------ 1193 END SUBROUTINE UpdateTimeForce 1194!------------------------------------------------------------------------------ 1195 1196 1197 1198!------------------------------------------------------------------------------ 1199!> Add element local matrices & vectors to global matrices and vectors. 1200!------------------------------------------------------------------------------ 1201 SUBROUTINE UpdateGlobalEquations( StiffMatrix, LocalStiffMatrix, & 1202 ForceVector, LocalForce, n, NDOFs, NodeIndexes, RotateNT, UElement, & 1203 GlobalValues ) 1204!------------------------------------------------------------------------------ 1205 TYPE(Matrix_t), POINTER :: StiffMatrix !< The global matrix 1206 REAL(KIND=dp) :: LocalStiffMatrix(:,:) !< Local matrix to be added to the global matrix. 1207 REAL(KIND=dp) :: LocalForce(:) !< Element local force vector. 1208 REAL(KIND=dp) :: ForceVector(:) !< The global RHS vector. 1209 INTEGER :: n !< Number of nodes. 1210 INTEGER :: NDOFs !< Number of element nodes. 1211 INTEGER :: NodeIndexes(:) !< Element node to global node numbering mapping. 1212 LOGICAL, OPTIONAL :: RotateNT !< Should the global equation be done in local normal-tangential coordinates. 1213 TYPE(Element_t), OPTIONAL, TARGET :: UElement !< Element to be updated 1214 REAL(KIND=dp), OPTIONAL :: GlobalValues(:) 1215!------------------------------------------------------------------------------ 1216 INTEGER :: i,j,k,dim, Indexes(n) 1217 LOGICAL :: Rotate 1218 TYPE(Element_t), POINTER :: Element 1219!------------------------------------------------------------------------------ 1220! Update global matrix and rhs vector.... 1221!------------------------------------------------------------------------------ 1222 IF (PRESENT(UElement)) THEN 1223 Element => UElement 1224 ELSE 1225 Element => CurrentModel % CurrentElement 1226 END IF 1227!------------------------------------------------------------------------------ 1228! Check first if this element has been defined passive 1229!------------------------------------------------------------------------------ 1230 IF ( CheckPassiveElement(Element) ) RETURN 1231 1232!------------------------------------------------------------------------------ 1233 Rotate = .TRUE. 1234 IF ( PRESENT(RotateNT) ) Rotate = RotateNT 1235 1236 dim = CoordinateSystemDimension() 1237 IF ( Rotate .AND. NormalTangentialNOFNodes > 0 .AND. ndofs>=dim) THEN 1238 Indexes = 0 1239 Indexes(1:Element % TYPE % NumberOfNodes) = & 1240 BoundaryReorder(Element % NodeIndexes) 1241 CALL RotateMatrix( LocalStiffMatrix, LocalForce, n, dim, NDOFs, & 1242 Indexes, BoundaryNormals, BoundaryTangent1, BoundaryTangent2 ) 1243 END IF 1244!------------------------------------------------------------------------------ 1245 IF ( ASSOCIATED( StiffMatrix ) ) THEN 1246 SELECT CASE( StiffMatrix % FORMAT ) 1247 CASE( MATRIX_CRS ) 1248 CALL CRS_GlueLocalMatrix( StiffMatrix,n,NDOFs, & 1249 NodeIndexes, LocalStiffMatrix, GlobalValues ) 1250 1251 CASE( MATRIX_LIST ) 1252 CALL List_GlueLocalMatrix( StiffMatrix % ListMatrix,n,NDOFs,NodeIndexes, & 1253 LocalStiffMatrix ) 1254 1255 CASE( MATRIX_BAND,MATRIX_SBAND ) 1256 CALL Band_GlueLocalMatrix( StiffMatrix,n,NDOFs,NodeIndexes, & 1257 LocalStiffMatrix ) 1258 END SELECT 1259 END IF 1260 1261 DO i=1,n 1262 IF ( Nodeindexes(i) > 0 ) THEN 1263 DO j=1,NDOFs 1264 k = NDOFs * (NodeIndexes(i)-1) + j 1265!$omp atomic 1266 ForceVector(k) = ForceVector(k) + LocalForce(NDOFs*(i-1)+j) 1267 END DO 1268 END IF 1269 END DO 1270!------------------------------------------------------------------------------ 1271 END SUBROUTINE UpdateGlobalEquations 1272!------------------------------------------------------------------------------ 1273 1274 1275!> Add element local matrices & vectors to global matrices and vectors. 1276!> Vectorized version, does not support normal or tangential boundary 1277!> conditions yet. 1278 SUBROUTINE UpdateGlobalEquationsVec( Gmtr, Lmtr, Gvec, Lvec, n, & 1279 NDOFs, NodeIndexes, RotateNT, UElement, MCAssembly ) 1280 TYPE(Matrix_t), POINTER :: Gmtr !< The global matrix 1281 REAL(KIND=dp) CONTIG :: Lmtr(:,:) !< Local matrix to be added to the global matrix. 1282 REAL(KIND=dp) CONTIG :: Gvec(:) !< Element local force vector. 1283 REAL(KIND=dp) CONTIG :: Lvec(:) !< The global RHS vector. 1284 INTEGER :: n !< Number of nodes. 1285 INTEGER :: NDOFs !< Number of degrees of free per node. 1286 INTEGER CONTIG :: NodeIndexes(:) !< Element node to global node numbering mapping. 1287 LOGICAL, OPTIONAL :: RotateNT !< Should the global equation be done in local normal-tangential coordinates. 1288 TYPE(Element_t), OPTIONAL, TARGET :: UElement !< Element to be updated 1289 LOGICAL, OPTIONAL :: MCAssembly !< Assembly process is multicoloured and guaranteed race condition free 1290 1291 ! Local variables 1292 INTEGER :: dim, i,j,k 1293 INTEGER :: Ind(n*NDOFs) 1294 REAL(KIND=dp) :: Vals(n*NDOFs) 1295!DIR$ ATTRIBUTES ALIGN:64::Ind, Vals 1296 1297 TYPE(Element_t), POINTER :: Element 1298 LOGICAL :: Rotate 1299 LOGICAL :: ColouredAssembly, NeedMasking 1300 1301 IF (PRESENT(UElement)) THEN 1302 Element => UElement 1303 ELSE 1304 Element => CurrentModel % CurrentElement 1305 END IF 1306 1307 IF ( CheckPassiveElement(Element) ) RETURN 1308 Rotate = .TRUE. 1309 IF ( PRESENT(RotateNT) ) Rotate = RotateNT 1310 1311 ColouredAssembly = .FALSE. 1312 IF ( PRESENT(MCAssembly) ) ColouredAssembly = MCAssembly 1313 1314 dim = CoordinateSystemDimension() 1315 ! TEMP 1316 IF ( Rotate .AND. NormalTangentialNOFNodes > 0 .AND. ndofs>=dim) THEN 1317 1318 DO i=1,Element % TYPE % NumberOfNodes 1319 Ind(i) = BoundaryReorder(Element % NodeIndexes(i)) 1320 END DO 1321 1322 ! TODO: See that RotateMatrix is vectorized 1323 CALL RotateMatrix( Lmtr, Lvec, n, dim, NDOFs, Ind, BoundaryNormals, & 1324 BoundaryTangent1, BoundaryTangent2 ) 1325 1326 !IF ( Rotate .AND. NormalTangentialNOFNodes > 0 .AND. ndofs>=dim) THEN 1327 ! CALL Fatal('UpdateGlobalEquationsVec', & 1328 ! 'Normal or tangential boundary conditions not supported yet!') 1329 END IF 1330 1331 NeedMasking = .FALSE. 1332 DO i=1,n 1333 IF (NodeIndexes(i)<=0) THEN 1334 NeedMasking = .TRUE. 1335 EXIT 1336 END IF 1337 END DO 1338 1339 IF ( ASSOCIATED( Gmtr ) ) THEN 1340 SELECT CASE( Gmtr % FORMAT ) 1341 CASE( MATRIX_CRS ) 1342 CALL CRS_GlueLocalMatrixVec(Gmtr, n, NDOFs, NodeIndexes, Lmtr, ColouredAssembly, NeedMasking) 1343 CASE DEFAULT 1344 CALL Fatal('UpdateGlobalEquationsVec','Not implemented for given matrix type') 1345 END SELECT 1346 END IF 1347 1348 ! Check for multicolored assembly 1349 IF (ColouredAssembly) THEN 1350 IF (NeedMasking) THEN 1351 ! Vector masking needed, no ATOMIC needed 1352 !_ELMER_OMP_SIMD PRIVATE(j,k) 1353 DO i=1,n 1354 IF (NodeIndexes(i)>0) THEN 1355 DO j=1,NDOFs 1356 k = NDOFs*(NodeIndexes(i)-1) + j 1357 Gvec(k) = Gvec(k) + Lvec(NDOFs*(i-1)+j) 1358 END DO 1359 END IF 1360 END DO 1361 ELSE 1362 ! No vector masking needed, no ATOMIC needed 1363 IF (NDOFS>1) THEN 1364 !_ELMER_OMP_SIMD PRIVATE(j,k) 1365 DO i=1,n 1366 DO j=1,NDOFs 1367 k = NDOFs*(NodeIndexes(i)-1) + j 1368 Gvec(k) = Gvec(k) + Lvec(NDOFs*(i-1)+j) 1369 END DO 1370 END DO 1371 ELSE 1372 !_ELMER_OMP_SIMD 1373 DO i=1,n 1374 Gvec(NodeIndexes(i)) = Gvec(NodeIndexes(i)) + Lvec(i) 1375 END DO 1376 END IF 1377 END IF ! Vector masking 1378 ELSE 1379 IF (NeedMasking) THEN 1380 ! Vector masking needed, ATOMIC needed 1381 DO i=1,n 1382 IF (NodeIndexes(i)>0) THEN 1383!DIR$ IVDEP 1384 DO j=1,NDOFs 1385 k = NDOFs*(NodeIndexes(i)-1) + j 1386 !$OMP ATOMIC 1387 Gvec(k) = Gvec(k) + Lvec(NDOFs*(i-1)+j) 1388 END DO 1389 END IF 1390 END DO 1391 ELSE 1392 ! No vector masking needed, ATOMIC needed 1393 DO i=1,n 1394!DIR$ IVDEP 1395 DO j=1,NDOFs 1396 k = NDOFs*(NodeIndexes(i)-1) + j 1397 !$OMP ATOMIC 1398 Gvec(k) = Gvec(k) + Lvec(NDOFs*(i-1)+j) 1399 END DO 1400 END DO 1401 END IF ! Vector masking 1402 END IF ! Coloured assembly 1403 END SUBROUTINE UpdateGlobalEquationsVec 1404 1405!------------------------------------------------------------------------------ 1406!> Update the global vector with the local vector entry. 1407!------------------------------------------------------------------------------ 1408 SUBROUTINE UpdateGlobalForce(ForceVector, LocalForce, n, & 1409 NDOFs, NodeIndexes, RotateNT, UElement ) 1410!------------------------------------------------------------------------------ 1411 REAL(KIND=dp) :: LocalForce(:) !< Element local force vector. 1412 REAL(KIND=dp) :: ForceVector(:) !< The global RHS vector. 1413 INTEGER :: n !< Number of nodes. 1414 INTEGER :: NDOFs !< Number of element nodes. 1415 INTEGER :: NodeIndexes(:) !< Element node to global node numbering mapping. 1416 LOGICAL, OPTIONAL :: RotateNT !< Should the global equation be done in local normal-tangential coordinates. 1417 TYPE(Element_t), OPTIONAL, TARGET :: UElement !< Element to be updated 1418!------------------------------------------------------------------------------ 1419 TYPE(Element_t), POINTER :: Element 1420 INTEGER :: i,j,k, dim,indexes(n) 1421 LOGICAL :: Rotate 1422 REAL(KIND=dp) :: LocalStiffMatrix(n*NDOFs,n*NDOFs), LForce(n*NDOFs) 1423!------------------------------------------------------------------------------ 1424! Update global matrix and rhs vector.... 1425!------------------------------------------------------------------------------ 1426 IF (PRESENT(UElement)) THEN 1427 Element => UElement 1428 ELSE 1429 Element => CurrentModel % CurrentElement 1430 END IF 1431 1432 IF ( CheckPassiveElement( Element ) ) RETURN 1433 1434 Rotate = .TRUE. 1435 IF ( PRESENT(RotateNT) ) Rotate=RotateNT 1436 1437 IF ( Rotate .AND. NormalTangentialNOFNodes>0 ) THEN 1438 dim = CoordinateSystemDimension() 1439 Indexes = 0 1440 ! Element => CurrentModel % CurrentElement 1441 Indexes(1:Element % TYPE % NumberOfNodes) = & 1442 BoundaryReorder(Element % NodeIndexes) 1443 CALL RotateMatrix( LocalStiffMatrix, LocalForce, n, dim, NDOFs, & 1444 Indexes, BoundaryNormals, BoundaryTangent1, BoundaryTangent2 ) 1445 END IF 1446 1447 DO i=1,n 1448 IF ( NodeIndexes(i) > 0 ) THEN 1449 DO j=1,NDOFs 1450 k = NDOFs * (NodeIndexes(i)-1) + j 1451!$omp atomic 1452 ForceVector(k) = ForceVector(k) + LocalForce(NDOFs*(i-1)+j) 1453 END DO 1454 END IF 1455 END DO 1456!------------------------------------------------------------------------------ 1457 END SUBROUTINE UpdateGlobalForce 1458!------------------------------------------------------------------------------ 1459 1460 1461!> Updates the mass matrix only. 1462!------------------------------------------------------------------------------ 1463 SUBROUTINE UpdateMassMatrix( StiffMatrix, LocalMassMatrix, & 1464 n, NDOFs, NodeIndexes, GlobalValues ) 1465!------------------------------------------------------------------------------ 1466 TYPE(Matrix_t), POINTER :: StiffMatrix !< The global matrix structure 1467 REAL(KIND=dp) :: LocalMassMatrix(:,:) !< Local matrix to be added to the global matrix 1468 INTEGER :: n !< number of nodes in element 1469 INTEGER :: NDOFs !< number of DOFs per node 1470 INTEGER :: NodeIndexes(:) !< Element node to global node numbering mapping 1471 REAL(KIND=dp), OPTIONAL, TARGET :: GlobalValues(:) 1472!------------------------------------------------------------------------------ 1473 INTEGER :: i,j,k 1474 REAL(KIND=dp) :: s,t 1475!------------------------------------------------------------------------------ 1476! Check first if this element has been defined passive 1477!------------------------------------------------------------------------------ 1478 IF ( CheckPassiveElement() ) RETURN 1479 1480!------------------------------------------------------------------------------ 1481! Update global matrix and rhs vector.... 1482!------------------------------------------------------------------------------ 1483 1484 IF ( StiffMatrix % Lumped ) THEN 1485 s = 0.d0 1486 t = 0.d0 1487 DO i=1,n*NDOFs 1488 DO j=1,n*NDOFs 1489 s = s + LocalMassMatrix(i,j) 1490 IF (i /= j) LocalMassMatrix(i,j) = 0.0d0 1491 END DO 1492 t = t + LocalMassMatrix(i,i) 1493 END DO 1494 1495 DO i=1,n*NDOFs 1496 LocalMassMatrix(i,i) = LocalMassMatrix(i,i) * s / t 1497 END DO 1498 END IF 1499 1500 1501 SELECT CASE( StiffMatrix % Format ) 1502 CASE( MATRIX_CRS ) 1503 CALL CRS_GlueLocalMatrix( StiffMatrix, & 1504 n, NDOFs, NodeIndexes, LocalMassMatrix, GlobalValues ) 1505 1506! CASE( MATRIX_LIST ) 1507! CALL List_GlueLocalMatrix( StiffMatrix % ListMatrix, & 1508! n, NDOFs, NodeIndexes, LocalMassMatrix ) 1509 1510! CASE( MATRIX_BAND,MATRIX_SBAND ) 1511! CALL Band_GlueLocalMatrix( StiffMatrix, & 1512! n, NDOFs, NodeIndexes, LocalMassMatrix ) 1513 1514 CASE DEFAULT 1515 CALL FATAL( 'UpdateMassMatrix', 'Unexpected matrix format') 1516 END SELECT 1517!------------------------------------------------------------------------------ 1518 END SUBROUTINE UpdateMassMatrix 1519!------------------------------------------------------------------------------ 1520 1521 1522!------------------------------------------------------------------------------ 1523!> Determine soft limiters set. This is called after the solution. 1524!> and can therefore be active only on the 2nd nonlinear iteration round. 1525!------------------------------------------------------------------------------ 1526 SUBROUTINE DetermineSoftLimiter( Solver ) 1527!------------------------------------------------------------------------------ 1528 TYPE(Solver_t) :: Solver 1529!----------------------------------------------------------------------------- 1530 TYPE(Model_t), POINTER :: Model 1531 TYPE(variable_t), POINTER :: Var, LoadVar, IterV, LimitVar 1532 TYPE(Element_t), POINTER :: Element 1533 INTEGER :: i,j,k,n,t,ind,dofs, dof, bf, bc, Upper, Removed, Added, & 1534 ElemFirst, ElemLast, totsize, i2, j2, ind2 1535 REAL(KIND=dp), POINTER :: FieldValues(:), LoadValues(:), & 1536 ElemLimit(:),ElemInit(:), ElemActive(:) 1537 REAL(KIND=dp) :: LimitSign, EqSign, ValEps, LoadEps, val 1538 INTEGER, POINTER :: FieldPerm(:), NodeIndexes(:) 1539 LOGICAL :: Found,AnyLimitBC, AnyLimitBF, GotInit, GotActive 1540 LOGICAL, ALLOCATABLE :: LimitDone(:) 1541 LOGICAL, POINTER :: LimitActive(:) 1542 TYPE(ValueList_t), POINTER :: Params, Entity 1543 CHARACTER(LEN=MAX_NAME_LEN) :: Name, LimitName, InitName, ActiveName 1544 LOGICAL, ALLOCATABLE :: InterfaceDof(:) 1545 INTEGER :: ConservativeAfterIters, NonlinIter, CoupledIter, DownStreamDirection 1546 LOGICAL :: Conservative, ConservativeAdd, ConservativeRemove, & 1547 DoAdd, DoRemove, DirectionActive, FirstTime, DownStreamRemove 1548 TYPE(Mesh_t), POINTER :: Mesh 1549 CHARACTER(*), PARAMETER :: Caller = 'DetermineSoftLimiter' 1550 1551 Model => CurrentModel 1552 Var => Solver % Variable 1553 Mesh => Solver % Mesh 1554 1555 1556 ! Check the iterations counts and determine whether this is the first 1557 ! time with this solver. 1558 !------------------------------------------------------------------------ 1559 FirstTime = .TRUE. 1560 iterV => VariableGet( Mesh % Variables,'nonlin iter') 1561 IF( ASSOCIATED( iterV ) ) THEN 1562 NonlinIter = NINT( iterV % Values(1) ) 1563 IF( NonlinIter > 1 ) FirstTime = .FALSE. 1564 END IF 1565 1566 iterV => VariableGet( Mesh % Variables,'coupled iter') 1567 IF( ASSOCIATED( iterV ) ) THEN 1568 CoupledIter = NINT( iterV % Values(1) ) 1569 IF( CoupledIter > 1 ) FirstTime = .FALSE. 1570 END IF 1571 1572 ! Determine variable for computing the contact load used to determine the 1573 ! soft limit set. 1574 !------------------------------------------------------------------------ 1575 CALL Info(Caller,'Determining soft limiter problems',Level=8) 1576 LoadVar => VariableGet( Model % Variables, & 1577 GetVarName(Var) // ' Contact Load',ThisOnly = .TRUE. ) 1578 CALL CalculateLoads( Solver, Solver % Matrix, Var % Values, Var % DOFs, .FALSE., LoadVar ) 1579 1580 IF( .NOT. ASSOCIATED( LoadVar ) ) THEN 1581 CALL Fatal(Caller, & 1582 'No Loads associated with variable '//GetVarName(Var) ) 1583 RETURN 1584 END IF 1585 LoadValues => LoadVar % Values 1586 1587 1588 ! The variable to be constrained by the soft limiters 1589 FieldValues => Var % Values 1590 FieldPerm => Var % Perm 1591 totsize = SIZE( FieldValues ) 1592 dofs = Var % Dofs 1593 Params => Solver % Values 1594 1595 ConservativeAdd = .FALSE. 1596 ConservativeAfterIters = ListGetInteger(Params,& 1597 'Apply Limiter Conservative Add After Iterations',Conservative ) 1598 IF( Conservative ) THEN 1599 ConservativeAdd = ( ConservativeAfterIters < NonlinIter ) 1600 IF( ConservativeAdd ) THEN 1601 CALL Info(Caller,'Adding dofs in conservative fashion',Level=8) 1602 END IF 1603 END IF 1604 1605 ConservativeRemove = .FALSE. 1606 ConservativeAfterIters = ListGetInteger(Params,& 1607 'Apply Limiter Conservative Remove After Iterations',Found ) 1608 IF( Found ) THEN 1609 Conservative = .TRUE. 1610 ConservativeRemove = ( ConservativeAfterIters < NonlinIter ) 1611 IF( ConservativeRemove ) THEN 1612 CALL Info(Caller,'Removing dofs in conservative fashion',Level=8) 1613 END IF 1614 END IF 1615 1616 DownStreamRemove = ListGetLogical( Params,'Apply Limiter Remove Downstream',Found) 1617 IF( DownStreamRemove ) THEN 1618 CALL Info(Caller,'Removing contact dofs only in downstream',Level=8) 1619 ConservativeRemove = .TRUE. 1620 Conservative = .TRUE. 1621 DownStreamDirection = ListGetInteger( Params,'Apply Limiter Downstream Direction',Found) 1622 IF(.NOT. Found ) DownStreamDirection = 1 1623 END IF 1624 1625 LoadEps = ListGetConstReal(Params,'Limiter Load Tolerance',Found ) 1626 IF(.NOT. Found ) LoadEps = EPSILON( LoadEps ) 1627 1628 ValEps = ListGetConstReal(Params,'Limiter Value Tolerance',Found ) 1629 IF(.NOT. Found ) ValEps = EPSILON( ValEps ) 1630 1631 ! The user may want to toggle the sign for various kinds of equations 1632 ! The default sign that come from standard formulation of Laplace equation. 1633 !--------------------------------------------------------------------------- 1634 IF( ListGetLogical( Params,'Limiter Load Sign Negative',Found) ) THEN 1635 EqSign = -1.0_dp 1636 ELSE 1637 EqSign = 1.0_dp 1638 END IF 1639 1640 ! Loop through upper and lower limits 1641 !------------------------------------------------------------------------ 1642 DO Upper=0,1 1643 1644 DirectionActive = .FALSE. 1645 1646 ! If we have both upper and lower limiter then these logical vectors need to be 1647 ! reinitialized for the 2nd sweep. 1648 IF( ALLOCATED( LimitDone) ) LimitDone = .FALSE. 1649 IF( ALLOCATED( InterfaceDof ) ) InterfaceDof = .FALSE. 1650 1651 ! Upper and lower limits have different sign for testing 1652 !---------------------------------------------------------------------- 1653 IF( Upper == 0 ) THEN 1654 LimitSign = -EqSign 1655 ELSE 1656 LimitSign = EqSign 1657 END IF 1658 1659 ! Go through the components of the field, if many 1660 !------------------------------------------------- 1661 DO DOF = 1,dofs 1662 1663 name = Var % name 1664 IF ( Var % DOFs > 1 ) name = ComponentName(name,DOF) 1665 1666 ! The keywords for the correct lower or upper limit of the variable 1667 !------------------------------------------------------------------ 1668 IF( Upper == 0 ) THEN 1669 LimitName = TRIM(name)//' Lower Limit' 1670 InitName = TRIM(name)//' Lower Initial' 1671 ActiveName = TRIM(name)//' Lower Active' 1672 ELSE 1673 LimitName = TRIM(name)//' Upper Limit' 1674 InitName = TRIM(name)//' Upper Initial' 1675 ActiveName = TRIM(name)//' Upper Active' 1676 END IF 1677 1678 AnyLimitBC = ListCheckPresentAnyBC( Model, LimitName ) 1679 AnyLimitBF = ListCheckPresentAnyBodyForce( Model, LimitName ) 1680 1681 ! If there is no active keyword then there really is nothing to do 1682 !---------------------------------------------------------------- 1683 IF( .NOT. ( AnyLimitBC .OR. AnyLimitBF ) ) CYCLE 1684 DirectionActive = .TRUE. 1685 1686 CALL Info(Caller,'Applying limit: '//TRIM(LimitName),Level=8) 1687 1688 ! OK: Do contact for a particular dof and only upper or lower limit 1689 !------------------------------------------------------------------------ 1690 1691 ! Define the range of elements for which the limiters are active 1692 !--------------------------------------------------------------- 1693 ElemFirst = Model % NumberOfBulkElements + 1 1694 ElemLast = Model % NumberOfBulkElements 1695 1696 IF( AnyLimitBF ) ElemFirst = 1 1697 IF( AnyLimitBC ) ElemLast = Model % NumberOfBulkElements + & 1698 Model % NumberOfBoundaryElements 1699 1700 IF(.NOT. ALLOCATED( LimitDone) ) THEN 1701 n = Model % MaxElementNodes 1702 ALLOCATE( LimitDone( totsize ), ElemLimit(n), ElemInit(n), ElemActive(n) ) 1703 LimitDone = .FALSE. 1704 END IF 1705 1706 ! Check that active set vectors for limiters exist, otherwise allocate 1707 !--------------------------------------------------------------------- 1708 IF( Upper == 0 ) THEN 1709 IF( .NOT. ASSOCIATED(Var % LowerLimitActive ) ) THEN 1710 ALLOCATE( Var % LowerLimitActive( totsize ) ) 1711 Var % LowerLimitActive = .FALSE. 1712 END IF 1713 LimitActive => Var % LowerLimitActive 1714 ELSE 1715 IF( .NOT. ASSOCIATED( Var % UpperLimitActive ) ) THEN 1716 ALLOCATE( Var % UpperLimitActive( totsize ) ) 1717 Var % UpperLimitActive = .FALSE. 1718 END IF 1719 LimitActive => Var % UpperLimitActive 1720 END IF 1721 1722 Removed = 0 1723 Added = 0 1724 IF(.NOT. ALLOCATED( LimitDone) ) THEN 1725 n = Model % MaxElementNodes 1726 ALLOCATE( LimitDone( totsize ), ElemLimit(n), ElemInit(n), ElemActive(n) ) 1727 LimitDone = .FALSE. 1728 END IF 1729 1730 1731 IF( FirstTime ) THEN 1732 ! In the first time set the initial set 1733 !---------------------------------------------------------------------- 1734 DO t = ElemFirst, ElemLast 1735 1736 Element => Model % Elements(t) 1737 Model % CurrentElement => Element 1738 1739 n = Element % TYPE % NumberOfNodes 1740 NodeIndexes => Element % NodeIndexes 1741 1742 Found = .FALSE. 1743 IF( t > Model % NumberOfBulkElements ) THEN 1744 DO bc = 1,Model % NumberOfBCs 1745 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 1746 Found = .TRUE. 1747 Entity => Model % BCs(bc) % Values 1748 EXIT 1749 END IF 1750 END DO 1751 IF(.NOT. Found ) CYCLE 1752 ELSE 1753 bf = ListGetInteger( Model % Bodies(Element % bodyid) % Values, & 1754 'Body Force', Found) 1755 IF(.NOT. Found ) CYCLE 1756 Entity => Model % BodyForces(bf) % Values 1757 END IF 1758 1759 ElemLimit(1:n) = ListGetReal( Entity, & 1760 LimitName, n, NodeIndexes, Found) 1761 IF(.NOT. Found) CYCLE 1762 1763 ElemInit(1:n) = ListGetReal( Entity, & 1764 InitName, n, NodeIndexes, GotInit) 1765 ElemActive(1:n) = ListGetReal( Entity, & 1766 ActiveName, n, NodeIndexes, GotActive) 1767 IF(.NOT. ( GotInit .OR. GotActive ) ) CYCLE 1768 1769 1770 DO i=1,n 1771 j = FieldPerm( NodeIndexes(i) ) 1772 IF( j == 0 ) CYCLE 1773 ind = Dofs * ( j - 1) + Dof 1774 1775 IF( LimitDone(ind) ) CYCLE 1776 1777 ! Go through the active set and free nodes with wrong sign in contact force 1778 !-------------------------------------------------------------------------- 1779 IF( GotInit .AND. ElemInit(i) > 0.0_dp ) THEN 1780 added = added + 1 1781 LimitActive(ind) = .TRUE. 1782 ELSE IF( GotActive .AND. ElemActive(i) > 0.0_dp ) THEN 1783 added = added + 1 1784 LimitActive(ind) = .TRUE. 1785 ELSE 1786 LimitActive(ind) = .FALSE. 1787 END IF 1788 1789 ! Enforce the values to limits because nonlinear material models 1790 ! may otherwise lead to divergence of the iteration 1791 !-------------------------------------------------------------- 1792 IF( LimitActive(ind) ) THEN 1793 IF( Upper == 0 ) THEN 1794 Var % Values(ind) = MAX( val, ElemLimit(i) ) 1795 ELSE 1796 Var % Values(ind) = MIN( val, ElemLimit(i) ) 1797 END IF 1798 END IF 1799 1800 LimitDone(ind) = .TRUE. 1801 END DO 1802 END DO 1803 1804 CYCLE 1805 END IF 1806 1807 1808 IF( Conservative ) THEN 1809 IF(.NOT. ALLOCATED( InterfaceDof ) ) THEN 1810 ALLOCATE( InterfaceDof( totsize ) ) 1811 InterfaceDof = .FALSE. 1812 END IF 1813 1814 1815 ! Mark limited and unlimited neighbours and thereby make a 1816 ! list of interface dofs. 1817 !---------------------------------------------------------------------- 1818 DO t = ElemFirst, ElemLast 1819 1820 Element => Model % Elements(t) 1821 Model % CurrentElement => Element 1822 n = Element % TYPE % NumberOfNodes 1823 NodeIndexes => Element % NodeIndexes 1824 1825 Found = .FALSE. 1826 IF( t > Model % NumberOfBulkElements ) THEN 1827 DO bc = 1,Model % NumberOfBCs 1828 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 1829 Found = .TRUE. 1830 Entity => Model % BCs(bc) % Values 1831 EXIT 1832 END IF 1833 END DO 1834 IF(.NOT. Found ) CYCLE 1835 ELSE 1836 bf = ListGetInteger( Model % Bodies(Element % bodyid) % Values, & 1837 'Body Force', Found) 1838 IF(.NOT. Found ) CYCLE 1839 Entity => Model % BodyForces(bf) % Values 1840 END IF 1841 1842 ElemLimit(1:n) = ListGetReal( Entity, & 1843 LimitName, n, NodeIndexes, Found) 1844 IF(.NOT. Found) CYCLE 1845 1846 1847 IF( DownStreamRemove ) THEN 1848 ! This includes only interface dofs donwstream from 1849 ! non-contact zone. 1850 BLOCK 1851 REAL(kind=DP) :: r1(3),r2(3),dr(3),reps=1.0d-6 1852 1853 DO i=1,n 1854 j = FieldPerm( NodeIndexes(i) ) 1855 IF( j == 0 ) CYCLE 1856 ind = Dofs * ( j - 1) + Dof 1857 1858 ! Downstream of non-contact zone 1859 IF(LimitActive(ind)) CYCLE 1860 1861 DO i2 = i,n 1862 IF( i2 == i ) CYCLE 1863 j2 = FieldPerm( NodeIndexes(i2) ) 1864 IF( j2 == 0 ) CYCLE 1865 ind2 = Dofs * ( j2 - 1) + Dof 1866 1867 IF( LimitActive(ind2) ) THEN 1868 r2(1) = Mesh % Nodes % x(NodeIndexes(i2)) 1869 r2(2) = Mesh % Nodes % y(NodeIndexes(i2)) 1870 r2(3) = Mesh % Nodes % z(NodeIndexes(i2)) 1871 1872 r1(1) = Mesh % Nodes % x(NodeIndexes(i)) 1873 r1(2) = Mesh % Nodes % y(NodeIndexes(i)) 1874 r1(3) = Mesh % Nodes % z(NodeIndexes(i)) 1875 1876 k = DownStreamDirection 1877 IF( k > 0 ) THEN 1878 dr = r2 - r1 1879 ELSE 1880 dr = r1 - r2 1881 k = -k 1882 END IF 1883 1884 IF( dr(k) < reps ) CYCLE 1885 1886 IF( dr(k) > 0.5*SQRT(SUM(dr*dr)) ) THEN 1887 InterfaceDof(ind2) = .TRUE. 1888 !PRINT *,'downstream coord:',dr 1889 END IF 1890 END IF 1891 END DO 1892 END DO 1893 END BLOCK 1894 ELSE 1895 ! This includes all interface dofs 1896 DO i=1,n 1897 j = FieldPerm( NodeIndexes(i) ) 1898 IF( j == 0 ) CYCLE 1899 ind = Dofs * ( j - 1) + Dof 1900 1901 DO i2 = i+1,n 1902 j2 = FieldPerm( NodeIndexes(i2) ) 1903 IF( j2 == 0 ) CYCLE 1904 ind2 = Dofs * ( j2 - 1) + Dof 1905 1906 IF( LimitActive(ind) .NEQV. LimitActive(ind2) ) THEN 1907 InterfaceDof(ind) = .TRUE. 1908 InterfaceDof(ind2) = .TRUE. 1909 END IF 1910 END DO 1911 END DO 1912 END IF 1913 END DO 1914 1915 CALL Info(Caller,& 1916 'Number of interface dofs: '//TRIM(I2S(COUNT(InterfaceDof))),Level=8) 1917 END IF 1918 1919 IF( DownStreamRemove ) THEN 1920 t = COUNT(InterfaceDof) 1921 CALL Info(Caller,'Downstream contact set dofs:'//TRIM(I2S(t)),Level=8) 1922 END IF 1923 1924 1925 ! Add and release dofs from the contact set: 1926 ! If it is removed it cannot be added. 1927 !---------------------------------------------------------------------- 1928 DO t = ElemFirst, ElemLast 1929 1930 Element => Model % Elements(t) 1931 Model % CurrentElement => Element 1932 n = Element % TYPE % NumberOfNodes 1933 NodeIndexes => Element % NodeIndexes 1934 1935 Found = .FALSE. 1936 IF( t > Model % NumberOfBulkElements ) THEN 1937 DO bc = 1,Model % NumberOfBCs 1938 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 1939 Found = .TRUE. 1940 Entity => Model % BCs(bc) % Values 1941 EXIT 1942 END IF 1943 END DO 1944 IF(.NOT. Found ) CYCLE 1945 ELSE 1946 bf = ListGetInteger( Model % Bodies(Element % bodyid) % Values, & 1947 'Body Force', Found) 1948 IF(.NOT. Found ) CYCLE 1949 Entity => Model % BodyForces(bf) % Values 1950 END IF 1951 1952 ElemLimit(1:n) = ListGetReal( Entity, & 1953 LimitName, n, NodeIndexes, Found) 1954 IF(.NOT. Found) CYCLE 1955 1956 ElemActive(1:n) = ListGetReal( Entity, & 1957 ActiveName, n, NodeIndexes, GotActive) 1958 1959 DO i=1,n 1960 j = FieldPerm( NodeIndexes(i) ) 1961 IF( j == 0 ) CYCLE 1962 ind = Dofs * ( j - 1) + Dof 1963 1964 IF( LimitDone(ind) ) CYCLE 1965 1966 ! Go through the active set and free nodes with wrong sign in contact force 1967 !-------------------------------------------------------------------------- 1968 IF( GotActive .AND. ElemActive(i) > 0.0_dp ) THEN 1969 IF(.NOT. LimitActive( ind ) ) THEN 1970 added = added + 1 1971 LimitActive(ind) = .TRUE. 1972 END IF 1973 ELSE IF( LimitActive( ind ) ) THEN 1974 DoRemove = ( LimitSign * LoadValues(ind) > LimitSign * LoadEps ) 1975 IF( DoRemove ) THEN 1976 ! In the conservative mode only release nodes from contact set 1977 ! when they are adjacent to dofs that previously was not in the set. 1978 ! This means that set is released only at the boundaries. 1979 IF( ConservativeRemove ) DoRemove = InterfaceDof( ind ) 1980 IF( DoRemove ) THEN 1981 removed = removed + 1 1982 LimitActive(ind) = .FALSE. 1983 CYCLE 1984 END IF 1985 END IF 1986 ELSE 1987 ! Go through the dofs that are beyond the contact surface. 1988 !----------------------------------------------------------- 1989 val = Var % Values(ind) 1990 IF( Upper == 0 ) THEN 1991 DoAdd = ( val < ElemLimit(i) - ValEps ) 1992 ELSE 1993 DoAdd = ( val > ElemLimit(i) + ValEps ) 1994 END IF 1995 1996 IF( DoAdd ) THEN 1997 IF( ConservativeAdd ) DoAdd = InterfaceDof( ind ) 1998 IF( DoAdd ) THEN 1999 IF( .NOT. LimitActive(ind) ) THEN 2000 added = added + 1 2001 LimitActive(ind) = .TRUE. 2002 END IF 2003 END IF 2004 END IF 2005 END IF 2006 2007 ! Enforce the values to limits because nonlinear material models 2008 ! may otherwise lead to divergence of the iteration 2009 !-------------------------------------------------------------- 2010 IF( LimitActive(ind) ) THEN 2011 IF( Upper == 0 ) THEN 2012 Var % Values(ind) = MAX( val, ElemLimit(i) ) 2013 ELSE 2014 Var % Values(ind) = MIN( val, ElemLimit(i) ) 2015 END IF 2016 END IF 2017 2018 LimitDone(ind) = .TRUE. 2019 END DO 2020 END DO 2021 END DO 2022 2023 IF( DirectionActive ) THEN 2024 ! Output some information before exiting 2025 !--------------------------------------------------------------------- 2026 IF( Upper == 0 ) THEN 2027 CALL Info(Caller,'Determined lower soft limit set',Level=6) 2028 ELSE 2029 CALL Info(Caller,'Determined upper soft limit set',Level=6) 2030 END IF 2031 2032 WRITE(Message,'(A,I0)') 'Number of limited dofs for '& 2033 //TRIM(GetVarName(Var))//': ',COUNT( LimitActive ) 2034 CALL Info(Caller,Message,Level=5) 2035 2036 IF(added >= 0) THEN 2037 WRITE(Message,'(A,I0,A)') 'Added ',added,' dofs to the set' 2038 CALL Info(Caller,Message,Level=6) 2039 END IF 2040 2041 IF(removed >= 0) THEN 2042 WRITE(Message,'(A,I0,A)') 'Removed ',removed,' dofs from the set' 2043 CALL Info(Caller,Message,Level=6) 2044 END IF 2045 END IF 2046 END DO 2047 2048 ! Optionally save the limiters as a field variable so that 2049 ! lower limit is given value -1.0 and upper limit value +1.0. 2050 IF( ListGetLogical( Params,'Save Limiter',Found ) ) THEN 2051 2052 LimitVar => VariableGet( Model % Variables, & 2053 GetVarName(Var) // ' Contact Active',ThisOnly = .TRUE. ) 2054 IF(.NOT. ASSOCIATED( LimitVar ) ) THEN 2055 CALL Info(Caller,'Creating field for contact: '//TRIM(GetVarName(Var)),Level=7) 2056 CALL VariableAddVector( Model % Variables, Solver % Mesh, Solver,& 2057 GetVarName(Var) //' Contact Active', Perm = FieldPerm ) 2058 LimitVar => VariableGet( Model % Variables, & 2059 GetVarName(Var) // ' Contact Active',ThisOnly = .TRUE. ) 2060 END IF 2061 2062 ! Currently the visulized limit is always scalar even though the limited field could be a vector! 2063 DO i = 1, SIZE( LimitVar % Values ) 2064 LimitVar % Values(i) = 0.0_dp 2065 DO j=1,Var % Dofs 2066 IF( ASSOCIATED( Var % LowerLimitActive ) ) THEN 2067 IF( Var % LowerLimitActive(Var%Dofs*(i-1)+j) ) LimitVar % Values(i) = -1.0_dp 2068 END IF 2069 IF( ASSOCIATED( Var % UpperLimitActive ) ) THEN 2070 IF( Var % UpperLimitActive(Var%Dofs*(i-1)+j) ) LimitVar % Values(i) = 1.0_dp 2071 END IF 2072 END DO 2073 END DO 2074 END IF 2075 2076 IF( ALLOCATED( LimitDone ) ) THEN 2077 DEALLOCATE( LimitDone, ElemLimit, ElemInit, ElemActive ) 2078 END IF 2079 2080 IF( ALLOCATED( InterfaceDof ) ) THEN 2081 DEALLOCATE( InterfaceDof ) 2082 END IF 2083 2084 CALL Info(Caller,'All done',Level=12) 2085 2086 END SUBROUTINE DetermineSoftLimiter 2087!------------------------------------------------------------------------------ 2088 2089 2090!------------------------------------------------------------------------------ 2091!> Subroutine for determine the contact set and create the necessary data 2092!> for setting up the contact conditions. As input the mortar projectors, 2093!> the current solution, and the stiffness matrix are used. 2094!------------------------------------------------------------------------------ 2095 SUBROUTINE DetermineContact( Solver ) 2096!------------------------------------------------------------------------------ 2097 TYPE(Solver_t) :: Solver 2098!----------------------------------------------------------------------------- 2099 TYPE(Model_t), POINTER :: Model 2100 TYPE(variable_t), POINTER :: Var, LoadVar, IterVar 2101 TYPE(Variable_t), POINTER :: DistVar, NormalLoadVar, SlipLoadVar, VeloVar, & 2102 WeightVar, NormalActiveVar, StickActiveVar, GapVar 2103 TYPE(Element_t), POINTER :: Element 2104 TYPE(Mesh_t), POINTER :: Mesh 2105 INTEGER :: i,j,k,l,n,m,t,ind,dofs, bf, Upper, & 2106 ElemFirst, ElemLast, totsize, i2, j2, ind2, bc_ind, master_ind, & 2107 DistSign, LimitSign, DofN, DofT1, DofT2, Limited, LimitedMin, TimeStep 2108 REAL(KIND=dp), POINTER :: FieldValues(:), LoadValues(:), ElemLimit(:),pNormal(:,:),& 2109 RotatedField(:) 2110 REAL(KIND=dp) :: ValEps, LoadEps, val, ContactNormal(3), & 2111 ContactT1(3), ContactT2(3), LocalT1(3), LocalT2(3), & 2112 LocalNormal(3), NodalForce(3), wsum, coeff, & 2113 Dist, DistN, DistT1, DistT2, NTT(3,3), RotVec(3), dt 2114 INTEGER, POINTER :: FieldPerm(:), NodeIndexes(:) 2115 LOGICAL :: Found,AnyLimitBC, AnyLimitBF 2116 LOGICAL, ALLOCATABLE :: LimitDone(:),InterfaceDof(:) 2117 LOGICAL, POINTER :: LimitActive(:) 2118 TYPE(ValueList_t), POINTER :: Params 2119 CHARACTER(LEN=MAX_NAME_LEN) :: Str, LimitName, VarName, ContactType 2120 INTEGER :: ConservativeAfterIters, ActiveDirection, NonlinIter, CoupledIter 2121 LOGICAL :: ConservativeAdd, ConservativeRemove, & 2122 DoAdd, DoRemove, DirectionActive, Rotated, FlatProjector, PlaneProjector, & 2123 RotationalProjector, NormalProjector, FirstTime = .TRUE., & 2124 AnyRotatedContact, ThisRotatedContact, StickContact, TieContact, FrictionContact, SlipContact, & 2125 CalculateVelocity, NodalNormal, ResidualMode, AddDiag, SkipFriction, DoIt 2126 TYPE(MortarBC_t), POINTER :: MortarBC 2127 TYPE(Matrix_t), POINTER :: Projector, DualProjector 2128 TYPE(ValueList_t), POINTER :: BC, MasterBC 2129 REAL(KIND=dp), POINTER :: nWrk(:,:) 2130 LOGICAL :: CreateDual 2131 CHARACTER(*), PARAMETER :: Caller = 'DetermineContact' 2132 2133 2134 SAVE FirstTime 2135 2136 CALL Info(Caller,'Setting up contact conditions',Level=8) 2137 2138 Model => CurrentModel 2139 Var => Solver % Variable 2140 VarName = GetVarName( Var ) 2141 Mesh => Solver % Mesh 2142 2143 ! Is any boundary rotated or not 2144 AnyRotatedContact = ( NormalTangentialNOFNodes > 0 ) 2145 2146 ! The variable to be constrained by the contact algorithm 2147 ! Here it is assumed to be some "displacement" i.e. a vector quantity 2148 FieldValues => Var % Values 2149 FieldPerm => Var % Perm 2150 totsize = SIZE( FieldValues ) 2151 dofs = Var % Dofs 2152 Params => Solver % Values 2153 2154 IterVar => VariableGet( Model % Variables,'coupled iter') 2155 CoupledIter = NINT( IterVar % Values(1) ) 2156 2157 IterVar => VariableGet( Model % Variables,'nonlin iter') 2158 NonlinIter = NINT( IterVar % Values(1) ) 2159 2160 IterVar => VariableGet( Model % Variables,'timestep') 2161 Timestep = NINT( IterVar % Values(1) ) 2162 2163 IterVar => VariableGet( Mesh % Variables,'timestep size') 2164 IF( ASSOCIATED( IterVar ) ) THEN 2165 dt = IterVar % Values(1) 2166 ELSE 2167 dt = 1.0_dp 2168 END IF 2169 2170 !FirstTime = ( NonlinIter == 1 .AND. CoupledIter == 1 ) 2171 2172 ConservativeAfterIters = ListGetInteger(Params,& 2173 'Apply Limiter Conservative Add After Iterations',ConservativeAdd ) 2174 IF( ConservativeAdd ) THEN 2175 IF( CoupledIter == 1 ) ConservativeAdd = ( ConservativeAfterIters < NonlinIter ) 2176 IF( ConservativeAdd ) THEN 2177 CALL Info(Caller,'Adding dofs in conservative fashion',Level=8) 2178 END IF 2179 END IF 2180 2181 ConservativeAfterIters = ListGetInteger(Params,& 2182 'Apply Limiter Conservative Remove After Iterations',ConservativeRemove ) 2183 IF( ConservativeRemove ) THEN 2184 IF( CoupledIter == 1 ) ConservativeRemove = ( ConservativeAfterIters < NonlinIter ) 2185 IF( ConservativeRemove ) THEN 2186 CALL Info(Caller,'Removing dofs in conservative fashion',Level=8) 2187 END IF 2188 END IF 2189 2190 ResidualMode = ListGetLogical(Params,& 2191 'Linear System Residual Mode',Found ) 2192 2193 CalculateVelocity = ListGetLogical(Params,& 2194 'Apply Contact Velocity',Found ) 2195 IF(.NOT. Found ) THEN 2196 Str = ListGetString( CurrentModel % Simulation, 'Simulation Type' ) 2197 CalculateVelocity = ( Str == 'transient' ) 2198 END IF 2199 2200 NodalNormal = ListGetLogical(Params,& 2201 'Use Nodal Normal',Found ) 2202 2203 LoadEps = ListGetConstReal(Params,'Limiter Load Tolerance',Found ) 2204 IF(.NOT. Found ) LoadEps = EPSILON( LoadEps ) 2205 2206 ValEps = ListGetConstReal(Params,'Limiter Value Tolerance',Found ) 2207 IF(.NOT. Found ) ValEps = EPSILON( ValEps ) 2208 2209 IF( .NOT. ASSOCIATED( Model % Solver % MortarBCs ) ) THEN 2210 CALL Fatal(Caller,'Cannot apply contact without projectors!') 2211 END IF 2212 2213 ! a) Create rotateted contact if needed 2214 CALL RotatedDisplacementField() 2215 2216 ! b) Create and/or obtain pointers to boundary variables 2217 CALL GetContactFields( FirstTime ) 2218 2219 ! c) Calculate the contact loads to the normal direction 2220 LoadVar => CalculateContactLoad() 2221 LoadValues => LoadVar % Values 2222 2223 2224 ! Loop over each contact pair 2225 !-------------------------------------------------------------- 2226 DO bc_ind = 1, Model % NumberOfBCs 2227 2228 MortarBC => Model % Solver % MortarBCs(bc_ind) 2229 IF( .NOT. ASSOCIATED( MortarBC ) ) CYCLE 2230 2231 Projector => MortarBC % Projector 2232 IF(.NOT. ASSOCIATED(Projector) ) CYCLE 2233 2234 BC => Model % BCs(bc_ind) % Values 2235 2236 CALL Info(Caller,'Set contact for boundary: '& 2237 //TRIM(I2S(bc_ind)),Level=8) 2238 Model % Solver % MortarBCsChanged = .TRUE. 2239 2240 FlatProjector = ListGetLogical( BC, 'Flat Projector',Found ) 2241 PlaneProjector = ListGetLogical( BC, 'Plane Projector',Found ) 2242 RotationalProjector = ListGetLogical( BC, 'Rotational Projector',Found ) .OR. & 2243 ListGetLogical( BC, 'Cylindrical Projector',Found ) 2244 NormalProjector = ListGetLogical( BC, 'Normal Projector',Found ) 2245 2246 ! Is the current boundary rotated or not 2247 ThisRotatedContact = ListGetLogical( BC,'Normal-Tangential '//TRIM(VarName),Found) 2248 2249 IF( FlatProjector ) THEN 2250 ActiveDirection = ListGetInteger( BC, 'Flat Projector Coordinate',Found ) 2251 IF( .NOT. Found ) ActiveDirection = dofs 2252 ELSE IF( PlaneProjector ) THEN 2253 pNormal => ListGetConstRealArray( BC,'Plane Projector Normal',Found) 2254 IF( ThisRotatedContact ) THEN 2255 ActiveDirection = 1 2256 ELSE 2257 ActiveDirection = 1 2258 DO i=2,3 2259 IF( ABS( pnormal(i,1) ) > ABS( pnormal(ActiveDirection,1) ) ) THEN 2260 ActiveDirection = i 2261 END IF 2262 END DO 2263 CALL Info(Caller,'Active direction set to: '//TRIM(I2S(ActiveDirection)),Level=6) 2264 END IF 2265 ELSE IF( RotationalProjector .OR. NormalProjector ) THEN 2266 ActiveDirection = 1 2267 IF( .NOT. ThisRotatedContact ) THEN 2268 CALL Warn(Caller,'Rotational and normal projectors should only work with N-T coordinates!') 2269 END IF 2270 ELSE 2271 CALL Fatal(Caller,'Projector must be current either flat, plane, cylinder or rotational!') 2272 END IF 2273 2274 2275 ! Get the pointer to the other side i.e. master boundary 2276 master_ind = ListGetInteger( BC,'Mortar BC',Found ) 2277 IF( .NOT. Found ) master_ind = ListGetInteger( BC,'Contact BC',Found ) 2278 MasterBC => Model % BCs(master_ind) % Values 2279 2280 ! If we have dual projector we may use it to map certain quantities directly to master nodes 2281 DualProjector => Projector % Ematrix 2282 CreateDual = ASSOCIATED( DualProjector ) 2283 IF( CreateDual ) THEN 2284 CALL Info(Caller,'Using also the dual projector',Level=8) 2285 END IF 2286 2287 ! If we have N-T system then the mortar condition for the master side 2288 ! should have reverse sign as both normal displacement diminish the gap. 2289 IF( ThisRotatedContact ) THEN 2290 IF( master_ind > 0 ) THEN 2291 IF( .NOT. ListGetLogical( MasterBC, & 2292 'Normal-Tangential '//TRIM(VarName),Found) ) THEN 2293 CALL Fatal(Caller,'Master boundary '//TRIM(I2S(master_ind))//& 2294 ' should also have N-T coordinates!') 2295 END IF 2296 END IF 2297 2298 CALL Info(Caller,'We have a normal-tangential system',Level=6) 2299 MortarBC % MasterScale = -1.0_dp 2300 DofN = 1 2301 ELSE 2302 DofN = ActiveDirection 2303 END IF 2304 2305 ! Get the degrees of freedom related to the normal and tangential directions 2306 DofT1 = 0; DofT2 = 0 2307 DO i=1,dofs 2308 IF( i == DofN ) CYCLE 2309 IF( DofT1 == 0 ) THEN 2310 DofT1 = i 2311 CYCLE 2312 END IF 2313 IF( DofT2 == 0 ) THEN 2314 DofT2 = i 2315 CYCLE 2316 END IF 2317 END DO 2318 2319 ! This is the normal that is used to detect the signed distance 2320 ! and tangent vectors used to detect surface velocity 2321 IF( PlaneProjector ) THEN 2322 ContactNormal = pNormal(1:3,1) 2323 ELSE 2324 ContactNormal = 0.0_dp 2325 ContactNormal(ActiveDirection) = 1.0_dp 2326 END IF 2327 ContactT1 = 0.0_dp 2328 ContactT1(DofT1) = 1.0_dp 2329 ContactT2 = 0.0_dp 2330 IF(DofT2>0) ContactT2(DofT2) = 1.0_dp 2331 2332 ! Get the contact type. There are four possibilities currently. 2333 ! Only one is active at a time while others are false. 2334 StickContact = .FALSE.; TieContact = .FALSE. 2335 FrictionContact = .FALSE.; SlipContact = .FALSE. 2336 2337 ContactType = ListGetString( BC,'Contact Type',Found ) 2338 IF( Found ) THEN 2339 SELECT CASE ( ContactType ) 2340 CASE('stick') 2341 StickContact = .TRUE. 2342 CASE('tie') 2343 TieContact = .TRUE. 2344 CASE('friction') 2345 FrictionContact = .TRUE. 2346 CASE('slide') 2347 SlipContact = .TRUE. 2348 CASE Default 2349 CALL Fatal(Caller,'Unknown contact type: '//TRIM(ContactType)) 2350 END SELECT 2351 ELSE 2352 StickContact = ListGetLogical( BC,'Stick Contact',Found ) 2353 IF(.NOT. Found ) TieContact = ListGetLogical( BC,'Tie Contact',Found ) 2354 IF(.NOT. Found ) FrictionContact = ListGetLogical( BC,'Friction Contact',Found ) 2355 IF(.NOT. Found ) SlipContact = ListGetLogical( BC,'Slip Contact',Found ) 2356 IF(.NOT. Found ) SlipContact = ListGetLogical( BC,'Slide Contact',Found ) 2357 IF(.NOT. Found ) THEN 2358 CALL Warn(Caller,'No contact type given, assuming > Slip Contact <') 2359 SlipContact = .TRUE. 2360 END IF 2361 END IF 2362 2363 IF( StickContact ) CALL Info(Caller,'Using stick contact for displacement',Level=10) 2364 IF( TieContact ) CALL Info(Caller,'Using tie contact for displacement',Level=10) 2365 IF( FrictionContact ) CALL Info(Caller,'Using friction contact for displacement',Level=10) 2366 IF( SlipContact ) CALL Info(Caller,'Using slip contact for displacement',Level=10) 2367 2368 2369 ! At the start it may be beneficial to assume initial tie contact 2370 IF( (FrictionContact .OR. StickContact .OR. SlipContact ) .AND. & 2371 (TimeStep == 1 .AND. NonlinIter == 1 ) ) THEN 2372 DoIt = ListGetLogical(BC,'Initial Tie Contact',Found ) 2373 IF( DoIt ) THEN 2374 FrictionContact = .FALSE.; StickContact = .FALSE.; SlipContact = .FALSE. 2375 TieContact = .TRUE. 2376 CALL Info(Caller,'Assuming initial tie contact',Level=10) 2377 END IF 2378 END IF 2379 2380 ! At the first time it may be beneficial to assume frictionless initial contact. 2381 SkipFriction = .FALSE. 2382 IF( (FrictionContact .OR. StickContact .OR. SlipContact ) .AND. TimeStep == 1 ) THEN 2383 DoIt = .NOT. ListGetLogical(BC,'Initial Contact Friction',Found ) 2384 IF( DoIt ) THEN 2385 FrictionContact = .FALSE.; StickContact = .FALSE. 2386 SlipContact = .TRUE. 2387 SkipFriction = .TRUE. 2388 CALL Info(Caller,'Assuming frictionless initial contact',Level=10) 2389 END IF 2390 ELSE IF( ( FrictionContact .OR. SlipContact) .AND. NonlinIter == 1 ) THEN 2391 DoIt = ListGetLogical(BC,'Nonlinear System Initial Stick',Found ) 2392 IF(.NOT. Found ) THEN 2393 ! If contact velocity is not given then it is difficult to determine the direction at 2394 ! start of nonlinear iteration when the initial guess still reflects the old displacements. 2395 DoIt = .NOT. ListCheckPresent( BC,'Contact Velocity') .AND. & 2396 ListCheckPresent( BC,'Dynamic Friction Coefficient') 2397 END IF 2398 IF( DoIt ) THEN 2399 FrictionContact = .FALSE. 2400 SlipContact = .FALSE. 2401 StickContact = .TRUE. 2402 CALL Info(Caller,'Assuming sticking in first iteration initial contact',Level=10) 2403 END IF 2404 END IF 2405 2406 ! If we have stick contact then create a diagonal entry to the projection matrix. 2407 IF( StickContact .OR. FrictionContact ) THEN 2408 AddDiag = ListCheckPresent( BC,'Stick Contact Coefficient') 2409 ELSE 2410 AddDiag = .FALSE. 2411 END IF 2412 2413 ! d) allocate and initialize all necessary vectors for the contact 2414 !------------------------------------------------------------------ 2415 CALL InitializeMortarVectors() 2416 2417 ! e) If the contact set is set up in a conservative fashion we need to mark interface nodes 2418 !------------------------------------------------------------------ 2419 IF( ConservativeAdd .OR. ConservativeRemove ) THEN 2420 CALL MarkInterfaceDofs() 2421 END IF 2422 2423 ! f) Compute the normal load used to determine whether contact should be released. 2424 ! Also check the direction to which the signed distance should be computed 2425 !------------------------------------------------------------------ 2426 CALL CalculateContactPressure() 2427 2428 ! g) Calculate the distance used to determine whether contact should be added 2429 !------------------------------------------------------------------ 2430 CALL CalculateMortarDistance() 2431 2432 ! h) Determine the contact set in normal direction 2433 !------------------------------------------------------------------ 2434 CALL NormalContactSet() 2435 2436 ! i) If requested ensure a minimum number of contact nodes 2437 !------------------------------------------------------------------- 2438 LimitedMin = ListGetInteger( BC,'Contact Active Set Minimum',Found) 2439 IF( Found ) CALL IncreaseContactSet( LimitedMin ) 2440 2441 ! j) Determine the stick set in tangent direction 2442 !------------------------------------------------------------------ 2443 CALL TangentContactSet() 2444 2445 ! k) Add the stick coefficient if present 2446 !------------------------------------------------------------------ 2447 IF( AddDiag ) THEN 2448 CALL StickCoefficientSet() 2449 END IF 2450 2451 ! l) We can map information from slave to master either by creating a dual projector 2452 ! or using the transpose of the original projector to map field from slave to master. 2453 !----------------------------------------------------------------------------------- 2454 IF(.NOT. CreateDual ) THEN 2455 CALL ProjectFromSlaveToMaster() 2456 END IF 2457 2458 ! m) If we have dynamic friction then add it 2459 IF( .NOT. SkipFriction .AND. ( SlipContact .OR. FrictionContact ) ) THEN 2460 CALL SetSlideFriction() 2461 END IF 2462 2463 IF( ConservativeAdd .OR. ConservativeRemove ) THEN 2464 DEALLOCATE( InterfaceDof ) 2465 END IF 2466 END DO 2467 2468 ! Use N-T coordinate system for the initial guess 2469 ! This is mandatory if using the residual mode linear solvers 2470 IF( AnyRotatedContact ) THEN 2471 DEALLOCATE( RotatedField ) 2472 END IF 2473 2474 2475 FirstTime = .FALSE. 2476 CALL Info(Caller,'All done',Level=10) 2477 2478 CONTAINS 2479 2480 2481 ! Given the cartesian solution compute the rotated solution. 2482 !------------------------------------------------------------------------- 2483 SUBROUTINE RotatedDisplacementField( ) 2484 2485 REAL(KIND=dp) :: RotVec(3) 2486 INTEGER :: i,j,k,m 2487 2488 IF( .NOT. AnyRotatedContact ) RETURN 2489 2490 CALL Info(Caller,'Rotating displacement field',Level=8) 2491 ALLOCATE( RotatedField(Solver % Matrix % NumberOfRows ) ) 2492 RotatedField = Var % Values 2493 2494 DO i=1,Solver % Mesh % NumberOfNodes 2495 j = Solver % Variable % Perm(i) 2496 IF( j == 0 ) CYCLE 2497 m = BoundaryReorder(i) 2498 IF( m == 0 ) CYCLE 2499 2500 RotVec = 0._dp 2501 DO k=1,Var % DOFs 2502 RotVec(k) = RotatedField(Var % DOfs*(j-1)+k) 2503 END DO 2504 CALL RotateNTSystem( RotVec, i ) 2505 DO k=1,Var % DOFs 2506 RotatedField(Var % Dofs*(j-1)+k) = RotVec( k ) 2507 END DO 2508 END DO 2509 2510 END SUBROUTINE RotatedDisplacementField 2511 2512 2513 ! Given the previous solution and the current stiffness matrix 2514 ! computes the load normal to the surface i.e. the contact load. 2515 ! If we have normal-tangential coordinate system then also the load is in 2516 ! the same coordinate system. 2517 !------------------------------------------------------------------------- 2518 FUNCTION CalculateContactLoad( ) RESULT ( LoadVar ) 2519 2520 TYPE(Variable_t), POINTER :: LoadVar 2521 REAL(KIND=dp), POINTER :: TempX(:) 2522 REAL(KIND=dp) :: RotVec(3) 2523 INTEGER :: i,j,k,m 2524 2525 2526 CALL Info(Caller,'Determining contact load for contact problems',Level=10) 2527 2528 LoadVar => VariableGet( Model % Variables, & 2529 TRIM(VarName) // ' Contact Load',ThisOnly = .TRUE. ) 2530 IF( .NOT. ASSOCIATED( LoadVar ) ) THEN 2531 CALL Fatal(Caller, & 2532 'No Loads associated with variable: '//GetVarName(Var) ) 2533 END IF 2534 2535 IF( AnyRotatedContact ) THEN 2536 TempX => RotatedField 2537 ELSE 2538 TempX => FieldValues 2539 END IF 2540 2541 CALL CalculateLoads( Solver, Solver % Matrix, TempX, Var % DOFs, .FALSE., LoadVar ) 2542 2543 END FUNCTION CalculateContactLoad 2544 2545 2546 ! Create fields where the contact information will be saved. 2547 ! Create the fields both for slave and master nodes at each 2548 ! contact pair. 2549 !-------------------------------------------------------------- 2550 SUBROUTINE GetContactFields( DoAllocate ) 2551 2552 LOGICAL :: DoAllocate 2553 INTEGER, POINTER :: BoundaryPerm(:), Indexes(:) 2554 INTEGER :: i,j,k,t,n 2555 TYPE(Element_t), POINTER :: Element 2556 LOGICAL, ALLOCATABLE :: ActiveBCs(:) 2557 2558 2559 IF( DoAllocate ) THEN 2560 CALL Info(Caller,'Creating contact fields',Level=8) 2561 2562 ALLOCATE( BoundaryPerm(Mesh % NumberOfNodes) ) 2563 BoundaryPerm = 0 2564 2565 ALLOCATE( ActiveBCs(Model % NumberOfBcs ) ) 2566 ActiveBCs = .FALSE. 2567 2568 DO i=1,Model % NumberOfBCs 2569 j = ListGetInteger( Model % BCs(i) % Values,'Mortar BC',Found ) 2570 IF(.NOT. Found ) THEN 2571 j = ListGetInteger( Model % BCs(i) % Values,'Contact BC',Found ) 2572 END IF 2573 IF( j > 0 ) THEN 2574 ActiveBCs(i) = .TRUE. 2575 ActiveBCs(j) = .TRUE. 2576 END IF 2577 END DO 2578 2579 DO t=Mesh % NumberOfBulkElements + 1, & 2580 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2581 2582 Element => Mesh % Elements( t ) 2583 DO i = 1, Model % NumberOfBCs 2584 IF ( Element % BoundaryInfo % Constraint == Model % BCs(i) % Tag ) THEN 2585 IF( ActiveBCs(i) ) THEN 2586 BoundaryPerm( Element % NodeIndexes ) = 1 2587 END IF 2588 END IF 2589 END DO 2590 END DO 2591 2592 DEALLOCATE( ActiveBCs ) 2593 2594 j = 0 2595 DO i=1,Mesh % NumberOfNodes 2596 IF( BoundaryPerm(i) > 0 ) THEN 2597 j = j + 1 2598 BoundaryPerm(i) = j 2599 END IF 2600 END DO 2601 2602 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2603 TRIM(VarName)//' Contact Distance',1,Perm = BoundaryPerm ) 2604 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2605 TRIM(VarName)//' Contact Gap',1,Perm = BoundaryPerm ) 2606 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2607 TRIM(VarName)//' Contact Normalload',1,Perm = BoundaryPerm ) 2608 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2609 TRIM(VarName)//' Contact Slipload',1,Perm = BoundaryPerm ) 2610 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2611 TRIM(VarName)//' Contact Weight',1,Perm = BoundaryPerm ) 2612 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2613 TRIM(VarName)//' Contact Active',1,Perm = BoundaryPerm ) 2614 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2615 TRIM(VarName)//' Contact Stick',1,Perm = BoundaryPerm ) 2616 IF( CalculateVelocity ) THEN 2617 CALL VariableAddVector( Model % Variables,Mesh,Solver,& 2618 TRIM(VarName)//' Contact Velocity',Dofs,Perm = BoundaryPerm ) 2619 END IF 2620 END IF 2621 2622 DistVar => VariableGet( Model % Variables,& 2623 TRIM(VarName)//' Contact Distance') 2624 GapVar => VariableGet( Model % Variables,& 2625 TRIM(VarName)//' Contact Gap') 2626 NormalLoadVar => VariableGet( Model % Variables,& 2627 TRIM(VarName)//' Contact Normalload') 2628 SlipLoadVar => VariableGet( Model % Variables,& 2629 TRIM(VarName)//' Contact Slipload') 2630 WeightVar => VariableGet( Model % Variables,& 2631 TRIM(VarName)//' Contact Weight') 2632 NormalActiveVar => VariableGet( Model % Variables,& 2633 TRIM(VarName)//' Contact Active') 2634 StickActiveVar => VariableGet( Model % Variables,& 2635 TRIM(VarName)//' Contact Stick') 2636 IF( CalculateVelocity ) THEN 2637 VeloVar => VariableGet( Model % Variables,& 2638 TRIM(VarName)//' Contact Velocity') 2639 END IF 2640 2641 NormalActiveVar % Values = -1.0_dp 2642 StickActiveVar % Values = -1.0_dp 2643 2644 END SUBROUTINE GetContactFields 2645 2646 2647 2648 ! Allocates the vectors related to the mortar contact surface, if needed. 2649 ! Initialize the mortar vectors and mortar permutation future use. 2650 ! As the geometry changes the size of the projectors may also change. 2651 !---------------------------------------------------------------------------- 2652 SUBROUTINE InitializeMortarVectors() 2653 2654 INTEGER :: onesize, totsize 2655 INTEGER, POINTER :: Perm(:) 2656 LOGICAL, POINTER :: Active(:) 2657 REAL(KIND=dp), POINTER :: Diag(:) 2658 LOGICAL :: SamePerm, SameSize 2659 2660 2661 onesize = Projector % NumberOfRows 2662 totsize = Dofs * onesize 2663 2664 IF( .NOT. AddDiag .AND. ASSOCIATED(MortarBC % Diag) ) THEN 2665 DEALLOCATE( MortarBC % Diag ) 2666 END IF 2667 2668 2669 ! Create the permutation that is later need in putting the diag and rhs to correct position 2670 ALLOCATE( Perm( SIZE( FieldPerm ) ) ) 2671 Perm = 0 2672 DO i=1,SIZE( Projector % InvPerm ) 2673 j = Projector % InvPerm(i) 2674 IF( j == 0 ) CYCLE 2675 Perm( j ) = i 2676 END DO 2677 2678 ! First time nothing is allocated 2679 IF( .NOT. ASSOCIATED( MortarBC % Perm ) ) THEN 2680 CALL Info(Caller,'Allocating projector mortar vectors',Level=10) 2681 ALLOCATE( MortarBC % Active( totsize ), MortarBC % Rhs( totsize) ) 2682 MortarBC % Active = .FALSE. 2683 MortarBC % Rhs = 0.0_dp 2684 MortarBC % Perm => Perm 2685 2686 IF( AddDiag ) THEN 2687 ALLOCATE( MortarBC % Diag( totsize ) ) 2688 MortarBC % Diag = 0.0_dp 2689 END IF 2690 2691 RETURN 2692 END IF 2693 2694 2695 ! If permutation has changed we need to change the vectors also 2696 SamePerm = ANY( Perm /= MortarBC % Perm ) 2697 SameSize = ( SIZE(MortarBC % Rhs) == totsize ) 2698 2699 ! Permutation unchanged, just return 2700 IF( SamePerm ) THEN 2701 DEALLOCATE( Perm ) 2702 RETURN 2703 END IF 2704 2705 ! Permutation changes, and also sizes changed 2706 IF(.NOT. SameSize ) THEN 2707 DEALLOCATE( MortarBC % Rhs ) 2708 ALLOCATE( MortarBC % Rhs( totsize ) ) 2709 MortarBC % Rhs = 0.0_dp 2710 END IF 2711 2712 ! .NOT. SamePerm 2713 ALLOCATE(Active(totsize)) 2714 Active = .FALSE. 2715 2716 IF( AddDiag ) THEN 2717 ALLOCATE( Diag(totsize) ) 2718 Diag = 0.0_dp 2719 END IF 2720 2721 2722 DO i=1,SIZE( Perm ) 2723 j = Perm(i) 2724 IF( j == 0 ) CYCLE 2725 2726 k = MortarBC % Perm(i) 2727 IF( k == 0 ) CYCLE 2728 2729 DO l=1,Dofs 2730 Active(Dofs*(j-1)+l) = MortarBC % Active(Dofs*(k-1)+l) 2731 END DO 2732 END DO 2733 2734 DEALLOCATE( MortarBC % Active ) 2735 DEALLOCATE( MortarBC % Perm ) 2736 MortarBC % Active => Active 2737 MortarBC % Perm => Perm 2738 2739 IF( AddDiag ) THEN 2740 IF( ASSOCIATED( MortarBC % Diag ) ) THEN 2741 DEALLOCATE( MortarBC % Diag ) 2742 END IF 2743 MortarBC % Diag => Diag 2744 END IF 2745 2746 CALL Info(Caller,'Copied > Active < flag to changed projector',Level=8) 2747 2748 END SUBROUTINE InitializeMortarVectors 2749 2750 2751 2752 ! Make a list of interface dofs to allow conservative algorithms. 2753 ! There only nodes that are at the interface are added or removed from the set. 2754 !------------------------------------------------------------------------------ 2755 SUBROUTINE MarkInterfaceDofs() 2756 2757 INTEGER :: i,j,i2,j2,k,k2,l,n,ind,ind2,elem 2758 INTEGER, POINTER :: Indexes(:) 2759 TYPE(Element_t), POINTER :: Element 2760 2761 CALL Info(Caller,'Marking interface dofs for conservative adding/removal',Level=8) 2762 2763 IF(.NOT. ALLOCATED( InterfaceDof ) ) THEN 2764 ALLOCATE( InterfaceDof( SIZE(MortarBC % Active) ) ) 2765 END IF 2766 InterfaceDof = .FALSE. 2767 2768 2769 DO elem=Mesh % NumberOfBulkElements + 1, & 2770 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2771 2772 Element => Mesh % Elements( elem ) 2773 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc_ind) % Tag ) CYCLE 2774 2775 n = Element % TYPE % NumberOfNodes 2776 Indexes => Element % NodeIndexes 2777 2778 DO i=1,n 2779 j = FieldPerm( Indexes(i) ) 2780 IF( j == 0 ) CYCLE 2781 k = MortarBC % Perm( Indexes(i) ) 2782 2783 DO i2 = i+1,n 2784 j2 = FieldPerm( Indexes(i2) ) 2785 IF( j2 == 0 ) CYCLE 2786 k2 = MortarBC % perm( Indexes(i2) ) 2787 2788 DO l=1,Dofs 2789 ind = Dofs * ( k - 1 ) + l 2790 ind2 = Dofs * ( k2 - 1) + l 2791 2792 IF( MortarBC % Active(ind) .NEQV. MortarBC % Active(ind2) ) THEN 2793 InterfaceDof(ind) = .TRUE. 2794 InterfaceDof(ind2) = .TRUE. 2795 END IF 2796 END DO 2797 END DO 2798 END DO 2799 END DO 2800 2801 n = COUNT(InterfaceDof) 2802 CALL Info(Caller,& 2803 'Number of interface dofs: '//TRIM(I2S(n)),Level=8) 2804 END SUBROUTINE MarkInterfaceDofs 2805 2806 2807 ! Calculates the signed distance that is used to define whether we have contact or not. 2808 ! If distance is negative then we can later add the corresponding node to the contact set 2809 ! Also computes the right-hand-side of the mortar equality constrained which is the 2810 ! desired distance in the active direction. Works also for residual mode which greatly 2811 ! improves the convergence for large displacements. 2812 !---------------------------------------------------------------------------------------- 2813 SUBROUTINE CalculateMortarDistance() 2814 2815 REAL(KIND=dp) :: Disp(3), Coord(3), PrevDisp(3), Velo(3), ContactVec(3), ContactVelo(3), & 2816 LocalNormal0(3), SlipCoord(3), CartVec(3), ContactDist 2817 REAL(KIND=dp), POINTER :: DispVals(:), PrevDispVals(:) 2818 REAL(KIND=dp) :: MinDist, MaxDist, wsum, wsumM, mult 2819 TYPE(Matrix_t), POINTER :: ActiveProjector 2820 LOGICAL :: IsSlave, IsMaster, DistanceSet 2821 LOGICAL, ALLOCATABLE :: SlaveNode(:), MasterNode(:), NodeDone(:) 2822 INTEGER, POINTER :: Indexes(:) 2823 INTEGER :: elemcode, CoeffSign 2824 REAL(KIND=dp), ALLOCATABLE :: CoeffTable(:) 2825 INTEGER :: l2,elem,i1,i2,j1,j2 2826 LOGICAL :: LinearContactGap, DebugNormals 2827 2828 2829 CALL Info('CalculateMortarDistance','Computing distance between mortar boundaries',Level=14) 2830 2831 DispVals => Solver % Variable % Values 2832 IF( .NOT. ASSOCIATED( DispVals ) ) THEN 2833 CALL Fatal('CalculateMortarDistance','Displacement variable not associated!') 2834 END IF 2835 2836 IF( CalculateVelocity ) THEN 2837 IF( .NOT. ASSOCIATED( Solver % Variable % PrevValues ) ) THEN 2838 CALL Fatal('CalculateMortarDistance','Displacement PrevValues not associated!') 2839 END IF 2840 IF( Solver % TimeOrder == 1 ) THEN 2841 PrevDispVals => Solver % Variable % PrevValues(:,1) 2842 ELSE 2843 PrevDispVals => Solver % Variable % PrevValues(:,3) 2844 END IF 2845 IF(.NOT. ASSOCIATED( PrevDispVals ) ) CALL Fatal('CalculateMortarDistance',& 2846 'Previous displacement field required!') 2847 END IF 2848 2849 LinearContactGap = ListGetLogical( Model % Simulation,& 2850 'Contact BCs linear gap', Found ) 2851 2852 ALLOCATE( SlaveNode( Mesh % NumberOfNodes ) ) 2853 SlaveNode = .FALSE. 2854 2855 IF( CreateDual ) THEN 2856 ALLOCATE( MasterNode( Mesh % NumberOfNodes ) ) 2857 MasterNode = .FALSE. 2858 END IF 2859 2860 DO i=Mesh % NumberOfBulkElements + 1, & 2861 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2862 2863 Element => Mesh % Elements( i ) 2864 IF( Element % BoundaryInfo % Constraint == Model % BCs(bc_ind) % Tag ) THEN 2865 SlaveNode( Element % NodeIndexes ) = .TRUE. 2866 END IF 2867 IF( CreateDual ) THEN 2868 IF ( Element % BoundaryInfo % Constraint == Model % BCs(master_ind) % Tag ) THEN 2869 MasterNode( Element % NodeIndexes ) = .TRUE. 2870 END IF 2871 END IF 2872 END DO 2873 2874 ! First create the master, then the slave if needed 2875 IsSlave = .TRUE. 2876 IsMaster = .NOT. IsSlave 2877 ActiveProjector => Projector 2878 MinDist = HUGE(MinDist) 2879 MaxDist = -HUGE(MaxDist) 2880 2881 IF( .NOT. ASSOCIATED( ActiveProjector ) ) THEN 2882 CALL Fatal('CalculateMortarDistance','Projector not associated!') 2883 END IF 2884 2885 DebugNormals = ListGetLogical( Params,'Debug Normals',Found ) 2886 2887 IF( DebugNormals ) THEN 2888 PRINT *,'Flags:',TieContact,ResidualMode,ThisRotatedContact,NodalNormal,StickContact,RotationalProjector 2889 END IF 2890 2891 2892100 CONTINUE 2893 2894 DO i = 1,ActiveProjector % NumberOfRows 2895 2896 j = ActiveProjector % InvPerm(i) 2897 2898 IF( j == 0 ) CYCLE 2899 2900 wsum = 0.0_dp 2901 wsumM = 0.0_dp 2902 Dist = 0.0_dp 2903 DistN = 0.0_dp 2904 DistT1 = 0.0_dp 2905 DistT2 = 0.0_dp 2906 ContactVelo = 0.0_dp 2907 ContactVec = 0.0_dp 2908 DistanceSet = .FALSE. 2909 ContactDist = 0.0_dp 2910 CartVec = 0.0_dp 2911 2912 ! This is the most simple contact condition. We just want no slip on the contact. 2913 IF( TieContact .AND. .NOT. ResidualMode ) GOTO 200 2914 2915 ! Get the normal of the slave surface. 2916 IF( ThisRotatedContact ) THEN 2917 Rotated = GetSolutionRotation(NTT, j ) 2918 LocalNormal = NTT(:,1) 2919 LocalNormal0 = LocalNormal 2920 LocalT1 = NTT(:,2) 2921 IF( Dofs == 3 ) LocalT2 = NTT(:,3) 2922 ELSE 2923 LocalNormal = ContactNormal 2924 LocalT1 = ContactT1 2925 IF( Dofs == 3 ) LocalT2 = ContactT2 2926 END IF 2927 2928 ! Compute normal of the master surface from the average sum of normals 2929 IF( NodalNormal ) THEN 2930 LocalNormal = 0.0_dp 2931 LocalT1 = 0.0_dp 2932 LocalT2 = 0.0_dp 2933 2934 DO j = ActiveProjector % Rows(i),ActiveProjector % Rows(i+1)-1 2935 k = ActiveProjector % Cols(j) 2936 2937 l = FieldPerm( k ) 2938 IF( l == 0 ) CYCLE 2939 2940 coeff = ActiveProjector % Values(j) 2941 Rotated = GetSolutionRotation(NTT, k ) 2942 2943 ! Weighted direction for the unit vectors 2944 LocalNormal = LocalNormal + coeff * NTT(:,1) 2945 LocalT1 = LocalT1 + coeff * NTT(:,2) 2946 IF( Dofs == 3 ) LocalT2 = LocalT2 + coeff * NTT(:,3) 2947 END DO 2948 2949 ! Normalize the unit vector length to one 2950 LocalNormal = LocalNormal / SQRT( SUM( LocalNormal**2 ) ) 2951 LocalT1 = LocalT1 / SQRT( SUM( LocalT1**2 ) ) 2952 IF( Dofs == 3 ) LocalT2 = LocalT2 / SQRT( SUM( LocalT1**2 ) ) 2953 2954 !PRINT *,'NodalNormal:',i,j,LocalNormal0,LocalNormal 2955 END IF 2956 2957 ! For debugging reason, check that normals are roughly opposite 2958 IF( DebugNormals ) THEN 2959 DO j = ActiveProjector % Rows(i),ActiveProjector % Rows(i+1)-1 2960 k = ActiveProjector % Cols(j) 2961 2962 l = FieldPerm( k ) 2963 IF( l == 0 ) CYCLE 2964 2965 Rotated = GetSolutionRotation(NTT, k ) 2966 coeff = SUM( LocalNormal * NTT(:,1) ) + SUM( LocalT1*NTT(:,2)) + SUM(LocalT2*NTT(:,3)) 2967 IF( SlaveNode(k) .AND. coeff < 2.5_dp ) THEN 2968 Found = .TRUE. 2969 !PRINT *,'Slave Normal:',i,j,k,Rotated,coeff 2970 ELSE IF( .NOT. SlaveNode(k) .AND. coeff > -2.5_dp ) THEN 2971 Found = .TRUE. 2972 !PRINT *,'Master Normal:',i,j,k,Rotated,coeff 2973 ELSE 2974 Found = .FALSE. 2975 END IF 2976 IF( Found ) THEN 2977 !PRINT *,'Prod:',SUM( LocalNormal * NTT(:,1) ), SUM( LocalT1*NTT(:,2)), SUM(LocalT2*NTT(:,3)) 2978 !PRINT *,'N:',LocalNormal,NTT(:,1) 2979 !PRINT *,'T1:',LocalT1,NTT(:,2) 2980 !PRINT *,'T2:',LocalT2,NTT(:,3) 2981 END IF 2982 END DO 2983 END IF 2984 2985 ! Compute the weigted distance in the normal direction. 2986 DO j = ActiveProjector % Rows(i),ActiveProjector % Rows(i+1)-1 2987 k = ActiveProjector % Cols(j) 2988 2989 l = FieldPerm( k ) 2990 IF( l == 0 ) CYCLE 2991 2992 coeff = ActiveProjector % Values(j) 2993 2994 ! Only compute the sum related to the active projector 2995 IF( SlaveNode(k) ) THEN 2996 wsum = wsum + coeff 2997 ELSE 2998 wsumM = wsumM + coeff 2999 END IF 3000 END DO 3001 3002 IF( ABS( wsum ) <= TINY( wsum ) ) THEN 3003 CALL Fatal('CalculateMortarDistance','wsum seems to be almost zero!') 3004 END IF 3005 IF( ABS( wsumM ) <= TINY( wsumM ) ) THEN 3006 CALL Fatal('CalculateMortarDistance','wsumM seems to be almost zero!') 3007 END IF 3008 3009 ! Slave and master multipliers should sum up to same value 3010 mult = ABS( wsum / wsumM ) 3011 3012 ! Compute the weigted distance in the normal direction. 3013 DO j = ActiveProjector % Rows(i),ActiveProjector % Rows(i+1)-1 3014 k = ActiveProjector % Cols(j) 3015 3016 l = FieldPerm( k ) 3017 IF( l == 0 ) CYCLE 3018 3019 ! This includes only the coordinate since the displacement 3020 ! is added to the coordinate! 3021 coeff = ActiveProjector % Values(j) 3022 3023 CoeffSign = 1 3024 3025 ! Only compute the sum related to the active projector 3026 IF( .NOT. SlaveNode(k) ) THEN 3027 coeff = mult * coeff 3028 IF( ThisRotatedContact ) CoeffSign = -1 3029 END IF 3030 3031 IF( dofs == 2 ) THEN 3032 disp(1) = DispVals( 2 * l - 1) 3033 disp(2) = DispVals( 2 * l ) 3034 disp(3) = 0.0_dp 3035 ELSE 3036 disp(1) = DispVals( 3 * l - 2) 3037 disp(2) = DispVals( 3 * l - 1 ) 3038 disp(3) = DispVals( 3 * l ) 3039 END IF 3040 3041 ! If nonlinear analysis is used we may need to cancel the introduced gap due to numerical errors 3042 IF( TieContact .AND. ResidualMode ) THEN 3043 IF( ThisRotatedContact ) THEN 3044 ContactVec(1) = ContactVec(1) + coeff * SUM( LocalNormal * Disp ) 3045 ContactVec(2) = ContactVec(2) + coeff * SUM( LocalT1 * Disp ) 3046 IF( Dofs == 3) ContactVec(3) = ContactVec(3) + coeff * SUM( LocalT2 * Disp ) 3047 ELSE 3048 ContactVec(1) = ContactVec(1) + coeff * SUM( ContactNormal * Disp ) 3049 ContactVec(2) = ContactVec(2) + coeff * SUM( ContactT1 * Disp ) 3050 IF( Dofs == 3 ) ContactVec(3) = ContactVec(3) + coeff * SUM( ContactT2 * Disp ) 3051 END IF 3052 CYCLE 3053 END IF 3054 3055 coord(1) = Mesh % Nodes % x( k ) 3056 coord(2) = Mesh % Nodes % y( k ) 3057 coord(3) = Mesh % Nodes % z( k ) 3058 3059 IF( CalculateVelocity ) THEN 3060 IF( dofs == 2 ) THEN 3061 PrevDisp(1) = PrevDispVals( 2 * l - 1) 3062 PrevDisp(2) = PrevDispVals( 2 * l ) 3063 PrevDisp(3) = 0.0_dp 3064 ELSE 3065 PrevDisp(1) = PrevDispVals( 3 * l - 2) 3066 PrevDisp(2) = PrevDispVals( 3 * l - 1 ) 3067 PrevDisp(3) = PrevDispVals( 3 * l ) 3068 END IF 3069 END IF 3070 3071 ! If the linear system is in residual mode also set the current coordinate in residual mode too! 3072 ! Note that displacement field is given always in cartesian coordinates! 3073 IF( ResidualMode ) THEN 3074 Coord = Coord + Disp 3075 END IF 3076 3077 ! DistN is used to give the distance that we need to move the original coordinates 3078 ! in the wanted direction in order to have contact. 3079 IF( ThisRotatedContact ) THEN 3080 ContactVec(1) = ContactVec(1) + coeff * SUM( LocalNormal * Coord ) 3081 ELSE 3082 ContactVec(1) = ContactVec(1) + coeff * SUM( ContactNormal * Coord ) 3083 END IF 3084 3085 ! Tangential distances needed to move the original coordinates to the contact position 3086 ! If stick is required then we want to keep the tangential slip zero. 3087 IF( StickContact ) THEN 3088 SlipCoord = -PrevDisp 3089 IF( ResidualMode ) SlipCoord = SlipCoord + Disp 3090 3091 IF( ThisRotatedContact ) THEN 3092 ContactVec(2) = ContactVec(2) + coeff * SUM( LocalT1 * SlipCoord ) 3093 IF( Dofs == 3) ContactVec(3) = ContactVec(3) + coeff * SUM( LocalT2 * SlipCoord ) 3094 ELSE 3095 ContactVec(2) = ContactVec(2) + coeff * SUM( ContactT1 * SlipCoord ) 3096 IF( Dofs == 3 ) ContactVec(3) = ContactVec(3) + coeff * SUM( ContactT2 * SlipCoord ) 3097 END IF 3098 END IF 3099 3100 ! If not in the residual mode still take into account the displacement for the condition 3101 IF( .NOT. ResidualMode ) Coord = Coord + Disp 3102 3103 ! Dist is used to compute the current signed distance that is used to determine 3104 ! whether we have contact or not. 3105 IF( RotationalProjector ) THEN 3106 Dist = Dist + coeff * SQRT( SUM( Coord**2 ) ) 3107 ELSE IF( NormalProjector ) THEN 3108 Dist = Dist + coeff * SUM( LocalNormal * Coord ) 3109 ELSE 3110 Dist = Dist + coeff * SUM( ContactNormal * Coord ) 3111 END IF 3112 3113 CartVec = CartVec + coeff * Coord 3114 3115 IF( CalculateVelocity ) THEN 3116 Velo = ( Disp - PrevDisp ) !/ dt 3117 ContactVelo(1) = ContactVelo(1) + coeff * SUM( Velo * LocalNormal ) 3118 ContactVelo(2) = ContactVelo(2) + coeff * SUM( Velo * LocalT1 ) 3119 ContactVelo(3) = ContactVelo(3) + coeff * SUM( Velo * LocalT2 ) 3120 END IF 3121 DistanceSet = .TRUE. 3122 END DO 3123 3124 ! Divide by weight to get back to real distance in the direction of the normal 3125 ContactVec = ContactVec / wsum 3126 Dist = DistSign * Dist / wsum 3127 IF( CalculateVelocity ) THEN 3128 ContactVelo = ContactVelo / wsum 3129 END IF 3130 CartVec = CartVec / wsum 3131 3132200 IF( IsSlave ) THEN 3133 MortarBC % Rhs(Dofs*(i-1)+DofN) = -ContactVec(1) 3134 IF( StickContact .OR. TieContact ) THEN 3135 MortarBC % Rhs(Dofs*(i-1)+DofT1) = -ContactVec(2) 3136 IF( Dofs == 3 ) THEN 3137 MortarBC % Rhs(Dofs*(i-1)+DofT2) = -ContactVec(3) 3138 END IF 3139 END IF 3140 3141 MinDist = MIN( Dist, MinDist ) 3142 MaxDist = MAX( Dist, MaxDist ) 3143 END IF 3144 3145 IF( IsMaster ) THEN 3146 Dist = -Dist 3147 ContactVelo = -ContactVelo 3148 END IF 3149 3150 ! We use the same permutation for all boundary variables 3151 IF(ActiveProjector % InvPerm(i) <= 0 ) CYCLE 3152 j = DistVar % Perm( ActiveProjector % InvPerm(i) ) 3153 3154 DistVar % Values( j ) = Dist 3155 3156 GapVar % Values( j ) = ContactVec(1) 3157 3158 IF( CalculateVelocity ) THEN 3159 DO k=1,Dofs 3160 VeloVar % Values( Dofs*(j-1)+k ) = ContactVelo(k) 3161 END DO 3162 END IF 3163 END DO 3164 3165 IF( IsSlave ) THEN 3166 IF( CreateDual ) THEN 3167 IsSlave = .FALSE. 3168 IsMaster = .NOT. IsSlave 3169 ActiveProjector => DualProjector 3170 GOTO 100 3171 END IF 3172 END IF 3173 3174 3175 IF( LinearContactGap ) THEN 3176 DO elem=Mesh % NumberOfBulkElements + 1, & 3177 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 3178 3179 Element => Mesh % Elements( elem ) 3180 3181 IsSlave = ( Element % BoundaryInfo % Constraint == Model % BCs(bc_ind) % Tag ) 3182 IsMaster = ( Element % BoundaryInfo % Constraint == Model % BCs(master_ind) % Tag ) 3183 IF( .NOT. ( IsSlave .OR. ( CreateDual .AND. IsMaster ) ) ) CYCLE 3184 3185 Indexes => Element % NodeIndexes 3186 ElemCode = Element % TYPE % ElementCode 3187 3188 SELECT CASE ( ElemCode ) 3189 3190 CASE( 408 ) 3191 DO i=5,8 3192 i1=i-4 3193 i2=i1+1 3194 IF(i2==5) i2=1 3195 j = DistVar % Perm(Indexes(i)) 3196 IF( j == 0 ) CYCLE 3197 j1 = DistVar % Perm(Indexes(i1)) 3198 j2 = DistVar % Perm(Indexes(i2)) 3199 3200 DistVar % Values(j) = 0.5_dp * & 3201 ( DistVar % Values(j1) + DistVar % Values(j2)) 3202 GapVar % Values(j) = 0.5_dp * & 3203 ( GapVar % Values(j1) + GapVar % Values(j2)) 3204 3205 IF( CalculateVelocity ) THEN 3206 DO k=1,Dofs 3207 VeloVar % Values( Dofs*(j-1)+k ) = 0.5_dp * & 3208 ( VeloVar % Values(Dofs*(j1-1)+k) + VeloVar % Values(Dofs*(j2-1)+k)) 3209 END DO 3210 END IF 3211 END DO 3212 3213 CASE DEFAULT 3214 CALL Fatal('CalculateMortarDistance','Implement linear gaps for: '//TRIM(I2S(ElemCode))) 3215 END SELECT 3216 END DO 3217 END IF 3218 3219 DEALLOCATE( SlaveNode ) 3220 IF( CreateDual ) DEALLOCATE( MasterNode ) 3221 3222 IF( InfoActive(20 ) ) THEN 3223 PRINT *,'Distance Range:',MinDist, MaxDist 3224 PRINT *,'Distance Offset:',MINVAL( MortarBC % Rhs ), MAXVAL( MortarBC % Rhs ) 3225 END IF 3226 3227 END SUBROUTINE CalculateMortarDistance 3228 3229 3230 3231 ! Calculates the contact pressure in the normal direction from the nodal loads. 3232 ! The nodal loads may be given either in cartesian or n-t coordinate system. 3233 !------------------------------------------------------------------------------- 3234 SUBROUTINE CalculateContactPressure() 3235 3236 INTEGER :: elem 3237 INTEGER, POINTER :: Indexes(:) 3238 TYPE(GaussIntegrationPoints_t), TARGET :: IntegStuff 3239 TYPE(Nodes_t) :: Nodes 3240 INTEGER :: i,j,k,t,CoordSys, NormalSign0, NormalSign, NormalCount 3241 REAL(KIND=dp) :: s, x, DetJ, u, v, w, Normal(3),NodalForce(3),DotProd, & 3242 NormalForce, SlipForce 3243 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 3244 LOGICAL :: Stat, IsSlave, IsMaster 3245 TYPE(Matrix_t), POINTER :: ActiveProjector 3246 LOGICAL, ALLOCATABLE :: NodeDone(:) 3247 LOGICAL :: LinearContactLoads 3248 INTEGER :: i1,i2,j1,j2,ElemCode 3249 3250 n = Mesh % MaxElementNodes 3251 ALLOCATE(Basis(n), Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 3252 3253 CoordSys = CurrentCoordinateSystem() 3254 NodalForce = 0.0_dp 3255 3256 NormalSign0 = 0 3257 NormalCount = 0 3258 3259 ALLOCATE( NodeDone( Mesh % NumberOfNodes ) ) 3260 NodeDone = .FALSE. 3261 3262 LinearContactLoads = ListGetLogical( Model % Simulation,& 3263 'Contact BCs linear loads', Found ) 3264 3265 3266100 DO elem=Mesh % NumberOfBulkElements + 1, & 3267 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 3268 3269 Element => Mesh % Elements( elem ) 3270 3271 IsSlave = ( Element % BoundaryInfo % Constraint == Model % BCs(bc_ind) % Tag ) 3272 IsMaster = ( Element % BoundaryInfo % Constraint == Model % BCs(master_ind) % Tag ) 3273 3274 IF( .NOT. ( IsSlave .OR. ( CreateDual .AND. IsMaster ) ) ) CYCLE 3275 3276 Indexes => Element % NodeIndexes 3277 3278 n = Element % TYPE % NumberOfNodes 3279 Nodes % x(1:n) = Mesh % Nodes % x(Indexes) 3280 Nodes % y(1:n) = Mesh % Nodes % y(Indexes) 3281 Nodes % z(1:n) = Mesh % Nodes % z(Indexes) 3282 3283 IntegStuff = GaussPoints( Element, n ) 3284 3285 DO t=1,IntegStuff % n 3286 U = IntegStuff % u(t) 3287 V = IntegStuff % v(t) 3288 W = IntegStuff % w(t) 3289 3290 stat = ElementInfo( Element, Nodes, U, V, W, detJ, Basis ) 3291 S = DetJ * IntegStuff % s(t) 3292 3293 IF ( CoordSys /= Cartesian ) THEN 3294 X = SUM( Nodes % X(1:n) * Basis(1:n) ) 3295 s = s * x 3296 END IF 3297 3298 Normal = NormalVector( Element,Nodes,u,v,.TRUE. ) 3299 3300 ! Check the consistency of sign in the projector 3301 IF( IsSlave .AND. ( FlatProjector .OR. PlaneProjector .OR. NormalProjector ) ) THEN 3302 DotProd = SUM( Normal * ContactNormal ) 3303 IF( DotProd < 0.0 ) THEN 3304 NormalSign = 1 3305 ELSE 3306 NormalSign = -1 3307 END IF 3308 IF( NormalSign0 == 0 ) THEN 3309 NormalSign0 = NormalSign 3310 ELSE 3311 IF( NormalSign0 /= NormalSign ) NormalCount = NormalCount + 1 3312 END IF 3313 END IF 3314 3315 DO i=1,n 3316 j = NormalLoadVar % Perm( Indexes(i) ) 3317 3318 IF( .NOT. NodeDone( Indexes(i) ) ) THEN 3319 NodeDone( Indexes(i) ) = .TRUE. 3320 WeightVar % Values(j) = 0.0_dp 3321 NormalLoadVar % Values(j) = 0.0_dp 3322 SlipLoadVar % Values(j) = 0.0_dp 3323 END IF 3324 3325 k = FieldPerm( Indexes(i) ) 3326 IF( k == 0 .OR. j == 0 ) CYCLE 3327 DO l=1,dofs 3328 NodalForce(l) = LoadValues(dofs*(k-1)+l) 3329 END DO 3330 3331 IF( ThisRotatedContact ) THEN 3332 NormalForce = NodalForce(1) 3333 ELSE 3334 NormalForce = SUM( NodalForce * Normal ) 3335 END IF 3336 SlipForce = SQRT( SUM( NodalForce**2 ) - NormalForce**2 ) 3337 3338 NormalLoadVar % Values(j) = NormalLoadVar % Values(j) - & 3339 s * Basis(i) * NormalForce 3340 SlipLoadVar % Values(j) = SlipLoadVar % Values(j) + & 3341 s * Basis(i) * SlipForce 3342 3343 WeightVar % Values(j) = WeightVar % Values(j) + s * Basis(i) 3344 END DO 3345 3346 END DO 3347 END DO 3348 3349 ! Normalize the computed normal loads such that the unit will be that of pressure 3350 DO i=1,Mesh % NumberOfNodes 3351 IF( NodeDone( i ) ) THEN 3352 j = WeightVar % Perm(i) 3353 SlipLoadVar % Values(j) = SlipLoadVar % Values(j) / WeightVar % Values(j)**2 3354 NormalLoadVar % Values(j) = NormalLoadVar % Values(j) / WeightVar % Values(j)**2 3355 END IF 3356 END DO 3357 3358 IF( LinearContactLoads ) THEN 3359 DO elem=Mesh % NumberOfBulkElements + 1, & 3360 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 3361 3362 Element => Mesh % Elements( elem ) 3363 3364 IsSlave = ( Element % BoundaryInfo % Constraint == Model % BCs(bc_ind) % Tag ) 3365 IsMaster = ( Element % BoundaryInfo % Constraint == Model % BCs(master_ind) % Tag ) 3366 IF( .NOT. ( IsSlave .OR. ( CreateDual .AND. IsMaster ) ) ) CYCLE 3367 3368 Indexes => Element % NodeIndexes 3369 ElemCode = Element % TYPE % ElementCode 3370 3371 SELECT CASE ( ElemCode ) 3372 3373 CASE( 408 ) 3374 DO i=5,8 3375 i1=i-4 3376 i2=i1+1 3377 IF(i2==5) i2=1 3378 j = SlipLoadVar % Perm(Indexes(i)) 3379 j1 = SlipLoadVar % Perm(Indexes(i1)) 3380 j2 = SlipLoadVar % Perm(Indexes(i2)) 3381 SlipLoadVar % Values(j) = 0.5_dp * & 3382 ( SlipLoadVar % Values(j1) + SlipLoadVar % Values(j2)) 3383 NormalLoadVar % Values(j) = 0.5_dp * & 3384 ( NormalLoadVar % Values(j1) + NormalLoadVar % Values(j2)) 3385 END DO 3386 3387 CASE DEFAULT 3388 CALL Fatal(Caller,'Implement linear loads for: '//TRIM(I2S(ElemCode))) 3389 END SELECT 3390 END DO 3391 END IF 3392 3393 IF( FlatProjector .OR. PlaneProjector .OR. NormalProjector ) THEN 3394 IF( NormalCount == 0 ) THEN 3395 CALL Info(Caller,'All normals are consistently signed',Level=10) 3396 ELSE 3397 CALL Warn(Caller,'There are normals with conflicting signs: '& 3398 //TRIM(I2S(NormalCount) ) ) 3399 NormalSign = 1 3400 END IF 3401 CALL Info(Caller,'Normal direction for distance measure: '& 3402 //TRIM(I2S(NormalSign)),Level=8) 3403 DistSign = NormalSign 3404 END IF 3405 3406 ! Check whether the normal sign has been enforced 3407 IF( ListGetLogical( BC,'Normal Sign Negative',Found ) ) DistSign = -1 3408 IF( ListGetLogical( BC,'Normal Sign Positive',Found ) ) DistSign = 1 3409 3410 3411 DEALLOCATE( Basis, Nodes % x, Nodes % y, Nodes % z, NodeDone ) 3412 3413 END SUBROUTINE CalculateContactPressure 3414 3415 3416 3417 ! Sets the contact in the normal direction by looking at the signed distance and 3418 ! contact force. The initial contact set may be enlarged to eliminate null-space 3419 ! related to rigid-body motion. 3420 !---------------------------------------------------------------------------------- 3421 SUBROUTINE NormalContactSet() 3422 3423 INTEGER :: LimitSign, Removed, Added 3424 REAL(KIND=dp) :: DistOffSet, MinLoad, MaxLoad, NodeLoad, MinDist, MaxDist, NodeDist 3425 INTEGER :: i,j,k,ind 3426 LOGICAL :: Found 3427 3428 ! This is related to the formulation of the PDE and is probably fixed for all elasticity solvers 3429 LimitSign = -1 3430 3431 Removed = 0 3432 Added = 0 3433 MinLoad = HUGE(MinLoad) 3434 MaxLoad = -HUGE(MaxLoad) 3435 MinDist = HUGE(MinDist) 3436 MaxDist = -HUGE(MaxDist) 3437 3438 Found = .FALSE. 3439 IF( FirstTime ) THEN 3440 DistOffset = ListGetCReal( BC,& 3441 'Mortar BC Initial Contact Depth',Found) 3442 IF(.NOT. Found ) DistOffset = ListGetCReal( BC,& 3443 'Contact Depth Offset Initial',Found) 3444 END IF 3445 IF( .NOT. Found ) DistOffset = ListGetCReal( BC,& 3446 'Contact Depth Offset',Found) 3447 3448 ! Determine now whether we have contact or not 3449 DO i = 1,Projector % NumberOfRows 3450 j = Projector % InvPerm( i ) 3451 IF( j == 0 ) CYCLE 3452 k = FieldPerm( j ) 3453 IF( k == 0 ) CYCLE 3454 k = NormalLoadVar % Perm(j) 3455 3456 ind = Dofs * (i-1) + DofN 3457 3458 ! Tie contact should always be in contact - if we have found a counterpart 3459 IF( TieContact ) THEN 3460 MortarBC % Active(ind) = .TRUE. 3461 CYCLE 3462 END IF 3463 3464 ! Enforce contact 3465 !------------------------------------------------------ 3466 coeff = ListGetRealAtNode( BC,'Contact Active Condition', j, Found ) 3467 IF( Found .AND. coeff > 0.0_dp ) THEN 3468 MortarBC % Active(ind) = .TRUE. 3469 CYCLE 3470 END IF 3471 3472 ! Enforce no contact 3473 !------------------------------------------------------ 3474 coeff = ListGetRealAtNode( BC,'Contact Passive Condition', j, Found ) 3475 IF( Found .AND. coeff > 0.0_dp ) THEN 3476 MortarBC % Active(ind) = .FALSE. 3477 CYCLE 3478 END IF 3479 3480 ! Free nodes with wrong sign in contact force 3481 !-------------------------------------------------------------------------- 3482 IF( MortarBC % Active( ind ) ) THEN 3483 NodeLoad = NormalLoadVar % Values(k) 3484 MaxLoad = MAX( MaxLoad, NodeLoad ) 3485 MinLoad = MIN( MinLoad, NodeLoad ) 3486 DoRemove = ( LimitSign * NodeLoad > LimitSign * LoadEps ) 3487 IF( DoRemove .AND. ConservativeRemove ) THEN 3488 DoRemove = InterfaceDof(ind) 3489 END IF 3490 IF( DoRemove ) THEN 3491 removed = removed + 1 3492 MortarBC % Active(ind) = .FALSE. 3493 END IF 3494 ELSE 3495 NodeDist = DistVar % Values(k) 3496 MaxDist = MAX( MaxDist, NodeDist ) 3497 MinDist = MIN( MinDist, NodeDist ) 3498 3499 DoAdd = ( NodeDist < -ValEps + DistOffset ) 3500 IF( DoAdd .AND. ConservativeAdd ) THEN 3501 DoAdd = InterfaceDof(ind) 3502 END IF 3503 IF( DoAdd ) THEN 3504 added = added + 1 3505 MortarBC % Active(ind) = .TRUE. 3506 END IF 3507 END IF 3508 END DO 3509 3510 IF( InfoActive(20) ) THEN 3511 IF ( -HUGE(MaxDist) /= MaxDist ) THEN 3512 IF( MaxDist - MinDist >= 0.0_dp ) THEN 3513 PRINT *,'NormalContactSet Dist:',MinDist,MaxDist 3514 END IF 3515 END IF 3516 IF ( -HUGE(MaxLoad) /= MaxLoad) THEN 3517 IF( MaxLoad - MinLoad >= 0.0_dp ) THEN 3518 PRINT *,'NormalContactSet Load:',MinLoad,MaxLoad 3519 END IF 3520 END IF 3521 END IF 3522 3523 IF(added > 0) THEN 3524 WRITE(Message,'(A,I0,A)') 'Added ',added,' nodes to the set' 3525 CALL Info(Caller,Message,Level=6) 3526 END IF 3527 3528 IF(removed > 0) THEN 3529 WRITE(Message,'(A,I0,A)') 'Removed ',removed,' nodes from the set' 3530 CALL Info(Caller,Message,Level=6) 3531 END IF 3532 3533 END SUBROUTINE NormalContactSet 3534 3535 3536 3537 ! If requested add new nodes to the contact set 3538 ! This would be typically done in order to make the elastic problem well defined 3539 ! Without any contact the bodies may float around. 3540 !--------------------------------------------------------------------------------- 3541 SUBROUTINE IncreaseContactSet( LimitedMin ) 3542 INTEGER :: LimitedMin 3543 3544 REAL(KIND=dp), ALLOCATABLE :: DistArray(:) 3545 INTEGER, ALLOCATABLE :: IndArray(:) 3546 REAL(KIND=dp) :: Dist 3547 INTEGER :: i,j,ind,LimitedNow,NewNodes 3548 3549 ! Nothing to do 3550 IF( LimitedMin <= 0 ) RETURN 3551 3552 LimitedNow = COUNT( MortarBC % active(DofN::Dofs) ) 3553 NewNodes = LimitedMin - LimitedNow 3554 IF( NewNodes <= 0 ) RETURN 3555 3556 WRITE(Message,'(A,I0)') 'Initial number of contact nodes for '& 3557 //TRIM(VarName)//': ',LimitedNow 3558 CALL Info(Caller,Message,Level=5) 3559 3560 CALL Info(Caller,& 3561 'Setting '//TRIM(I2S(NewNodes))//' additional contact nodes',Level=5) 3562 3563 ALLOCATE( DistArray( NewNodes ), IndArray( NewNodes ) ) 3564 DistArray = HUGE( DistArray ) 3565 IndArray = 0 3566 3567 ! Find additional contact nodes from the closest non-contact nodes 3568 DO i = 1,Projector % NumberOfRows 3569 ind = Dofs * (i-1) + DofN 3570 IF( MortarBC % Active(ind) ) CYCLE 3571 3572 IF( Projector % InvPerm(i) == 0 ) CYCLE 3573 j = DistVar % Perm(Projector % InvPerm(i)) 3574 Dist = DistVar % Values(j) 3575 3576 IF( Dist < DistArray(NewNodes) ) THEN 3577 DistArray(NewNodes) = Dist 3578 IndArray(NewNodes) = i 3579 3580 ! Order the new nodes such that the last node always has the largest distance 3581 ! This way we only need to compare to the one distance when adding new nodes. 3582 DO j=1,NewNodes-1 3583 IF( DistArray(j) > DistArray(NewNodes) ) THEN 3584 Dist = DistArray(NewNodes) 3585 DistArray(NewNodes) = DistArray(j) 3586 DistArray(j) = Dist 3587 ind = IndArray(NewNodes) 3588 IndArray(NewNodes) = IndArray(j) 3589 IndArray(j) = ind 3590 END IF 3591 END DO 3592 END IF 3593 END DO 3594 3595 IF( ANY( IndArray == 0 ) ) THEN 3596 CALL Fatal(Caller,'Could not define sufficient number of new nodes!') 3597 END IF 3598 3599 WRITE(Message,'(A,ES12.4)') 'Maximum distance needed for new nodes:',DistArray(NewNodes) 3600 CALL Info(Caller,Message,Level=8) 3601 3602 MortarBC % Active( Dofs*(IndArray-1)+DofN ) = .TRUE. 3603 3604 DEALLOCATE( DistArray, IndArray ) 3605 3606 END SUBROUTINE IncreaseContactSet 3607 3608 3609 3610 ! Sets the contact in the tangent direction(s) i.e. the stick condition. 3611 ! Stick condition in 1st and 2nd tangent condition are always the same. 3612 !---------------------------------------------------------------------------------- 3613 SUBROUTINE TangentContactSet() 3614 3615 INTEGER :: Removed0, Removed, Added 3616 REAL(KIND=dp) :: NodeLoad, TangentLoad, mustatic, mudynamic, stickcoeff, & 3617 Fstatic, Fdynamic, Ftangent, du(3), Slip 3618 INTEGER :: i,j,k,l,ind,IndN, IndT1, IndT2 3619 LOGICAL :: Found 3620 3621 IF( FrictionContact .AND. & 3622 ListGetLogical( BC,'Stick Contact Global',Found ) ) THEN 3623 3624 ! Sum up global normal and slide forces 3625 DO i = 1,Projector % NumberOfRows 3626 j = Projector % InvPerm( i ) 3627 IF( j == 0 ) CYCLE 3628 k = FieldPerm( j ) 3629 IF( k == 0 ) CYCLE 3630 k = NormalLoadVar % Perm(j) 3631 3632 ! If there is no contact there can be no stick either 3633 indN = Dofs * (i-1) + DofN 3634 IF( .NOT. MortarBC % Active(indN) ) CYCLE 3635 3636 NodeLoad = NormalLoadVar % Values(k) 3637 TangentLoad = SlipLoadVar % Values(k) 3638 3639 mustatic = ListGetRealAtNode( BC,'Static Friction Coefficient', j ) 3640 mudynamic = ListGetRealAtNode( BC,'Dynamic Friction Coefficient', j ) 3641 IF( mustatic <= mudynamic ) THEN 3642 CALL Warn('TangentContactSet','Static friction coefficient should be larger than dynamic!') 3643 END IF 3644 3645 Fstatic = Fstatic + mustatic * ABS( NodeLoad ) 3646 Fdynamic = Fdynamic + mudynamic * ABS( NodeLoad ) 3647 Ftangent = Ftangent + ABS( TangentLoad ) 3648 IF( Ftangent > Fstatic ) THEN 3649 SlipContact = .TRUE. 3650 FrictionContact = .FALSE. 3651 ELSE 3652 GOTO 100 3653 END IF 3654 END DO 3655 END IF 3656 3657 3658 ! For stick and tie contact inherit the active flag from the normal component 3659 IF( SlipContact ) THEN 3660 MortarBC % Active( DofT1 :: Dofs ) = .FALSE. 3661 IF( Dofs == 3 ) THEN 3662 MortarBC % Active( DofT2 :: Dofs ) = .FALSE. 3663 END IF 3664 GOTO 100 3665 ELSE IF( StickContact .OR. TieContact ) THEN 3666 MortarBC % Active( DofT1 :: Dofs ) = MortarBC % Active( DofN :: Dofs ) 3667 IF( Dofs == 3 ) THEN 3668 MortarBC % Active( DofT2 :: Dofs ) = MortarBC % Active( DofN :: Dofs ) 3669 END IF 3670 GOTO 100 3671 END IF 3672 3673 CALL Info('TangentContactSet','Setting the stick set tangent components',Level=10) 3674 3675 Removed0 = 0 3676 Removed = 0 3677 Added = 0 3678 3679 ! Determine now whether we have contact or not 3680 DO i = 1,Projector % NumberOfRows 3681 j = Projector % InvPerm( i ) 3682 IF( j == 0 ) CYCLE 3683 k = FieldPerm( j ) 3684 IF( k == 0 ) CYCLE 3685 k = NormalLoadVar % Perm(j) 3686 3687 indN = Dofs * (i-1) + DofN 3688 indT1 = ind - DofN + DofT1 3689 IF(Dofs == 3 ) indT2 = ind - DofN + DofT2 3690 3691 ! If there is no contact there can be no stick either 3692 IF( .NOT. MortarBC % Active(indN) ) THEN 3693 IF( MortarBC % Active(indT1) ) THEN 3694 removed0 = removed0 + 1 3695 MortarBC % Active(indT1) = .FALSE. 3696 IF( Dofs == 3 ) MortarBC % Active(indT2) = .FALSE. 3697 END IF 3698 CYCLE 3699 END IF 3700 3701 ! Ok, we have normal contact what about stick 3702 ! Enforce stick condition 3703 !------------------------------------------------------ 3704 coeff = ListGetRealAtNode( BC,'Stick Active Condition', j, Found ) 3705 IF( Found .AND. coeff > 0.0_dp ) THEN 3706 IF( .NOT. MortarBC % Active(indT1) ) added = added + 1 3707 MortarBC % Active(indT1) = .TRUE. 3708 IF( Dofs == 3 ) MortarBC % Active(indT2) = .TRUE. 3709 CYCLE 3710 END IF 3711 3712 ! Enforce no-stick condition (=slip) 3713 !------------------------------------------------------ 3714 coeff = ListGetRealAtNode( BC,'Stick Passive Condition', j, Found ) 3715 IF( Found .AND. coeff > 0.0_dp ) THEN 3716 IF( MortarBC % Active(IndT1) ) removed = removed + 1 3717 MortarBC % Active(indT1) = .FALSE. 3718 IF( Dofs == 3 ) MortarBC % Active(indT2) = .FALSE. 3719 CYCLE 3720 END IF 3721 3722 ! Remove nodes with too large tangent force 3723 !-------------------------------------------------------------------------- 3724 3725 NodeLoad = NormalLoadVar % Values(k) 3726 TangentLoad = SlipLoadVar % Values(k) 3727 3728 mustatic = ListGetRealAtNode( BC,'Static Friction Coefficient', j ) 3729 mudynamic = ListGetRealAtNode( BC,'Dynamic Friction Coefficient', j ) 3730 3731 IF( mustatic <= mudynamic ) THEN 3732 CALL Warn('TangentContactSet','Static friction coefficient should be larger than dynamic!') 3733 END IF 3734 3735 IF( MortarBC % Active(IndT1) ) THEN 3736 IF( TangentLoad > mustatic * ABS( NodeLoad ) ) THEN 3737 removed = removed + 1 3738 MortarBC % Active(indT1) = .FALSE. 3739 IF( Dofs == 3 ) MortarBC % Active(indT2) = .FALSE. 3740 END IF 3741 ELSE 3742 stickcoeff = ListGetRealAtNode( BC,'Stick Contact Coefficient', j, Found ) 3743 IF( Found ) THEN 3744 DO l=1,Dofs 3745 du(l) = VeloVar % Values( Dofs*(k-1)+l ) 3746 END DO 3747 IF( Dofs == 3 ) THEN 3748 Slip = SQRT(du(dofT1)**2 + du(DofT2)**2) 3749 ELSE 3750 Slip = ABS( du(dofT1) ) 3751 END IF 3752 IF( stickcoeff * slip < mudynamic * ABS( NodeLoad ) ) THEN 3753 added = added + 1 3754 MortarBC % Active(indT1) = .TRUE. 3755 IF( Dofs == 3 ) MortarBC % Active(indT2) = .TRUE. 3756 END IF 3757 END IF 3758 END IF 3759 END DO 3760 3761 IF(added > 0) THEN 3762 WRITE(Message,'(A,I0,A)') 'Added ',added,' nodes to the stick set' 3763 CALL Info(Caller,Message,Level=6) 3764 END IF 3765 3766 IF(removed0 > 0) THEN 3767 WRITE(Message,'(A,I0,A)') 'Removed ',removed0,' non-contact nodes from the stick set' 3768 CALL Info(Caller,Message,Level=6) 3769 END IF 3770 3771 IF(removed > 0) THEN 3772 WRITE(Message,'(A,I0,A)') 'Removed ',removed,' sliding nodes from the stick set' 3773 CALL Info(Caller,Message,Level=6) 3774 END IF 3775 3776 3777100 CALL Info(Caller,'Creating fields out of normal and stick contact sets',Level=10) 3778 3779 DO i = 1, Projector % NumberOfRows 3780 j = Projector % InvPerm(i) 3781 IF( j == 0 ) CYCLE 3782 k = NormalActiveVar % Perm(j) 3783 3784 IF( MortarBC % Active(Dofs*(i-1)+DofN) ) THEN 3785 NormalActiveVar % Values(k) = 1.0_dp 3786 ELSE 3787 NormalActiveVar % Values(k) = -1.0_dp 3788 END IF 3789 3790 IF( MortarBC % Active(Dofs*(i-1)+DofT1) ) THEN 3791 StickActiveVar % Values(k) = 1.0_dp 3792 ELSE 3793 StickActiveVar % Values(k) = -1.0_dp 3794 END IF 3795 END DO 3796 3797 END SUBROUTINE TangentContactSet 3798 3799 3800 3801 ! Sets the diagonal entry for slip in the tangent direction(s). 3802 ! This coefficient may be used to relax the stick condition, and also to 3803 ! revert back nodes from slip to stick set. 3804 !---------------------------------------------------------------------------------- 3805 SUBROUTINE StickCoefficientSet() 3806 3807 REAL(KIND=dp) :: NodeLoad, TangentLoad 3808 INTEGER :: i,j,k,ind,IndN, IndT1, IndT2 3809 LOGICAL :: Found 3810 3811 CALL Info('StickCoefficientSet','Setting the stick coefficient entry for tangent components at stick',Level=10) 3812 3813 ! Determine now whether we have contact or not 3814 DO i = 1,Projector % NumberOfRows 3815 j = Projector % InvPerm( i ) 3816 IF( j == 0 ) CYCLE 3817 k = FieldPerm( j ) 3818 IF( k == 0 ) CYCLE 3819 k = NormalLoadVar % Perm(j) 3820 3821 indN = Dofs * (i-1) + DofN 3822 indT1 = Dofs * (i-1) + DofT1 3823 IF(Dofs == 3 ) indT2 = Dofs * (i-1) + DofT2 3824 3825 IF( .NOT. MortarBC % Active(indN) ) THEN 3826 ! If there is no contact there can be no stick either 3827 coeff = 0.0_dp 3828 ELSE IF( .NOT. MortarBC % Active(indT1) ) THEN 3829 ! If there is no stick there can be no stick coefficient either 3830 coeff = 0.0_dp 3831 ELSE 3832 ! Get the stick coefficient 3833 coeff = ListGetRealAtNode( BC,'Stick Contact Coefficient', j ) 3834 END IF 3835 3836 MortarBC % Diag(indT1) = coeff 3837 IF( Dofs == 3 ) MortarBC % Diag(indT2) = coeff 3838 END DO 3839 3840 END SUBROUTINE StickCoefficientSet 3841 3842 3843 3844 ! Here we eliminate the middle nodes from the higher order elements if they 3845 ! are different than both nodes of which they are associated with. 3846 ! There is no way geometric information could be accurate enough to allow 3847 ! such contacts to exist. 3848 !--------------------------------------------------------------------------- 3849 SUBROUTINE QuadraticContactSet() 3850 3851 LOGICAL :: ElemActive(8) 3852 INTEGER :: i,j,k,n,added, removed, elem, elemcode, ElemInds(8) 3853 INTEGER, POINTER :: Indexes(:) 3854 3855 added = 0 3856 removed = 0 3857 3858 DO elem=Mesh % NumberOfBulkElements + 1, & 3859 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 3860 3861 Element => Mesh % Elements( elem ) 3862 3863 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc_ind) % Tag ) CYCLE 3864 3865 Indexes => Element % NodeIndexes 3866 n = Element % TYPE % NumberOfNodes 3867 elemcode = Element % Type % ElementCode 3868 3869 DO i=1,n 3870 ElemActive(i) = MortarBC % Active( ElemInds(i) ) 3871 IF(j>0) THEN 3872 ElemInds(i) = Dofs * ( j - 1) + DofN 3873 ElemActive(i) = MortarBC % Active( ElemInds(i) ) 3874 ELSE 3875 ElemActive(i) = .FALSE. 3876 END IF 3877 END DO 3878 3879 SELECT CASE ( elemcode ) 3880 3881 CASE( 202, 303, 404 ) 3882 CONTINUE 3883 3884 CASE( 203 ) 3885 IF( ( ElemActive(1) .EQV. ElemActive(2) ) & 3886 .AND. ( ElemActive(1) .NEQV. ElemActive(3) ) ) THEN 3887 MortarBC % Active( ElemInds(3) ) = ElemActive(1) 3888 IF( ElemActive(1) ) THEN 3889 added = added + 1 3890 ELSE 3891 removed = removed + 1 3892 END IF 3893 END IF 3894 3895 CASE( 306 ) 3896 IF( ( ElemActive(1) .EQV. ElemActive(2) ) & 3897 .AND. ( ElemActive(1) .NEQV. ElemActive(4) ) ) THEN 3898 MortarBC % Active( ElemInds(4) ) = ElemActive(1) 3899 IF( ElemActive(1) ) THEN 3900 added = added + 1 3901 ELSE 3902 removed = removed + 1 3903 END IF 3904 END IF 3905 3906 IF( ( ElemActive(2) .EQV. ElemActive(3) ) & 3907 .AND. ( ElemActive(2) .NEQV. ElemActive(5) ) ) THEN 3908 MortarBC % Active( ElemInds(5) ) = ElemActive(2) 3909 IF( ElemActive(2) ) THEN 3910 added = added + 1 3911 ELSE 3912 removed = removed + 1 3913 END IF 3914 END IF 3915 3916 IF( ( ElemActive(3) .EQV. ElemActive(1) ) & 3917 .AND. ( ElemActive(3) .NEQV. ElemActive(6) ) ) THEN 3918 MortarBC % Active( ElemInds(6) ) = ElemActive(3) 3919 IF( ElemActive(3) ) THEN 3920 added = added + 1 3921 ELSE 3922 removed = removed + 1 3923 END IF 3924 END IF 3925 3926 CASE( 408 ) 3927 IF( ( ElemActive(1) .EQV. ElemActive(2) ) & 3928 .AND. ( ElemActive(1) .NEQV. ElemActive(5) ) ) THEN 3929 MortarBC % Active( ElemInds(5) ) = ElemActive(1) 3930 IF( ElemActive(1) ) THEN 3931 added = added + 1 3932 ELSE 3933 removed = removed + 1 3934 END IF 3935 END IF 3936 3937 IF( ( ElemActive(2) .EQV. ElemActive(3) ) & 3938 .AND. ( ElemActive(2) .NEQV. ElemActive(6) ) ) THEN 3939 MortarBC % Active( ElemInds(6) ) = ElemActive(2) 3940 IF( ElemActive(2) ) THEN 3941 added = added + 1 3942 ELSE 3943 removed = removed + 1 3944 END IF 3945 END IF 3946 3947 IF( ( ElemActive(3) .EQV. ElemActive(4) ) & 3948 .AND. ( ElemActive(3) .NEQV. ElemActive(7) ) ) THEN 3949 MortarBC % Active( ElemInds(7) ) = ElemActive(3) 3950 IF( ElemActive(3) ) THEN 3951 added = added + 1 3952 ELSE 3953 removed = removed + 1 3954 END IF 3955 END IF 3956 3957 IF( ( ElemActive(4) .EQV. ElemActive(1) ) & 3958 .AND. ( ElemActive(4) .NEQV. ElemActive(8) ) ) THEN 3959 MortarBC % Active( ElemInds(8) ) = ElemActive(4) 3960 IF( ElemActive(4) ) THEN 3961 added = added + 1 3962 ELSE 3963 removed = removed + 1 3964 END IF 3965 END IF 3966 3967 CASE DEFAULT 3968 CALL Fatal(Caller,'Cannot deal with element: '//TRIM(I2S(elemcode))) 3969 3970 END SELECT 3971 END DO 3972 3973 IF(added > 0) THEN 3974 WRITE(Message,'(A,I0,A)') 'Added ',added,' quadratic nodes to contact set' 3975 CALL Info(Caller,Message,Level=6) 3976 END IF 3977 3978 IF(removed > 0) THEN 3979 WRITE(Message,'(A,I0,A)') 'Removed ',removed,' quadratic nodes from contact set' 3980 CALL Info(Caller,Message,Level=6) 3981 END IF 3982 3983 END SUBROUTINE QuadraticContactSet 3984 3985 3986 ! Project contact fields from slave to master 3987 !---------------------------------------------------------------------------------------- 3988 SUBROUTINE ProjectFromSlaveToMaster() 3989 3990 REAL(KIND=dp) :: Disp(3), Coord(3), PrevDisp(3), Velo(3), ContactVelo(3), & 3991 LocalNormal0(3), SlipCoord(3) 3992 REAL(KIND=dp), POINTER :: DispVals(:), PrevDispVals(:) 3993 REAL(KIND=dp) :: MinDist, MaxDist, CoeffEps 3994 LOGICAL, ALLOCATABLE :: SlaveNode(:), NodeDone(:) 3995 REAL(KIND=dp), ALLOCATABLE :: CoeffTable(:), RealActive(:) 3996 INTEGER :: i,j,k,l,l2 3997 3998 CALL Info(Caller,'Mapping entities from slave to master',Level=10) 3999 4000 ALLOCATE( SlaveNode( Mesh % NumberOfNodes ) ) 4001 SlaveNode = .FALSE. 4002 4003 DO i=Mesh % NumberOfBulkElements + 1, & 4004 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 4005 4006 Element => Mesh % Elements( i ) 4007 IF( Element % BoundaryInfo % Constraint == Model % BCs(bc_ind) % Tag ) THEN 4008 SlaveNode( Element % NodeIndexes ) = .TRUE. 4009 END IF 4010 END DO 4011 4012 n = SIZE( DistVar % Values ) 4013 ALLOCATE( CoeffTable( n ), NodeDone( n ) ) 4014 4015 4016 CoeffTable = 0.0_dp 4017 NodeDone = .FALSE. 4018 4019 4020 DO i = 1,Projector % NumberOfRows 4021 4022 IF( Projector % InvPerm(i) == 0 ) CYCLE 4023 l = DistVar % Perm( Projector % InvPerm(i) ) 4024 4025 DO j = Projector % Rows(i),Projector % Rows(i+1)-1 4026 k = Projector % Cols(j) 4027 4028 IF( FieldPerm( k ) == 0 ) CYCLE 4029 IF( SlaveNode( k ) ) CYCLE 4030 4031 coeff = Projector % Values(j) 4032 4033 l2 = DistVar % Perm( k ) 4034 4035 IF(.NOT. NodeDone( l2 ) ) THEN 4036 DistVar % Values( l2 ) = 0.0_dp 4037 GapVar % Values( l2 ) = 0.0_dp 4038 NormalActiveVar % Values( l2 ) = 0.0_dp 4039 StickActiveVar % Values( l2 ) = 0.0_dp 4040 NormalLoadVar % Values( l2 ) = 0.0_dp 4041 SlipLoadVar % Values( l2 ) = 0.0_dp 4042 IF( CalculateVelocity ) THEN 4043 DO k=1,Dofs 4044 VeloVar % Values( Dofs*(l2-1)+k ) = 0.0_dp 4045 END DO 4046 END IF 4047 NodeDone( l2 ) = .TRUE. 4048 END IF 4049 4050 CoeffTable( l2 ) = CoeffTable( l2 ) + coeff 4051 DistVar % Values( l2 ) = DistVar % Values( l2 ) + coeff * DistVar % Values( l ) 4052 GapVar % Values( l2 ) = GapVar % Values( l2 ) + coeff * GapVar % Values( l ) 4053 NormalActiveVar % Values( l2 ) = NormalActiveVar % Values( l2 ) + coeff * NormalActiveVar % Values( l ) 4054 StickActiveVar % Values( l2 ) = StickActiveVar % Values( l2 ) + coeff * StickActiveVar % Values( l ) 4055 NormalLoadVar % Values( l2 ) = NormalLoadVar % Values( l2 ) + coeff * NormalLoadVar % Values( l ) 4056 SlipLoadVar % Values( l2 ) = SlipLoadVar % Values( l2 ) + coeff * SlipLoadVar % Values( l ) 4057 IF( CalculateVelocity ) THEN 4058 DO k=1,Dofs 4059 VeloVar % Values( Dofs*(l2-1)+k ) = VeloVar % Values( Dofs*(l2-1)+k ) + & 4060 coeff * VeloVar % Values( Dofs*(l-1)+k) 4061 END DO 4062 END IF 4063 END DO 4064 END DO 4065 4066 CoeffEps = 1.0d-8 * MAXVAL( ABS( CoeffTable ) ) 4067 DO i=1,SIZE( CoeffTable ) 4068 IF( NodeDone( i ) .AND. ( ABS( CoeffTable(i) ) > CoeffEps ) ) THEN 4069 DistVar % Values( i ) = DistVar % Values( i ) / CoeffTable( i ) 4070 GapVar % Values( i ) = GapVar % Values( i ) / CoeffTable( i ) 4071 NormalActiveVar % Values( i ) = NormalActiveVar % Values( i ) / CoeffTable( i ) 4072 StickActiveVar % Values( i ) = StickActiveVar % Values( i ) / CoeffTable( i ) 4073 4074 IF( NormalActiveVar % Values( i ) >= 0.0_dp ) THEN 4075 NormalLoadVar % Values( i ) = NormalLoadVar % Values( i ) / CoeffTable( i ) 4076 SlipLoadVar % Values( i ) = SlipLoadVar % Values( i ) / CoeffTable( i ) 4077 IF( CalculateVelocity ) THEN 4078 DO k=1,Dofs 4079 VeloVar % Values( Dofs*(i-1)+k ) = VeloVar % Values( Dofs*(i-1)+k ) / CoeffTable( i ) 4080 END DO 4081 END IF 4082 ELSE 4083 NormalLoadVar % Values( i ) = 0.0_dp 4084 SlipLoadVar % Values( i ) = 0.0_dp 4085 IF( CalculateVelocity ) THEN 4086 DO k=1,Dofs 4087 VeloVar % Values( Dofs*(i-1)+k ) = 0.0_dp 4088 END DO 4089 END IF 4090 END IF 4091 4092 END IF 4093 END DO 4094 4095 DO i = 1, Projector % NumberOfRows 4096 j = Projector % InvPerm(i) 4097 IF( j == 0 ) CYCLE 4098 k = NormalActiveVar % Perm(j) 4099 4100 IF( NormalActiveVar % Values( k ) < 0.0_dp ) THEN 4101 IF( CalculateVelocity ) THEN 4102 DO l=1,Dofs 4103 VeloVar % Values( Dofs*(k-1)+l ) = 0.0_dp 4104 END DO 4105 END IF 4106 END IF 4107 END DO 4108 4109 4110 END SUBROUTINE ProjectFromSlaveToMaster 4111 4112 4113 4114 ! Set the friction in an implicit manner by copying matrix rows of the normal component 4115 ! to matrix rows of the tangential component multiplied by friction coefficient and 4116 ! direction vector. 4117 !--------------------------------------------------------------------------------------- 4118 SUBROUTINE SetSlideFriction() 4119 4120 REAL(KIND=dp), POINTER :: Values(:) 4121 LOGICAL, ALLOCATABLE :: NodeDone(:) 4122 REAL(KIND=dp) :: Coeff, ActiveLimit 4123 TYPE(Element_t), POINTER :: Element 4124 INTEGER, POINTER :: NodeIndexes(:) 4125 INTEGER :: i,j,k,k2,k3,l,l2,l3,n,t 4126 TYPE(Matrix_t), POINTER :: A 4127 LOGICAL :: Slave, Master, GivenDirection 4128 REAL(KIND=dp), POINTER :: VeloDir(:,:) 4129 REAL(KIND=dp) :: VeloCoeff(3),AbsVeloCoeff 4130 INTEGER :: VeloSign = 1 4131 4132 4133 IF(.NOT. ListCheckPresent( BC, 'Dynamic Friction Coefficient') ) RETURN 4134 4135 CALL Info(Caller,'Setting contact friction for boundary',Level=10) 4136 4137 GivenDirection = ListCheckPresent( BC,'Contact Velocity') 4138 IF(.NOT. GivenDirection ) THEN 4139 IF(.NOT. ASSOCIATED( VeloVar ) ) THEN 4140 CALL Fatal(Caller,'Contact velocity must be given in some way') 4141 END IF 4142 END IF 4143 4144 ActiveLimit = 0.0_dp 4145 4146 Values => Solver % Matrix % values 4147 ALLOCATE( NodeDone( SIZE( FieldPerm ) ) ) 4148 A => Solver % Matrix 4149 4150 NodeDone = .FALSE. 4151 Coeff = 0.0_dp 4152 4153 DO t = Mesh % NumberOfBulkElements+1, & 4154 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 4155 Element => Mesh % Elements(t) 4156 4157 Model % CurrentElement => Element 4158 4159 Slave = ( Element % BoundaryInfo % Constraint == Model % BCs(bc_ind) % Tag ) 4160 Master = ( Element % BoundaryInfo % Constraint == Model % BCs(master_ind) % Tag ) 4161 4162 IF( .NOT. ( Slave .OR. Master ) ) CYCLE 4163 4164 NodeIndexes => Element % NodeIndexes 4165 n = Element % TYPE % NumberOfNodes 4166 4167 DO i = 1, n 4168 j = Nodeindexes(i) 4169 4170 IF( NodeDone( j ) ) CYCLE 4171 IF( FieldPerm( j ) == 0 ) CYCLE 4172 4173 ! Skipping the nodes not in the boundary 4174 k = NormalActiveVar % Perm( j ) 4175 IF( k == 0 ) CYCLE 4176 4177 ! Skipping the nodes not in contact. 4178 IF( NormalActiveVar % Values( k ) <= -ActiveLimit ) CYCLE 4179 4180 ! skipping the nodes in tangent stick 4181 IF( StickActiveVar % Values( k ) >= ActiveLimit ) CYCLE 4182 4183 NodeDone( j ) = .TRUE. 4184 4185 IF( Slave ) THEN 4186 Coeff = ListGetRealAtNode( BC,& 4187 'Dynamic Friction Coefficient', j, Found ) 4188 ELSE 4189 Coeff = ListGetRealAtNode( MasterBC,& 4190 'Dynamic Friction Coefficient', j, Found ) 4191 ! If friction not found in master then use the friction coefficient of the slave 4192 ! Ideally they should be the same. 4193 IF(.NOT. Found ) THEN 4194 Coeff = ListGetRealAtNode( BC,& 4195 'Dynamic Friction Coefficient', j, Found ) 4196 END IF 4197 END IF 4198 4199 ! There is no point of setting too small friction coefficient 4200 IF(ABS(Coeff) < 1.0d-10) CYCLE 4201 4202 IF( ThisRotatedContact ) THEN 4203 Rotated = GetSolutionRotation(NTT, j ) 4204 LocalNormal = NTT(:,1) 4205 LocalT1 = NTT(:,2) 4206 IF( Dofs == 3 ) LocalT2 = NTT(:,3) 4207 ELSE 4208 Rotated = .FALSE. 4209 LocalNormal = ContactNormal 4210 LocalT1 = ContactT1 4211 IF( Dofs == 3 ) LocalT2 = ContactT2 4212 END IF 4213 4214 VeloCoeff = 0.0_dp 4215 VeloSign = 1 4216 4217 IF( GivenDirection ) THEN 4218 IF( Slave ) THEN 4219 VeloDir => ListGetConstRealArray( BC, & 4220 'Contact Velocity', Found) 4221 ELSE 4222 VeloDir => ListGetConstRealArray( MasterBC, & 4223 'Contact Velocity', Found) 4224 IF(.NOT. Found ) THEN 4225 ! If velocity direction not found in master then use the opposite velocity of the slave 4226 VeloDir => ListGetConstRealArray( BC, & 4227 'Contact Velocity', Found) 4228 VeloSign = -1 4229 END IF 4230 END IF 4231 VeloCoeff(DofT1) = SUM( VeloDir(1:3,1) * LocalT1 ) 4232 IF( Dofs == 3 ) THEN 4233 VeloCoeff(DofT2) = SUM( VeloDir(1:3,1) * LocalT2 ) 4234 END IF 4235 ELSE 4236 VeloCoeff(DofT1) = VeloVar % Values(Dofs*(k-1)+DofT1) 4237 IF(Dofs==3) VeloCoeff(DofT2) = VeloVar % Values(Dofs*(k-1)+DofT2) 4238 IF( .NOT. Slave .AND. .NOT. Rotated ) THEN 4239 VeloSign = -1 4240 END IF 4241 END IF 4242 4243 ! Normalize coefficient to unity so that it only represents the direction of the force 4244 4245 AbsVeloCoeff = SQRT( SUM( VeloCoeff**2 ) ) 4246 IF( AbsVeloCoeff > TINY(AbsVeloCoeff) ) THEN 4247 VeloCoeff = VeloSign * VeloCoeff / AbsVeloCoeff 4248 ELSE 4249 CYCLE 4250 END IF 4251 4252 ! Add the friction coefficient 4253 VeloCoeff = Coeff * VeloCoeff 4254 4255 j = FieldPerm( j ) 4256 k = DOFs * (j-1) + DofN 4257 4258 k2 = DOFs * (j-1) + DofT1 4259 A % Rhs(k2) = A % Rhs(k2) - VeloCoeff(DofT1) * A % Rhs(k) 4260 4261 IF( Dofs == 3 ) THEN 4262 k3 = DOFs * (j-1) + DofT2 4263 A % Rhs(k3) = A % Rhs(k3) - VeloCoeff(DofT2) * A % Rhs(k) 4264 END IF 4265 4266 DO l = A % Rows(k),A % Rows(k+1)-1 4267 DO l2 = A % Rows(k2), A % Rows(k2+1)-1 4268 IF( A % Cols(l2) == A % Cols(l) ) EXIT 4269 END DO 4270 4271 A % Values(l2) = A % Values(l2) - VeloCoeff(DofT1) * A % Values(l) 4272 4273 IF( Dofs == 3 ) THEN 4274 DO l3 = A % Rows(k3), A % Rows(k3+1)-1 4275 IF( A % Cols(l3) == A % Cols(l) ) EXIT 4276 END DO 4277 A % Values(l3) = A % Values(l3) - VeloCoeff(DofT2) * A % Values(l) 4278 END IF 4279 END DO 4280 END DO 4281 END DO 4282 4283 n = COUNT( NodeDone ) 4284 CALL Info('SetSlideFriction','Number of friction nodes: '//TRIM(I2S(n)),Level=10) 4285 4286 DEALLOCATE( NodeDone ) 4287 4288 END SUBROUTINE SetSlideFriction 4289 4290 4291 END SUBROUTINE DetermineContact 4292 4293 4294 4295!> Sets one Dirichlet condition to the desired value 4296!------------------------------------------------------------------------------ 4297 SUBROUTINE UpdateDirichletDof( A, dof, dval ) 4298!------------------------------------------------------------------------------ 4299 TYPE(Matrix_t) :: A 4300 INTEGER :: dof 4301 REAL(KIND=dp) :: dval 4302 4303 IF(.NOT. ALLOCATED(A % ConstrainedDOF)) THEN 4304 ALLOCATE(A % ConstrainedDOF(A % NumberOfRows)) 4305 A % ConstrainedDOF = .FALSE. 4306 END IF 4307 4308 IF(.NOT. ALLOCATED(A % Dvalues)) THEN 4309 ALLOCATE(A % Dvalues(A % NumberOfRows)) 4310 A % Dvalues = 0._dp 4311 END IF 4312 4313 A % Dvalues( dof ) = dval 4314 A % ConstrainedDOF( dof ) = .TRUE. 4315 4316 END SUBROUTINE UpdateDirichletDof 4317!------------------------------------------------------------------------------ 4318 4319 4320!------------------------------------------------------------------------------ 4321 SUBROUTINE UpdateDirichletDofC( A, dof, cval ) 4322!------------------------------------------------------------------------------ 4323 TYPE(Matrix_t) :: A 4324 INTEGER :: dof 4325 COMPLEX(KIND=dp) :: cval 4326 4327 IF(.NOT. ALLOCATED(A % ConstrainedDOF)) THEN 4328 ALLOCATE(A % ConstrainedDOF(A % NumberOfRows)) 4329 A % ConstrainedDOF = .FALSE. 4330 END IF 4331 4332 IF(.NOT. ALLOCATED(A % Dvalues)) THEN 4333 ALLOCATE(A % Dvalues(A % NumberOfRows)) 4334 A % Dvalues = 0._dp 4335 END IF 4336 4337 A % Dvalues( 2*dof-1 ) = REAL( cval ) 4338 A % ConstrainedDOF( 2*dof-1 ) = .TRUE. 4339 4340 A % Dvalues( 2*dof ) = AIMAG( cval ) 4341 A % ConstrainedDOF( 2*dof ) = .TRUE. 4342 4343 END SUBROUTINE UpdateDirichletDofC 4344!------------------------------------------------------------------------------ 4345 4346 4347 4348 4349!> Releases one Dirichlet condition 4350!------------------------------------------------------------------------------ 4351 SUBROUTINE ReleaseDirichletDof( A, dof ) 4352!------------------------------------------------------------------------------ 4353 TYPE(Matrix_t) :: A 4354 INTEGER :: dof 4355 REAL(KIND=dp) :: dval 4356 4357 IF(.NOT. ALLOCATED(A % ConstrainedDOF)) THEN 4358 ALLOCATE(A % ConstrainedDOF(A % NumberOfRows)) 4359 A % ConstrainedDOF = .FALSE. 4360 END IF 4361 4362 IF(.NOT.ALLOCATED(A % Dvalues)) THEN 4363 ALLOCATE(A % Dvalues(A % NumberOfRows)) 4364 A % Dvalues = 0._dp 4365 END IF 4366 4367 A % ConstrainedDOF( dof ) = .FALSE. 4368 4369 END SUBROUTINE ReleaseDirichletDof 4370!------------------------------------------------------------------------------ 4371 4372 4373 4374!> Release the range or min/max values of Dirichlet values. 4375!------------------------------------------------------------------------------ 4376 FUNCTION DirichletDofsRange( Solver, Oper ) RESULT ( val ) 4377!------------------------------------------------------------------------------ 4378 TYPE(Solver_t), OPTIONAL :: Solver 4379 CHARACTER(LEN=*), OPTIONAL :: Oper 4380 REAL(KIND=dp) :: val 4381 4382 TYPE(Matrix_t), POINTER :: A 4383 REAL(KIND=dp) :: minv,maxv 4384 LOGICAL :: FindMin, FindMax 4385 INTEGER :: i,OperNo 4386 4387 IF( PRESENT( Solver ) ) THEN 4388 A => Solver % Matrix 4389 ELSE 4390 A => CurrentModel % Solver % Matrix 4391 END IF 4392 4393 val = 0.0_dp 4394 4395 ! Defaulting to range 4396 OperNo = 0 4397 4398 IF( PRESENT( Oper ) ) THEN 4399 IF( Oper == 'range' ) THEN 4400 OperNo = 0 4401 ELSE IF( Oper == 'min' ) THEN 4402 OperNo = 1 4403 ELSE IF( Oper == 'max' ) THEN 4404 OperNo = 2 4405 ELSE 4406 CALL Fatal('DirichletDofsRange','Unknown operator: '//TRIM(Oper)) 4407 END IF 4408 END IF 4409 4410 IF(.NOT. ALLOCATED(A % ConstrainedDOF)) THEN 4411 RETURN 4412 END IF 4413 4414 IF( OperNo == 0 .OR. OperNo == 1 ) THEN 4415 minv = HUGE( minv ) 4416 DO i=1,SIZE( A % ConstrainedDOF ) 4417 IF( A % ConstrainedDOF(i) ) minv = MIN( A % DValues(i), minv ) 4418 END DO 4419 minv = ParallelReduction( minv, 1 ) 4420 END IF 4421 4422 IF( OperNo == 0 .OR. OperNo == 2 ) THEN 4423 maxv = -HUGE( maxv ) 4424 DO i=1,SIZE( A % ConstrainedDOF ) 4425 IF( A % ConstrainedDOF(i) ) maxv = MAX( A % DValues(i), maxv ) 4426 END DO 4427 maxv = ParallelReduction( maxv, 2 ) 4428 END IF 4429 4430 IF( OperNo == 0 ) THEN 4431 val = maxv - minv 4432 ELSE IF( OperNo == 1 ) THEN 4433 val = minv 4434 ELSE 4435 val = maxv 4436 END IF 4437 4438 END FUNCTION DirichletDofsRange 4439!------------------------------------------------------------------------------ 4440 4441 4442 4443 4444!------------------------------------------------------------------------------ 4445!> Set dirichlet boundary condition for given dof. The conditions are 4446!> set based on the given name and applied directly to the matrix structure 4447!> so that a row is zeroed except for the diagonal which is set to one. 4448!> Then the r.h.s. value determines the value of the field variable 4449!> in the solution of the linear system. 4450!------------------------------------------------------------------------------ 4451 SUBROUTINE SetDirichletBoundaries( Model, A, b, Name, DOF, NDOFs, Perm, & 4452 PermOffSet, OffDiagonalMatrix ) 4453!------------------------------------------------------------------------------ 4454 TYPE(Model_t) :: Model !< The current model structure 4455 TYPE(Matrix_t), POINTER :: A !< The global matrix 4456 REAL(KIND=dp) :: b(:) !< The global RHS vector 4457 CHARACTER(LEN=*) :: Name !< Name of the dof to be set 4458 INTEGER :: DOF !< The order number of the dof 4459 INTEGER :: NDOFs !< The total number of DOFs for this equation 4460 INTEGER :: Perm(:) !< The node reordering info, this has been generated at the beginning of the 4461 !< simulation for bandwidth optimization 4462 INTEGER, OPTIONAL :: PermOffSet !< If the matrix and permutation vectors are not in sync the offset may used as a remedy. 4463 !< Needed in fully coupled systems. 4464 LOGICAL, OPTIONAL :: OffDiagonalMatrix !< For block systems the only the diagonal matrix should be given non-zero 4465 !< entries for matrix and r.h.s., for off-diagonal matrices just set the row to zero. 4466!------------------------------------------------------------------------------ 4467 TYPE(Element_t), POINTER :: Element 4468 INTEGER, POINTER :: NodeIndexes(:), IndNodes(:), BCOrder(:) 4469 INTEGER, ALLOCATABLE :: Indexes(:), PassPerm(:) 4470 INTEGER :: BC,i,j,j2,k,l,m,n,nd,p,t,k1,k2,OffSet 4471 LOGICAL :: GotIt, periodic, OrderByBCNumbering, ReorderBCs 4472 REAL(KIND=dp), POINTER :: MinDist(:) 4473 REAL(KIND=dp), POINTER :: WorkA(:,:,:) => NULL() 4474 REAL(KIND=dp) :: s 4475 4476 TYPE(Mesh_t), POINTER :: Mesh 4477 TYPE(Solver_t), POINTER :: Solver 4478 4479 LOGICAL :: Conditional 4480 LOGICAL, ALLOCATABLE :: DonePeriodic(:) 4481 CHARACTER(LEN=MAX_NAME_LEN) :: CondName, DirName, PassName, PassCondName 4482 4483 INTEGER :: NoNodes,NoDims,bf_id,nlen, NOFNodesFound, dim, & 4484 bndry_start, bndry_end, Upper 4485 REAL(KIND=dp), POINTER :: CoordNodes(:,:), Condition(:), Work(:)!,DiagScaling(:) 4486 REAL(KIND=dp) :: GlobalMinDist,Dist, Eps 4487 LOGICAL, ALLOCATABLE :: ActivePart(:), ActiveCond(:), ActivePartAll(:) 4488 TYPE(ValueList_t), POINTER :: ValueList, Params 4489 LOGICAL :: NodesFound, Passive, OffDiagonal, ApplyLimiter 4490 LOGICAL, POINTER :: LimitActive(:) 4491 TYPE(Variable_t), POINTER :: Var 4492 4493 TYPE(Element_t), POINTER :: Parent 4494 4495 INTEGER :: ind, ElemFirst, ElemLast, bf, BCstr, BCend, BCinc 4496 REAL(KIND=dp) :: SingleVal 4497 LOGICAL :: AnySingleBC, AnySingleBF 4498 LOGICAL, ALLOCATABLE :: LumpedNodeSet(:) 4499 LOGICAL :: NeedListMatrix 4500 INTEGER, ALLOCATABLE :: Rows0(:), Cols0(:) 4501 REAL(KIND=dp), POINTER :: BulkValues0(:) 4502 INTEGER :: DirCount 4503 CHARACTER(*), PARAMETER :: Caller = 'SetDirichletBoundaries' 4504 LOGICAL, ALLOCATABLE :: CandNodes(:) 4505 INTEGER, POINTER :: PlaneInds(:) 4506 4507!------------------------------------------------------------------------------ 4508! These logical vectors are used to minimize extra effort in setting up different BCs 4509!------------------------------------------------------------------------------ 4510 4511 nlen = LEN_TRIM(Name) 4512 n = MAX( Model % NumberOfBodyForces,Model % NumberOfBCs) 4513 IF( n == 0 ) THEN 4514 CALL Info(Caller,'No BCs or Body Forces present, exiting early...',Level=12) 4515 END IF 4516 4517 ALLOCATE( ActivePart(n), ActivePartAll(n), ActiveCond(n)) 4518 CondName = Name(1:nlen) // ' Condition' 4519 PassName = Name(1:nlen) // ' Passive' 4520 PassCondName = Name(1:nlen) // ' Condition' // ' Passive' 4521 4522 OffSet = 0 4523 OffDiagonal = .FALSE. 4524 IF( PRESENT( PermOffSet) ) OffSet = PermOffSet 4525 IF( PRESENT( OffDiagonalMatrix ) ) OffDiagonal = OffDiagonalMatrix 4526 4527 Mesh => Model % Mesh 4528 ALLOCATE( Indexes(Mesh % MaxElementDOFs) ) 4529!------------------------------------------------------------------------------ 4530! Go through the periodic BCs and set the linear dependence 4531!------------------------------------------------------------------------------ 4532 4533 ActivePart = .FALSE. 4534 DO BC=1,Model % NumberOfBCs 4535 IF ( ListGetLogical( Model % BCs(BC) % Values, & 4536 'Periodic BC ' // Name(1:nlen), GotIt ) ) ActivePart(BC) = .TRUE. 4537 IF ( ListGetLogical( Model % BCs(BC) % Values, & 4538 'Anti Periodic BC ' // Name(1:nlen), GotIt ) ) ActivePart(BC) = .TRUE. 4539 IF ( ListCheckPresent( Model % BCs(BC) % Values, & 4540 'Periodic BC Scale ' // Name(1:nlen) ) ) ActivePart(BC) = .TRUE. 4541 END DO 4542 4543 IF( ANY(ActivePart) ) THEN 4544 IF( Offset > 0 ) THEN 4545 CALL Fatal(Caller,'Periodicity not considered with offset') 4546 END IF 4547 4548 ALLOCATE( DonePeriodic( Mesh % NumberOFNodes ) ) 4549 DonePeriodic = .FALSE. 4550 DO BC=1,Model % NumberOfBCs 4551 IF( ActivePart(BC) ) THEN 4552 CALL SetPeriodicBoundariesPass1( Model, A, b, Name, DOF, & 4553 NDOFs, Perm, BC, DonePeriodic ) 4554 END IF 4555 END DO 4556 4557 DonePeriodic = .FALSE. 4558 DO BC=1,Model % NumberOfBCs 4559 IF(ActivePart(BC)) THEN 4560 CALL SetPeriodicBoundariesPass2( Model, A, b, Name, DOF, & 4561 NDOFs, Perm, BC, DonePeriodic ) 4562 END IF 4563 END DO 4564 4565 IF( InfoActive(12) ) THEN 4566 CALL Info(Caller,'Number of periodic points set: '& 4567 //TRIM(I2S(COUNT(DonePeriodic))),Level=12) 4568 END IF 4569 4570 DEALLOCATE( DonePeriodic ) 4571 4572 END IF 4573 4574 4575! Add the possible friction coefficient 4576!---------------------------------------------------------- 4577 IF ( ListCheckPresentAnyBC( Model,'Friction BC ' // Name(1:nlen) ) ) THEN 4578 CALL SetFrictionBoundaries( Model, A, b, Name, NDOFs, Perm ) 4579 END IF 4580 4581 4582! Add the possible nodal jump in case of mortar projectors 4583!--------------------------------------------------------------- 4584 IF( ListGetLogical( Model % Solver % Values,'Apply Mortar BCs',GotIt ) ) THEN 4585 CALL SetWeightedProjectorJump( Model, A, b, & 4586 Name, DOF, NDOFs, Perm ) 4587 END IF 4588 4589 4590!------------------------------------------------------------------------------ 4591! Go through the normal Dirichlet BCs applied on the boundaries 4592!------------------------------------------------------------------------------ 4593 4594 ActivePart = .FALSE. 4595 ActiveCond = .FALSE. 4596 ActivePartAll = .FALSE. 4597 DO BC=1,Model % NumberOfBCs 4598 ActivePartAll(BC) = ListCheckPresent( & 4599 Model % BCs(bc) % Values, Name(1:nlen) // ' DOFs' ) 4600 ActivePart(BC) = ListCheckPresent( Model % BCs(bc) % Values, Name ) 4601 ActiveCond(BC) = ListCheckPresent( Model % BCs(bc) % Values, CondName ) 4602 END DO 4603 4604 OrderByBCNumbering = ListGetLogical( Model % Simulation, & 4605 'Set Dirichlet BCs by BC Numbering', gotIt) 4606 4607 BCOrder => ListGetIntegerArray( Model % Solver % Values, & 4608 'Dirichlet BC Order', ReorderBCs) 4609 IF(ReorderBCs) THEN 4610 IF(.NOT. OrderByBCNumbering) THEN 4611 CALL Warn(Caller,"Requested 'Dirichlet BC Order' but & 4612 ¬ 'Set Dirichlet BCs by BC Numbering', ignoring...") 4613 ELSE IF(SIZE(BCOrder) /= Model % NumberOfBCs) THEN 4614 CALL Fatal(Caller,"'Dirichlet BC Order' is the wrong length!") 4615 END IF 4616 END IF 4617 4618 bndry_start = Model % NumberOfBulkElements+1 4619 bndry_end = bndry_start+Model % NumberOfBoundaryElements-1 4620 DirCount = 0 4621 4622 ! check and set some flags for nodes belonging to n-t boundaries 4623 ! getting set by other bcs: 4624 ! -------------------------------------------------------------- 4625 IF ( NormalTangentialNOFNodes>0 ) THEN 4626 IF ( OrderByBCNumbering ) THEN 4627 DO i=1,Model % NumberOfBCs 4628 BC = i 4629 IF(ReorderBCs) BC = BCOrder(BC) 4630 IF(.NOT. ActivePart(BC) .AND. .NOT. ActivePartAll(BC) ) CYCLE 4631 Conditional = ActiveCond(BC) 4632 4633 DO t = bndry_start, bndry_end 4634 Element => Model % Elements(t) 4635 IF ( Element % BoundaryInfo % Constraint /= & 4636 Model % BCs(BC) % Tag ) CYCLE 4637 4638 ValueList => Model % BCs(BC) % Values 4639 Model % CurrentElement => Element 4640 4641 IF ( ActivePart(BC) ) THEN 4642 n = Element % TYPE % NumberOfNodes 4643 IF ( Model % Solver % DG ) THEN 4644 Parent => Element % BoundaryInfo % Left 4645 DO p=1,Parent % Type % NumberOfNodes 4646 DO j=1,n 4647 IF (Parent % NodeIndexes(p) == Element % NodeIndexes(j) ) THEN 4648 Indexes(j) = Parent % DGIndexes(p); EXIT 4649 END IF 4650 END DO 4651 END DO 4652 ELSE 4653 Indexes(1:n) = Element % NodeIndexes 4654 END IF 4655 ELSE 4656 n = SgetElementDOFs( Indexes ) 4657 END IF 4658 CALL CheckNTelement(n,t) 4659 END DO 4660 END DO 4661 ELSE 4662 DO t = bndry_start, bndry_end 4663 DO BC=1,Model % NumberOfBCs 4664 IF(.NOT. ActivePart(BC) .AND. .NOT. ActivePartAll(BC) ) CYCLE 4665 Conditional = ActiveCond(BC) 4666 4667 Element => Model % Elements(t) 4668 IF ( Element % BoundaryInfo % Constraint /= & 4669 Model % BCs(BC) % Tag ) CYCLE 4670 4671 ValueList => Model % BCs(BC) % Values 4672 Model % CurrentElement => Element 4673 IF ( ActivePart(BC) ) THEN 4674 n = Element % TYPE % NumberOfNodes 4675 IF ( Model % Solver % DG ) THEN 4676 Parent => Element % BoundaryInfo % Left 4677 DO p=1,Parent % Type % NumberOfNodes 4678 DO j=1,n 4679 IF (Parent % NodeIndexes(p) == Element % NodeIndexes(j) ) THEN 4680 Indexes(j) = Parent % DGIndexes(p); EXIT 4681 END IF 4682 END DO 4683 END DO 4684 ELSE 4685 Indexes(1:n) = Element % NodeIndexes 4686 END IF 4687 ELSE 4688 n = SgetElementDOFs( Indexes ) 4689 END IF 4690 CALL CheckNTelement(n,t) 4691 END DO 4692 END DO 4693 END IF 4694 4695 IF ( DOF<= 0 ) THEN 4696 DO t=bndry_start,bndry_end 4697 Element => Model % Elements(t) 4698 n = Element % TYPE % NumberOfNodes 4699 DO j=1,n 4700 k = BoundaryReorder(Element % NodeIndexes(j)) 4701 IF (k>0) THEN 4702 NTelement(k,:)=0 4703 NTzeroing_done(k,:) = .FALSE. 4704 END IF 4705 END DO 4706 END DO 4707 END IF 4708 END IF 4709 4710 4711 ! Set the Dirichlet BCs from active boundary elements, if any...: 4712 !---------------------------------------------------------------- 4713 IF( ANY(ActivePart) .OR. ANY(ActivePartAll) ) THEN 4714 IF ( OrderByBCNumbering ) THEN 4715 DO i=1,Model % NumberOfBCs 4716 BC = i 4717 IF(ReorderBCs) BC = BCOrder(BC) 4718 IF(.NOT. ActivePart(BC) .AND. .NOT. ActivePartAll(BC) ) CYCLE 4719 Conditional = ActiveCond(BC) 4720 4721 DO t = bndry_start, bndry_end 4722 Element => Model % Elements(t) 4723 IF ( Element % BoundaryInfo % Constraint /= & 4724 Model % BCs(BC) % Tag ) CYCLE 4725 Model % CurrentElement => Element 4726 IF ( ActivePart(BC) ) THEN 4727 n = Element % TYPE % NumberOfNodes 4728 IF ( Model % Solver % DG ) THEN 4729 Parent => Element % BoundaryInfo % Left 4730 DO p=1,Parent % Type % NumberOfNodes 4731 DO j=1,n 4732 IF (Parent % NodeIndexes(p) == Element % NodeIndexes(j) ) THEN 4733 Indexes(j) = Parent % DGIndexes(p); EXIT 4734 END IF 4735 END DO 4736 END DO 4737 ELSE 4738 Indexes(1:n) = Element % NodeIndexes 4739 END IF 4740 ELSE 4741 n = SgetElementDOFs( Indexes ) 4742 END IF 4743 ValueList => Model % BCs(BC) % Values 4744 CALL SetElementValues(n,t) 4745 END DO 4746 END DO 4747 ELSE 4748 DO t = bndry_start, bndry_end 4749 DO BC=1,Model % NumberOfBCs 4750 IF(.NOT. ActivePart(BC) .AND. .NOT. ActivePartAll(BC) ) CYCLE 4751 Conditional = ActiveCond(BC) 4752 4753 Element => Model % Elements(t) 4754 IF ( Element % BoundaryInfo % Constraint /= & 4755 Model % BCs(BC) % Tag ) CYCLE 4756 4757 Model % CurrentElement => Element 4758 IF ( ActivePart(BC) ) THEN 4759 n = Element % TYPE % NumberOfNodes 4760 IF ( Model % Solver % DG ) THEN 4761 Parent => Element % BoundaryInfo % Left 4762 DO p=1,Parent % Type % NumberOfNodes 4763 DO j=1,n 4764 IF (Parent % NodeIndexes(p) == Element % NodeIndexes(j) ) THEN 4765 Indexes(j) = Parent % DGIndexes(p); EXIT 4766 END IF 4767 END DO 4768 END DO 4769 ELSE 4770 Indexes(1:n) = Element % NodeIndexes 4771 END IF 4772 ELSE 4773 n = SgetElementDOFs( Indexes ) 4774 END IF 4775 ValueList => Model % BCs(BC) % Values 4776 CALL SetElementValues(n,t) 4777 END DO 4778 END DO 4779 END IF 4780 END IF 4781 4782 4783!------------------------------------------------------------------------------ 4784! Go through the Dirichlet conditions in the body force lists 4785!------------------------------------------------------------------------------ 4786 4787 ActivePart = .FALSE. 4788 ActiveCond = .FALSE. 4789 ActivePartAll = .FALSE. 4790 Passive = .FALSE. 4791 DO bf_id=1,Model % NumberOFBodyForces 4792 ValueList => Model % BodyForces(bf_id) % Values 4793 4794 ActivePartAll(bf_id) = ListCheckPresent(ValueList, Name(1:nlen) // ' DOFs' ) 4795 ActiveCond(bf_id) = ListCheckPresent( ValueList,CondName ) 4796 ActivePart(bf_id) = ListCheckPresent(ValueList, Name(1:nlen) ) 4797 4798 Passive = Passive .OR. ListCheckPresent(ValueList, PassName) 4799 END DO 4800 4801 IF ( ANY(ActivePart) .OR. ANY(ActivePartAll) ) THEN 4802 Solver => Model % Solver 4803 Mesh => Solver % Mesh 4804 4805 ALLOCATE(PassPerm(Mesh % NumberOfNodes),NodeIndexes(1));PassPerm=0 4806 DO i=0,Mesh % PassBCCnt-1 4807 j=Mesh % NumberOfBulkElements+Mesh % NumberOfBoundaryElements-i 4808 PassPerm(Mesh % Elements(j) % NodeIndexes)=1 4809 END DO 4810 4811 DO t = 1, Mesh % NumberOfBulkElements 4812 Element => Mesh % Elements(t) 4813 IF( Element % BodyId <= 0 .OR. Element % BodyId > Model % NumberOfBodies ) THEN 4814 CALL Warn(Caller,'Element body id beyond body table!') 4815 CYCLE 4816 END IF 4817 4818 bf_id = ListGetInteger( Model % Bodies(Element % BodyId) % Values,'Body Force', GotIt) 4819 4820 IF(.NOT. GotIt) CYCLE 4821 IF(.NOT. ActivePart(bf_id) .AND. .NOT. ActivePartAll(bf_id)) CYCLE 4822 Conditional = ActiveCond(bf_id) 4823 4824 Model % CurrentElement => Element 4825 4826 IF ( ActivePart(bf_id) ) THEN 4827 n = Element % TYPE % NumberOfNodes 4828 Indexes(1:n) = Element % NodeIndexes 4829 ELSE 4830 n = SgetElementDOFs( Indexes ) 4831 END IF 4832 4833 ValueList => Model % BodyForces(bf_id) % Values 4834 IF(.NOT. ASSOCIATED( ValueList ) ) CYCLE 4835 4836 IF (ListGetLogical(ValueList,PassCondName,GotIt)) THEN 4837 IF (.NOT.CheckPassiveElement(Element)) CYCLE 4838 DO j=1,n 4839 NodeIndexes(1) = Indexes(j) 4840 IF(PassPerm(NodeIndexes(1))==0) CALL SetPointValues(1) 4841 END DO 4842 ELSE 4843 CALL SetElementValues( n,t ) 4844 END IF 4845 4846 END DO 4847 4848 DEALLOCATE(NodeIndexes,PassPerm) 4849 END IF 4850 4851 DEALLOCATE(ActivePart, ActiveCond) 4852 4853 4854!------------------------------------------------------------------------------ 4855! Go through the pointwise Dirichlet BCs that are created on-the-fly 4856! Note that it is best that the coordinates are transformed to nodes using 4857! the right variable. Otherwise it could point to nodes that are not active. 4858!------------------------------------------------------------------------------ 4859 4860 DO BC=1,Model % NumberOfBCs 4861 4862 ValueList => Model % BCs(BC) % Values 4863 IF( .NOT. ListCheckPresent( ValueList,Name )) CYCLE 4864 NodesFound = ListCheckPresent( ValueList,'Target Nodes' ) 4865 4866 ! The coordinates are only requested for a body that has no list of nodes. 4867 ! At the first calling the list of coordinates is transformed to list of nodes. 4868 IF(.NOT. NodesFound) THEN 4869 CoordNodes => ListGetConstRealArray(ValueList,'Target Coordinates',GotIt) 4870 IF(GotIt) THEN 4871 Eps = ListGetConstReal( ValueList, 'Target Coordinates Eps', Gotit ) 4872 IF ( .NOT. GotIt ) THEN 4873 Eps = HUGE(Eps) 4874 ELSE 4875 ! We are looking at square of distance 4876 Eps = Eps**2 4877 END IF 4878 4879 NoNodes = SIZE(CoordNodes,1) 4880 NoDims = SIZE(CoordNodes,2) 4881 4882 IF(NoNodes > 0) THEN 4883 ALLOCATE( IndNodes(NoNodes), MinDist(NoNodes) ) 4884 IndNodes = -1 4885 MinDist = HUGE( Dist ) 4886 DO j=1,NoNodes 4887 DO i=1,Model % NumberOfNodes 4888 IF( Perm(i) == 0) CYCLE 4889 4890 Dist = (Mesh % Nodes % x(i) - CoordNodes(j,1))**2 4891 IF(NoDims >= 2) Dist = Dist + (Mesh % Nodes % y(i) - CoordNodes(j,2))**2 4892 IF(NoDims == 3) Dist = Dist + (Mesh % Nodes % z(i) - CoordNodes(j,3))**2 4893 Dist = SQRT(Dist) 4894 4895 IF(Dist < MinDist(j) .AND. Dist <= Eps ) THEN 4896 MinDist(j) = Dist 4897 IndNodes(j) = i 4898 END IF 4899 END DO 4900 END DO 4901 4902 IF( InfoActive( 20 ) ) THEN 4903 DO j=1,NoNodes 4904 i = IndNodes(j) 4905 IF(i<1) CYCLE 4906 PRINT *,'Nearest node is:',i,MinDist(j) 4907 PRINT *,'Target Coordinates:',CoordNodes(j,:) 4908 PRINT *,'Nearest coordinates:',Model % Mesh % Nodes % x(i),& 4909 Model % Mesh % Nodes % y(i), Model % Mesh % Nodes % z(i) 4910 END DO 4911 END IF 4912 4913 ! In parallel case eliminate all except the nearest node. 4914 ! This relies on the fact that for each node partition the 4915 ! distance to nearest node is computed accurately. 4916 DO j=1,NoNodes 4917 GlobalMinDist = ParallelReduction( MinDist(j), 1 ) 4918 IF( ABS( GlobalMinDist - MinDist(j) ) > TINY(Dist) ) THEN 4919 IndNodes(j) = 0 4920 END IF 4921 END DO 4922 4923 NOFNodesFound = 0 4924 DO j=1,NoNodes 4925 IF ( IndNodes(j)>0 ) THEN 4926 NOFNodesFound = NOFNodesFound+1 4927 IndNodes(NOFNodesFound) = IndNodes(j) 4928 END IF 4929 END DO 4930 4931 ! In the first time add the found nodes to the list structure 4932 IF ( NOFNodesFound > 0 ) THEN 4933 DO i=1,NOFNodesFound 4934 CALL Info(Caller, 'Target Nodes('//TRIM(I2S(i))//& 4935 ') = '//TRIM(I2S(IndNodes(i))),Level=7) 4936 END DO 4937 CALL ListAddIntegerArray( ValueList,'Target Nodes', & 4938 NOFNodesFound, IndNodes) 4939 NodesFound = .TRUE. 4940 ELSE 4941 ! If no nodes found, add still an empty list and make sure the 4942 ! zero is not treated later on. Otherwise this search would be 4943 ! retreated each time. 4944 CALL ListAddIntegerArray( ValueList,'Target Nodes', & 4945 1, IndNodes) 4946 END IF 4947 4948 ! Finally deallocate the temporal vectors 4949 DEALLOCATE( IndNodes, MinDist ) 4950 END IF 4951 END IF 4952 END IF 4953 4954 ! If the target coordinates has already been assigned to an empty list 4955 ! cycle over it by testing the 1st node. 4956 IF( NodesFound ) THEN 4957 NodeIndexes => ListGetIntegerArray( ValueList,'Target Nodes') 4958 IF( NodeIndexes(1) == 0 ) NodesFound = .FALSE. 4959 END IF 4960 4961 IF(NodesFound) THEN 4962 Conditional = ListCheckPresent( ValueList, CondName ) 4963 n = SIZE(NodeIndexes) 4964 CALL SetPointValues(n) 4965 END IF 4966 END DO 4967 4968 4969!------------------------------------------------------------------------------ 4970! Go through soft upper and lower limits 4971!------------------------------------------------------------------------------ 4972 Params => Model % Solver % Values 4973 ApplyLimiter = ListGetLogical( Params,'Apply Limiter',GotIt) 4974 4975 IF( Dof/=0 .AND. ApplyLimiter ) THEN 4976 CALL Info(Caller,'Applying limiters',Level=10) 4977 4978 DO Upper=0,1 4979 4980 ! The limiters have been implemented only componentwise 4981 !------------------------------------------------------- 4982 4983 NULLIFY( LimitActive ) 4984 Var => Model % Solver % Variable 4985 IF( Upper == 0 ) THEN 4986 IF( ASSOCIATED( Var % LowerLimitActive ) ) & 4987 LimitActive => Var % LowerLimitActive 4988 ELSE 4989 IF( ASSOCIATED( Var % UpperLimitActive ) ) & 4990 LimitActive => Var % UpperLimitActive 4991 END IF 4992 4993 IF( .NOT. ASSOCIATED( LimitActive ) ) CYCLE 4994 4995 IF( Upper == 0 ) THEN 4996 CondName = TRIM(name)//' Lower Limit' 4997 ELSE 4998 CondName = TRIM(name)//' Upper Limit' 4999 END IF 5000 5001 ! check and set some flags for nodes belonging to n-t boundaries 5002 ! getting set by other bcs: 5003 ! -------------------------------------------------------------- 5004 DO t = 1, Model % NumberOfBulkElements+Model % NumberOfBoundaryElements 5005 Element => Model % Elements(t) 5006 Model % CurrentElement => Element 5007 n = Element % TYPE % NumberOfNodes 5008 NodeIndexes => Element % NodeIndexes 5009 5010 IF( t > Model % NumberOfBulkElements ) THEN 5011 DO bc = 1,Model % NumberOfBCs 5012 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 5013 ValueList => Model % BCs(BC) % Values 5014 CALL SetLimiterValues(n) 5015 END DO 5016 ELSE 5017 bf_id = ListGetInteger( Model % Bodies(Element % bodyid) % Values, & 5018 'Body Force', GotIt) 5019 IF(.NOT. GotIt ) CYCLE 5020 ValueList => Model % Bodyforces(bf_id) % Values 5021 CALL SetLimiterValues(n) 5022 END IF 5023 END DO 5024 END DO 5025 END IF 5026 5027 5028 ! Check the boundaries and body forces for possible single nodes BCs that are used to fixed 5029 ! the domain for undetermined equations. The loop is slower than optimal in the case that there is 5030 ! a large amount of different boundaries that have a node to set. 5031 !-------------------------------------------------------------------------------------------- 5032 DirName = TRIM(Name)//' Single Node' 5033 AnySingleBC = ListCheckPresentAnyBC( Model, DirName ) 5034 AnySingleBF = ListCheckPresentAnyBodyForce( Model, DirName ) 5035 5036 IF( AnySingleBC .OR. AnySingleBF ) THEN 5037 Solver => Model % Solver 5038 Mesh => Solver % Mesh 5039 5040 DO bc = 1,Model % NumberOfBCs + Model % NumberOfBodyForces 5041 5042 ! Make a distinction between BCs and BFs. 5043 ! These are treated in the same loop because most of the logic is still the same. 5044 IF( bc <= Model % NumberOfBCs ) THEN 5045 IF(.NOT. AnySingleBC ) CYCLE 5046 ValueList => Model % BCs(BC) % Values 5047 ElemFirst = Mesh % NumberOfBulkElements + 1 5048 ElemLast = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 5049 ELSE 5050 IF( .NOT. AnySingleBF ) CYCLE 5051 ValueList => Model % BodyForces(bc - Model % NumberOfBCs) % Values 5052 ElemFirst = 1 5053 ElemLast = Mesh % NumberOfBulkElements 5054 END IF 5055 5056 SingleVal = ListGetCReal( ValueList,DirName, GotIt) 5057 IF( .NOT. GotIt ) CYCLE 5058 ind = ListGetInteger( ValueList,TRIM(Name)//' Single Node Index',GotIt ) 5059 5060 ! On the first time find a one single uniquely defined node for setting 5061 ! the value. In parallel it will be an unshared node with the highest possible 5062 ! node number 5063 IF( .NOT. GotIt ) THEN 5064 5065 ind = 0 5066 DO t = ElemFirst, ElemLast 5067 Element => Mesh % Elements(t) 5068 n = Element % TYPE % NumberOfNodes 5069 NodeIndexes => Element % NodeIndexes 5070 5071 IF( bc <= Model % NumberOfBCs ) THEN 5072 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 5073 ELSE 5074 j = Element % BodyId 5075 IF( j < 0 .OR. j > Model % NumberOfBodies ) CYCLE 5076 bf = ListGetInteger( Model % Bodies(j) % Values,'Body Force',GotIt) 5077 IF(.NOT. GotIt) CYCLE 5078 IF( bc - Model % NumberOfBCs /= bf ) CYCLE 5079 END IF 5080 5081 DO i=1,n 5082 j = NodeIndexes(i) 5083 IF( Perm(j) == 0) CYCLE 5084 IF( ParEnv % PEs > 1 ) THEN 5085 IF( SIZE( Mesh % ParallelInfo % NeighbourList(j) % Neighbours) > 1 ) CYCLE 5086 IF( Mesh % ParallelInfo % NeighbourList(j) % Neighbours(1) /= ParEnv % MyPe ) CYCLE 5087 END IF 5088 ind = j 5089 EXIT 5090 END DO 5091 IF( ind > 0 ) EXIT 5092 END DO 5093 5094 k = NINT( ParallelReduction( 1.0_dp * ind, 2 ) ) 5095 5096 ! Find the maximum partition that owns a suitable node. 5097 ! It could be minimum also, just some convection is needed. 5098 IF( ParEnv % PEs > 1 ) THEN 5099 k = -1 5100 IF( ind > 0 ) k = ParEnv % MyPe 5101 k = NINT( ParallelReduction( 1.0_dp * k, 2 ) ) 5102 IF( k == -1 ) THEN 5103 CALL Warn(Caller,'Could not find node to set: '//TRIM(DirName)) 5104 ELSE 5105 IF( k /= ParEnv % MyPe ) ind = 0 5106 IF( InfoActive(8) ) THEN 5107 ind = NINT( ParallelReduction( 1.0_dp * ind, 2 ) ) 5108 CALL Info(Caller,'Fixing single node '& 5109 //TRIM(I2S(ind))//' at partition '//TRIM(I2S(k)),Level=8) 5110 IF( k /= ParEnv % MyPe ) ind = 0 5111 END IF 5112 END IF 5113 ELSE 5114 IF( ind == 0 ) THEN 5115 CALL Warn(Caller,'Could not find node to set: '//TRIM(DirName)) 5116 ELSE 5117 CALL Info(Caller,'Fixing single node '//TRIM(I2S(ind)),Level=8) 5118 END IF 5119 END IF 5120 5121 CALL ListAddInteger( ValueList,TRIM(Name)//' Single Node Index', ind ) 5122 END IF 5123 5124 ! Ok, if this is the partition where the single node to eliminate the floating should 5125 ! be eliminated then set it here. Index equal to zero tells that we are in a wrong partition. 5126 IF( ind > 0 ) THEN 5127 CALL SetSinglePoint(ind,DOF,SingleVal,.TRUE.) 5128 END IF 5129 END DO 5130 END IF 5131 5132 5133!------------------------------------------------------------------------------ 5134! Take care of the matrix entries of passive elements 5135!------------------------------------------------------------------------------ 5136 5137 IF ( Passive ) THEN 5138 Solver => Model % Solver 5139 Mesh => Solver % Mesh 5140 DO i=1,Solver % NumberOfActiveElements 5141 Element => Mesh % Elements(Solver % ActiveElements(i)) 5142 IF (CheckPassiveElement(Element)) THEN 5143 n = sGetElementDOFs(Indexes,UElement=Element) 5144 DO j=1,n 5145 k=Indexes(j) 5146 IF (k<=0) CYCLE 5147 5148 k=Perm(k) 5149 IF (k<=0) CYCLE 5150 5151 s=0._dp 5152 DO l=1,NDOFs 5153 m=NDOFs*(k-1)+l 5154 s=s+ABS(A % Values(A % Diag(m))) 5155 END DO 5156 IF (s>EPSILON(s)) CYCLE 5157 5158 DO l=1,NDOFs 5159 m = NDOFs*(k-1)+l 5160 IF(A % ConstrainedDOF(m)) CYCLE 5161 CALL SetSinglePoint(k,l,Solver % Variable % Values(m),.FALSE.) 5162 END DO 5163 END DO 5164 END IF 5165 END DO 5166 END IF 5167 5168 5169 ! Check the boundaries and body forces for possible single nodes BCs that must have a constant 5170 ! value on that boundary / body force. 5171 !-------------------------------------------------------------------------------------------- 5172 DirName = TRIM(Name)//' Constant' 5173 AnySingleBC = ListCheckPresentAnyBC( Model, DirName ) 5174 AnySingleBF = ListCheckPresentAnyBodyForce( Model, DirName ) 5175 5176 IF( AnySingleBC .OR. AnySingleBF ) THEN 5177 ALLOCATE( LumpedNodeSet( SIZE( Perm ) ) ) 5178 5179 IF( AnySingleBC ) CALL Info(Caller,'Found BC constraint: '//TRIM(DirName),Level=6) 5180 IF( AnySingleBF ) CALL Info(Caller,'Found BodyForce constraint: '//TRIM(DirName),Level=6) 5181 5182 ! Improve the logic in future 5183 ! Now we assume that if the "supernode" has been found then also the matrix has the correct topology. 5184 IF( AnySingleBC ) THEN 5185 NeedListMatrix = .NOT. ListCheckPresentAnyBC( Model, TRIM(Name)//' Constant Node Index') 5186 ELSE 5187 NeedListMatrix = .NOT. ListCheckPresentAnyBodyForce( Model, TRIM(Name)//' Constant Node Index') 5188 END IF 5189 5190 ! Move the list matrix because of its flexibility 5191 IF( NeedListMatrix ) THEN 5192 CALL Info(Caller,'Using List maxtrix to set constant constraints',Level=8) 5193 CALL Info(Caller,'Original matrix non-zeros: '& 5194 //TRIM(I2S(SIZE( A % Cols ))),Level=8) 5195 IF( ASSOCIATED( A % BulkValues ) ) THEN 5196 ALLOCATE( Cols0( SIZE( A % Cols ) ), Rows0( SIZE( A % Rows ) ) ) 5197 Cols0 = A % Cols 5198 Rows0 = A % Rows 5199 END IF 5200 CALL List_toListMatrix(A) 5201 END IF 5202 5203 DO bc = 1,Model % NumberOfBCs + Model % NumberOfBodyForces 5204 5205 ! Make a distinction between BCs and BFs. 5206 ! These are treated in the same loop because most of the logic is still the same. 5207 IF( bc <= Model % NumberOfBCs ) THEN 5208 IF(.NOT. AnySingleBC ) CYCLE 5209 ValueList => Model % BCs(BC) % Values 5210 ElemFirst = Model % NumberOfBulkElements + 1 5211 ElemLast = Model % NumberOfBulkElements + Model % NumberOfBoundaryElements 5212 ELSE 5213 IF(.NOT. AnySingleBF ) CYCLE 5214 ValueList => Model % BodyForces(bc - Model % NumberOfBCs) % Values 5215 ElemFirst = 1 5216 ElemLast = Model % NumberOfBulkElements 5217 END IF 5218 5219 IF( .NOT. ListGetLogical( ValueList,DirName, GotIt) ) CYCLE 5220 5221 ind = ListGetInteger( ValueList,TRIM(Name)//' Constant Node Index',GotIt ) 5222 5223 5224 ! On the first time find a one single uniquely defined node for setting 5225 ! the value. In parallel it will be an unshared node with the highest possible 5226 ! node number 5227 IF( .NOT. GotIt ) THEN 5228 5229 ind = 0 5230 DO t = ElemFirst, ElemLast 5231 Element => Model % Elements(t) 5232 5233 IF( bc <= Model % NumberOfBCs ) THEN 5234 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 5235 ELSE 5236 bf = ListGetInteger( Model % Bodies(Element % bodyid) % Values,'Body Force',GotIt) 5237 IF( bc - Model % NumberOfBCs /= bf ) CYCLE 5238 END IF 5239 5240 n = Element % TYPE % NumberOfNodes 5241 NodeIndexes => Element % NodeIndexes 5242 5243 DO i=1,n 5244 j = NodeIndexes(i) 5245 IF( Perm(j) == 0) CYCLE 5246 IF( ParEnv % PEs > 1 ) THEN 5247 IF( SIZE( Mesh % ParallelInfo % NeighbourList(j) % Neighbours) > 1 ) CYCLE 5248 IF( Mesh % ParallelInfo % NeighbourList(j) % Neighbours(1) /= ParEnv % MyPe ) CYCLE 5249 END IF 5250 ind = j 5251 EXIT 5252 END DO 5253 IF( ind > 0 ) EXIT 5254 END DO 5255 5256 ! Find the maximum partition that owns the node. 5257 ! It could be minimum also, just some convection is needed. 5258 IF( ParEnv % PEs > 1 ) THEN 5259 k = -1 5260 IF( ind > 0 ) k = ParEnv % MyPe 5261 k = NINT( ParallelReduction( 1.0_dp * k, 2 ) ) 5262 IF( k == -1 ) THEN 5263 CALL Warn(Caller,'Could not find node to set: '//TRIM(DirName)) 5264 END IF 5265 IF( k /= ParEnv % MyPe ) ind = 0 5266 ELSE 5267 IF( ind == 0 ) THEN 5268 CALL Warn(Caller,'Could not find node to set: '//TRIM(DirName)) 5269 END IF 5270 END IF 5271 5272 CALL ListAddInteger( ValueList,TRIM(Name)//' Constant Node Index', ind ) 5273 NeedListMatrix = .TRUE. 5274 END IF 5275 5276 IF( ParEnv % PEs > 1 ) CALL Warn(Caller,'Node index not set properly in parallel') 5277 IF( ind == 0 ) CYCLE 5278 5279 ! Ok, now sum up the rows to the corresponding nodal index 5280 LumpedNodeSet = .FALSE. 5281 5282 ! Don't lump the "supernode" and therefore mark it set already 5283 LumpedNodeSet(ind) = .TRUE. 5284 5285 DO t = ElemFirst, ElemLast 5286 Element => Model % Elements(t) 5287 5288 IF( bc <= Model % NumberOfBCs ) THEN 5289 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) CYCLE 5290 ELSE 5291 bf = ListGetInteger( Model % Bodies(Element % bodyid) % Values,'Body Force',GotIt) 5292 IF( bc - Model % NumberOfBCs /= bf ) CYCLE 5293 END IF 5294 5295 n = Element % TYPE % NumberOfNodes 5296 Indexes(1:n) = Element % NodeIndexes 5297 5298 CALL SetLumpedRows(ind,n) 5299 END DO 5300 5301 n = COUNT( LumpedNodeSet ) 5302 CALL Info(Caller,'Number of lumped nodes set: '//TRIM(I2S(n)),Level=10) 5303 END DO 5304 5305 IF( NeedListMatrix ) THEN 5306 DEALLOCATE( LumpedNodeSet ) 5307 5308 ! Revert back to CRS matrix 5309 CALL List_ToCRSMatrix(A) 5310 5311 ! This is needed in order to copy the old BulkValues to a vector that 5312 ! has the same size as the new matrix. Otherwise the matrix vector multiplication 5313 ! with the new Rows and Cols will fail. 5314 IF( ASSOCIATED( A % BulkValues ) ) THEN 5315 BulkValues0 => A % BulkValues 5316 NULLIFY( A % BulkValues ) 5317 ALLOCATE( A % BulkValues( SIZE( A % Values ) ) ) 5318 A % BulkValues = 0.0_dp 5319 5320 DO i=1,A % NumberOfRows 5321 DO j = Rows0(i), Rows0(i+1)-1 5322 k = Cols0(j) 5323 DO j2 = A % Rows(i), A % Rows(i+1)-1 5324 k2 = A % Cols(j2) 5325 IF( k == k2 ) THEN 5326 A % BulkValues(j2) = BulkValues0(j) 5327 EXIT 5328 END IF 5329 END DO 5330 END DO 5331 END DO 5332 5333 DEALLOCATE( Cols0, Rows0, BulkValues0 ) 5334 END IF 5335 5336 CALL Info(Caller,'Modified matrix non-zeros: '& 5337 //TRIM(I2S(SIZE( A % Cols ))),Level=8) 5338 END IF 5339 END IF 5340 5341 5342 5343 ! Check the boundaries and body forces for possible single nodes BCs that must have a constant 5344 ! value on that boundary / body force. 5345 !-------------------------------------------------------------------------------------------- 5346 DirName = TRIM(Name)//' Plane' 5347 AnySingleBC = ListCheckPresentAnyBC( Model, DirName ) 5348 5349 IF( AnySingleBC ) THEN 5350 dim = CoordinateSystemDimension() 5351 5352 ALLOCATE( LumpedNodeSet( SIZE( Perm ) ) ) 5353 5354 CALL Info(Caller,'Found BC constraint: '//TRIM(DirName),Level=6) 5355 5356 ! Improve the logic in future 5357 ! Now we assume that if the "supernode" has been found then also the matrix has the correct topology. 5358 NeedListMatrix = .NOT. ListCheckPresentAnyBC( Model, TRIM(Name)//' Plane Node Indices') 5359 5360 ! Move the list matrix because of its flexibility 5361 IF( NeedListMatrix ) THEN 5362 CALL Info(Caller,'Using List maxtrix to set constant constraints',Level=8) 5363 CALL Info(Caller,'Original matrix non-zeros: '& 5364 //TRIM(I2S(SIZE( A % Cols ))),Level=8) 5365 IF( ASSOCIATED( A % BulkValues ) ) THEN 5366 ALLOCATE( Cols0( SIZE( A % Cols ) ), Rows0( SIZE( A % Rows ) ) ) 5367 Cols0 = A % Cols 5368 Rows0 = A % Rows 5369 END IF 5370 CALL List_toListMatrix(A) 5371 END IF 5372 5373 ElemFirst = Model % NumberOfBulkElements + 1 5374 ElemLast = Model % NumberOfBulkElements + Model % NumberOfBoundaryElements 5375 5376 DO bc = 1,Model % NumberOfBCs 5377 5378 ValueList => Model % BCs(BC) % Values 5379 IF( .NOT. ListGetLogical( ValueList,DirName, GotIt) ) CYCLE 5380 5381 PlaneInds => ListGetIntegerArray( ValueList,TRIM(Name)//' Plane Node Indices',GotIt ) 5382 5383 IF(.NOT. GotIt ) THEN 5384 IF(.NOT. ALLOCATED(CandNodes) ) THEN 5385 ALLOCATE( CandNodes( Mesh % NumberOfNodes ) ) 5386 END IF 5387 CandNodes = .FALSE. 5388 5389 ! Add nodes to the set that are associated with this BC only. 5390 DO t = ElemFirst, ElemLast 5391 Element => Model % Elements(t) 5392 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 5393 NodeIndexes => Element % NodeIndexes 5394 CandNodes(NodeIndexes) = .TRUE. 5395 END IF 5396 END DO 5397 5398 ! Remove nodes from the set that may be set by other BCs also. 5399 DO t = ElemFirst, ElemLast 5400 Element => Model % Elements(t) 5401 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(bc) % Tag ) THEN 5402 NodeIndexes => Element % NodeIndexes 5403 CandNodes(NodeIndexes) = .FALSE. 5404 END IF 5405 END DO 5406 5407 ALLOCATE(PlaneInds(3)) 5408 CALL FindExtremumNodes(Mesh,CandNodes,dim,PlaneInds) 5409 5410 CALL ListAddIntegerArray( ValueList,TRIM(Name)//' Plane Node Indices',dim, PlaneInds ) 5411 NeedListMatrix = .TRUE. 5412 END IF 5413 5414 IF( ParEnv % PEs > 1 ) CALL Warn(Caller,'Node index perhaps not set properly in parallel') 5415 ! IF( ind == 0 ) CYCLE 5416 5417 ! Ok, now sum up the rows to the corresponding nodal index 5418 LumpedNodeSet = .FALSE. 5419 5420 ! Don't lump the "supernodes" and therefore mark it set already 5421 LumpedNodeSet(PlaneInds) = .TRUE. 5422 5423 DO t = ElemFirst, ElemLast 5424 Element => Model % Elements(t) 5425 5426 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc) % Tag ) THEN 5427 n = Element % TYPE % NumberOfNodes 5428 Indexes(1:n) = Element % NodeIndexes 5429 CALL SetRigidRows(PlaneInds,bc,n) 5430 END IF 5431 END DO 5432 5433 n = COUNT( LumpedNodeSet ) 5434 CALL Info(Caller,'Number of lumped nodes set: '//TRIM(I2S(n)),Level=10) 5435 END DO 5436 5437 IF( NeedListMatrix ) THEN 5438 DEALLOCATE( LumpedNodeSet ) 5439 5440 ! Revert back to CRS matrix 5441 CALL List_ToCRSMatrix(A) 5442 5443 ! This is needed in order to copy the old BulkValues to a vector that 5444 ! has the same size as the new matrix. Otherwise the matrix vector multiplication 5445 ! with the new Rows and Cols will fail. 5446 IF( ASSOCIATED( A % BulkValues ) ) THEN 5447 BulkValues0 => A % BulkValues 5448 NULLIFY( A % BulkValues ) 5449 ALLOCATE( A % BulkValues( SIZE( A % Values ) ) ) 5450 A % BulkValues = 0.0_dp 5451 5452 DO i=1,A % NumberOfRows 5453 DO j = Rows0(i), Rows0(i+1)-1 5454 k = Cols0(j) 5455 DO j2 = A % Rows(i), A % Rows(i+1)-1 5456 k2 = A % Cols(j2) 5457 IF( k == k2 ) THEN 5458 A % BulkValues(j2) = BulkValues0(j) 5459 EXIT 5460 END IF 5461 END DO 5462 END DO 5463 END DO 5464 5465 DEALLOCATE( Cols0, Rows0, BulkValues0 ) 5466 END IF 5467 5468 CALL Info(Caller,'Modified matrix non-zeros: '& 5469 //TRIM(I2S(SIZE( A % Cols ))),Level=8) 5470 END IF 5471 END IF 5472 5473 5474 IF( InfoActive(12) ) THEN 5475 DirCount = NINT( ParallelReduction( 1.0_dp * DirCount ) ) 5476 CALL Info(Caller,'Number of dofs set for '//TRIM(Name)//': '& 5477 //TRIM(I2S(DirCount)),Level=12) 5478 END IF 5479 5480 5481!------------------------------------------------------------------------------ 5482 5483 CONTAINS 5484 5485 ! Check n-t node setting element 5486 !------------------------------- 5487 SUBROUTINE CheckNTElement(n,elno) 5488 INTEGER :: n,elno 5489 INTEGER :: i,j,k,l,m,dim,kmax 5490 LOGICAL :: found 5491 REAL(KIND=dp) :: Condition(n), RotVec(3) 5492 5493 dim = CoordinateSystemDimension() 5494 5495 IF ( DOF <= 0 ) RETURN 5496 IF ( ALL(BoundaryReorder(Indexes(1:n))<1) ) RETURN 5497 IF ( .NOT. ListCheckPresent(ValueList, Name) ) RETURN 5498 IF ( ListGetLogical(ValueList,NormalTangentialName,Found) ) RETURN 5499 5500 IF ( Conditional ) THEN 5501 Condition(1:n) = ListGetReal( ValueList, CondName, n, Indexes, gotIt ) 5502 Conditional = Conditional .AND. GotIt 5503 END IF 5504 5505 ! 5506 ! Check for nodes belonging to n-t boundary getting set by other bcs. 5507 ! ------------------------------------------------------------------- 5508 DO j=1,n 5509 IF ( Conditional .AND. Condition(j)<0.0_dp ) CYCLE 5510 k = Perm(Indexes(j)) 5511 IF ( k > 0 ) THEN 5512 k = k + OffSet 5513 m = BoundaryReorder(Indexes(j)) 5514 IF ( m>0 ) THEN 5515 RotVec = 0._dp 5516 RotVec(DOF) = 1._dp 5517 CALL RotateNTSystem( RotVec, Indexes(j) ) 5518 kmax = 1 5519 DO k=1,dim 5520 IF ( ABS(RotVec(k)) > ABS(RotVec(kmax)) ) kmax = k 5521 END DO 5522 NTelement(m,kmax)=elno 5523 END IF 5524 END IF 5525 END DO 5526!------------------------------------------------------------------------------ 5527 END SUBROUTINE CheckNTElement 5528!------------------------------------------------------------------------------ 5529 5530 5531!------------------------------------------------------------------------------ 5532!> Set values related to a specific boundary or bulk element. 5533!------------------------------------------------------------------------------ 5534 SUBROUTINE SetElementValues(n,elno) 5535!------------------------------------------------------------------------------ 5536 INTEGER :: n,elno 5537 INTEGER :: i,j,k,l,m,dim,kmax,lmax 5538 LOGICAL :: CheckNT,found 5539 REAL(KIND=dp) :: Condition(n), Work(n), RotVec(3) 5540 5541 dim = CoordinateSystemDimension() 5542 5543 IF ( DOF > 0 ) THEN 5544 IF (Model % Solver % DG) THEN 5545 Work(1:n) = ListGetReal( ValueList, Name, n, Element % NodeIndexes, gotIt ) 5546 ELSE 5547 Work(1:n) = ListGetReal( ValueList, Name, n, Indexes, gotIt ) 5548 END IF 5549 IF ( .NOT. GotIt ) THEN 5550 Work(1:n) = ListGetReal( ValueList, Name(1:nlen) // ' DOFs', n, Indexes, gotIt ) 5551 END IF 5552 ELSE 5553 CALL ListGetRealArray( ValueList, Name, WorkA, n, Indexes, gotIt ) 5554 END IF 5555 5556 IF ( gotIt ) THEN 5557 IF ( Conditional ) THEN 5558 IF (Model % Solver % DG) THEN 5559 Condition(1:n) = ListGetReal( ValueList, CondName, n, Element % NodeIndexes, gotIt ) 5560 ELSE 5561 Condition(1:n) = ListGetReal( ValueList, CondName, n, Indexes, gotIt ) 5562 END IF 5563 Conditional = Conditional .AND. GotIt 5564 END IF 5565 5566 ! 5567 ! Check for nodes belonging to n-t boundary getting set by other bcs. 5568 ! ------------------------------------------------------------------- 5569 CheckNT = .FALSE. 5570 IF ( NormalTangentialNOFNodes>0 .AND. DOF>0 ) THEN 5571 CheckNT = .TRUE. 5572 IF ( ALL(BoundaryReorder(Indexes(1:n))<1) ) CheckNT = .FALSE. 5573 IF ( ListGetLogical(ValueList,NormalTangentialName,Found)) CheckNT=.FALSE. 5574 END IF 5575 5576 DO j=1,n 5577 IF ( Conditional .AND. Condition(j) < 0.0d0 ) CYCLE 5578 5579 k = Perm(Indexes(j)) 5580 IF ( k > 0 ) THEN 5581 5582 IF ( DOF>0 ) THEN 5583 m = 0 5584 IF ( NormalTangentialNOFNodes>0 ) m=BoundaryReorder(Indexes(j)) 5585 IF ( m>0 .AND. CheckNT ) THEN 5586 RotVec = 0._dp 5587 RotVec(DOF) = 1._dp 5588 CALL RotateNTSystem( RotVec, Indexes(j) ) 5589 5590 ! When cartesian component "DOF" is defined set the N-T component 5591 ! closest to its direction. 5592 kmax = 1 5593 DO k=2,dim 5594 IF ( ABS(RotVec(k)) > ABS(RotVec(kmax)) ) THEN 5595 kmax = k 5596 END IF 5597 END DO 5598 5599 lmax = NDOFs * (Perm(Indexes(j))-1) + kmax 5600 IF ( .NOT. NTZeroing_done(m,kmax) ) THEN 5601 NTZeroing_done(m,kmax) = .TRUE. 5602 b(lmax) = 0._dp 5603 5604 IF( .NOT. OffDiagonal ) THEN 5605 b(lmax) = b(lmax) + Work(j) !/DiagScaling(lmax) 5606 END IF 5607 5608 ! Consider all components of the cartesian vector mapped to the 5609 ! N-T coordinate system. Should this perhaps have scaling included? 5610 DirCount = DirCount + 1 5611 CALL ZeroRow( A,lmax ) 5612 IF( .NOT. OffDiagonal) THEN 5613 DO k=1,dim 5614 l = NDOFs * (Perm(Indexes(j))-1) + k 5615 CALL SetMatrixElement( A,lmax,l,RotVec(k) ) 5616 END DO 5617 END IF 5618 NTZeroing_done(m,kmax) = .TRUE. 5619 A % ConstrainedDOF(lmax) = .FALSE. 5620 END IF 5621 ELSE 5622 DirCount = DirCount + 1 5623 CALL SetSinglePoint(k,DOF,Work(j),.FALSE.) 5624 END IF 5625 ELSE 5626 DO l=1,MIN( NDOFs, SIZE(WorkA,1) ) 5627 DirCount = DirCount + 1 5628 CALL SetSinglePoint(k,l,WorkA(l,1,j),.FALSE.) 5629 END DO 5630 END IF 5631 END IF 5632 END DO 5633 END IF 5634!------------------------------------------------------------------------------ 5635 END SUBROUTINE SetElementValues 5636!------------------------------------------------------------------------------ 5637 5638 5639 5640!------------------------------------------------------------------------------ 5641!> Set values related to a specific boundary or bulk element. 5642!> If scaling has been applied the rows need to be scaled when 5643!> they are moved. 5644!------------------------------------------------------------------------------ 5645 SUBROUTINE SetLumpedRows(ind0,n) 5646!------------------------------------------------------------------------------ 5647 INTEGER :: ind0,n 5648 INTEGER :: ind,i,j,k,k0 5649 REAL(KIND=dp) :: Coeff 5650 ! ------------------------------------------------------------------- 5651 5652 5653 DO j=1,n 5654 ind = Indexes(j) 5655 5656 IF( LumpedNodeSet(ind) ) CYCLE 5657 LumpedNodeSet(ind) = .TRUE. 5658 5659 IF ( DOF > 0 ) THEN 5660 k0 = Offset + NDOFs * (Perm(ind0)-1) + DOF 5661 k = OffSet + NDOFs * (Perm(ind)-1) + DOF 5662 5663 Coeff = 1.0_dp 5664 5665 CALL MoveRow( A, k, k0, Coeff ) 5666 b(k0) = b(k0) + Coeff * b(k) 5667 5668 CALL AddToMatrixElement( A, k, k, 1.0_dp ) 5669 CALL AddToMatrixElement( A, k, k0, -Coeff ) 5670 b(k) = 0.0_dp 5671 ELSE 5672 DO l = 1, NDOFs 5673 k0 = Offset + NDOFs + (Perm(ind0)-1) * DOF 5674 k = OffSet + NDOFs * (Perm(ind)-1) + l 5675 5676 Coeff = 1.0_dp 5677 5678 CALL MoveRow( A, k, k0, Coeff ) 5679 b(k0) = b(k0) + Coeff * b(k) 5680 5681 CALL AddToMatrixElement( A, k, k, 1.0_dp ) 5682 CALL AddToMatrixElement( A, k, k0, -Coeff ) 5683 END DO 5684 END IF 5685 END DO 5686 5687!------------------------------------------------------------------------------ 5688 END SUBROUTINE SetLumpedRows 5689!------------------------------------------------------------------------------ 5690 5691 5692!------------------------------------------------------------------------------ 5693!> Set values related to a rigid plane boundary such that any node on the boundary 5694!> is expressed as linear combinination of the selected three (or two if on line) 5695!> nodes. 5696!------------------------------------------------------------------------------ 5697 SUBROUTINE SetRigidRows(inds0,bcind,n) 5698!------------------------------------------------------------------------------ 5699 INTEGER :: inds0(:) 5700 INTEGER :: bcind 5701 INTEGER :: n 5702 5703 INTEGER :: bcind0 = 0 5704 INTEGER :: ind,i,j,k,k0 5705 REAL(KIND=dp) :: Coeff, Weights(3) 5706 REAL(KIND=dp) :: BaseCoord(3,3),r1(3),r2(3),Coord(3),dCoord(3),Amat(2,2),A0mat(2,2),bvec(2) 5707 5708 SAVE bcind0, BaseCoord, A0mat, r1, r2 5709!------------------------------------------------------------------- 5710 5711 IF(bcind /= bcind0 ) THEN 5712 BaseCoord = 0.0_dp 5713 DO i=1,dim 5714 j = inds0(i) 5715 BaseCoord(i,1) = Mesh % Nodes % x(j) 5716 BaseCoord(i,2) = Mesh % Nodes % y(j) 5717 BaseCoord(i,3) = Mesh % Nodes % z(j) 5718 END DO 5719 bcind0 = bcind 5720 5721 r1 = BaseCoord(2,:) - BaseCoord(1,:) 5722 Amat(1,1) = SUM(r1*r1) 5723 5724 IF( dim == 3 ) THEN 5725 r2 = BaseCoord(3,:) - BaseCoord(1,:) 5726 Amat(1,2) = SUM(r1*r2) 5727 Amat(2,1) = Amat(1,2) 5728 Amat(2,2) = SUM(r2*r2) 5729 END IF 5730 5731 A0mat = Amat 5732 bcind0 = bcind 5733 END IF 5734 5735 DO j=1,n 5736 ind = Indexes(j) 5737 5738 IF( LumpedNodeSet(ind) ) CYCLE 5739 LumpedNodeSet(ind) = .TRUE. 5740 5741 Coord(1) = Mesh % Nodes % x(ind) 5742 Coord(2) = Mesh % Nodes % y(ind) 5743 Coord(3) = Mesh % Nodes % z(ind) 5744 5745 dCoord = Coord - BaseCoord(1,:) 5746 5747 bvec(1) = SUM( dCoord * r1 ) 5748 IF( dim == 3 ) THEN 5749 bvec(2) = SUM( dCoord * r2 ) 5750 END IF 5751 5752 IF( dim == 2 ) THEN 5753 bvec(1) = bvec(1) / A0mat(1,1) 5754 Weights(2) = bvec(1) 5755 Weights(1) = 1.0_dp - Weights(2) 5756 ELSE 5757 Amat = A0mat 5758 CALL LUSolve(2,Amat,bvec) 5759 Weights(2:3) = bvec(1:2) 5760 Weights(1) = 1.0_dp - SUM(bvec(1:2)) 5761 END IF 5762 5763 DO l = 1, dim 5764 k = OffSet + NDOFs * (Perm(ind)-1) + l 5765 5766 ! Distribute row in accordance with the weights 5767 DO m = 1, dim 5768 k0 = Offset + NDOFs * (Perm(inds0(m))-1) + l 5769 Coeff = Weights(m) 5770 5771 b(k0) = b(k0) + Coeff * b(k) 5772 IF( m < dim ) THEN 5773 ! This does not nullify the row 5774 CALL MoveRow( A, k, k0, Coeff, 1.0_dp ) 5775 ELSE 5776 ! Now also nullify the row 5777 CALL MoveRow( A, k, k0, Coeff ) 5778 b(k) = 0.0_dp 5779 END IF 5780 END DO 5781 5782 ! Express the node as linear combination of the base nodes 5783 DO m = 1,dim 5784 k0 = Offset + NDOFs * (Perm(inds0(m))-1) + l 5785 Coeff = Weights(m) 5786 CALL AddToMatrixElement( A, k, k0, -Coeff ) 5787 END DO 5788 CALL AddToMatrixElement( A, k, k, 1.0_dp ) 5789 END DO 5790 5791 END DO 5792 5793!------------------------------------------------------------------------------ 5794 END SUBROUTINE SetRigidRows 5795!------------------------------------------------------------------------------ 5796 5797 5798!------------------------------------------------------------------------------ 5799!> Set values related to individual points. 5800!------------------------------------------------------------------------------ 5801 SUBROUTINE SetPointValues(n) 5802!------------------------------------------------------------------------------ 5803 INTEGER :: n 5804 REAL(KIND=dp) :: Work(n), Condition(n) 5805 5806 INTEGER :: i,j,k,k1,l 5807 5808 IF ( DOF > 0 ) THEN 5809 Work(1:n) = ListGetReal( ValueList, Name, n, NodeIndexes, gotIt ) 5810 ELSE 5811 CALL ListGetRealArray( ValueList, Name, WorkA, n, NodeIndexes, gotIt ) 5812 END IF 5813 5814 IF ( gotIt ) THEN 5815 5816 Condition(1:n) = 1.0d0 5817 IF ( Conditional ) THEN 5818 Condition(1:n) = ListGetReal( ValueList, CondName, n, NodeIndexes, gotIt ) 5819 Conditional = Conditional .AND. GotIt 5820 END IF 5821 5822 DO j=1,n 5823 k = Perm(NodeIndexes(j)) 5824 IF( k == 0 ) CYCLE 5825 5826 IF ( Conditional .AND. Condition(j) < 0.0d0 ) CYCLE 5827 IF ( NodeIndexes(j) > SIZE(Perm) .OR. NodeIndexes(j) < 1 ) THEN 5828 CALL Warn(Caller,'Invalid Node Number') 5829 CYCLE 5830 END IF 5831 5832 IF ( DOF>0 ) THEN 5833 CALL SetSinglePoint(k,DOF,Work(j),.FALSE.) 5834 ELSE 5835 DO l=1,MIN( NDOFs, SIZE(Worka,1) ) 5836 CALL SetSinglePoint(k,l,WorkA(l,1,j),.FALSE.) 5837 END DO 5838 END IF 5839 5840 END DO 5841 END IF 5842!------------------------------------------------------------------------------ 5843 END SUBROUTINE SetPointValues 5844!------------------------------------------------------------------------------ 5845 5846 5847!------------------------------------------------------------------------------ 5848!> Set values related to one single point 5849!------------------------------------------------------------------------------ 5850 SUBROUTINE SetSinglePoint(ind,DOF,val,ApplyPerm) 5851!------------------------------------------------------------------------------ 5852 LOGICAL :: ApplyPerm 5853 INTEGER :: ind, DOF 5854 REAL(KIND=dp) :: val 5855 5856 REAL(KIND=dp) :: s 5857 INTEGER :: i,j,k,k1,l 5858 5859 5860 IF(.NOT. ALLOCATED(A % ConstrainedDOF)) THEN 5861 ALLOCATE(A % ConstrainedDOF(A % NumberOfRows)) 5862 A % ConstrainedDOF = .FALSE. 5863 END IF 5864 5865 IF(.NOT. ALLOCATED(A % Dvalues)) THEN 5866 ALLOCATE(A % Dvalues(A % NumberOfRows)) 5867 A % Dvalues = 0._dp 5868 END IF 5869 5870 k = ind 5871 IF (ApplyPerm) k = Perm(ind) 5872 IF( k == 0 ) RETURN 5873 5874 k = OffSet + NDOFs * (k-1) + DOF 5875 5876 ! Do not add non-zero entries to pure halo nodes which are not associated with the partition. 5877 ! These are nodes could be created by the -halobc flag in ElmerGrid. 5878 IF( ParEnv % PEs > 1 ) THEN 5879 IF( .NOT. ANY( A % ParallelInfo % NeighbourList(k) % Neighbours == ParEnv % MyPe ) ) THEN 5880 RETURN 5881 END IF 5882 END IF 5883 5884 DirCount = DirCount + 1 5885 5886 IF( .NOT. OffDiagonal ) THEN 5887 A % Dvalues(k) = val 5888 END IF 5889 A % ConstrainedDOF(k) = .TRUE. 5890 5891!------------------------------------------------------------------------------ 5892 END SUBROUTINE SetSinglePoint 5893!------------------------------------------------------------------------------ 5894 5895 5896!------------------------------------------------------------------------------ 5897!> Set values related to upper and lower limiters. 5898!------------------------------------------------------------------------------ 5899 SUBROUTINE SetLimiterValues(n) 5900!------------------------------------------------------------------------------ 5901 INTEGER :: n 5902 REAL(KIND=dp) :: Work(n) 5903 5904 Work(1:n) = ListGetReal( ValueList, CondName, n, NodeIndexes, gotIt ) 5905 5906 IF ( gotIt ) THEN 5907 DO j=1,n 5908 k = Perm(NodeIndexes(j)) 5909 IF( k == 0 ) CYCLE 5910 5911 IF( .NOT. LimitActive(nDofs*(k-1)+dof)) CYCLE 5912 CALL SetSinglePoint(k,DOF,Work(j),.FALSE.) 5913 END DO 5914 END IF 5915!------------------------------------------------------------------------------ 5916 END SUBROUTINE SetLimiterValues 5917!------------------------------------------------------------------------------ 5918 5919 5920!------------------------------------------------------------------------------ 5921!> At first pass sum together the rows related to the periodic dofs. 5922!------------------------------------------------------------------------------ 5923 SUBROUTINE SetPeriodicBoundariesPass1( Model, A, b, & 5924 Name, DOF, NDOFs, Perm, This, Done ) 5925!------------------------------------------------------------------------------ 5926 TYPE(Model_t) :: Model !< The current model structure 5927 TYPE(Matrix_t), POINTER :: A !< The global matrix 5928 REAL(KIND=dp) :: b(:) !< The global RHS vector 5929 CHARACTER(LEN=*) :: Name !< name of the dof to be set 5930 LOGICAL :: Done(:) !< Has the node already been done. 5931 INTEGER :: This !< Number of the current boundary. 5932 INTEGER :: DOF !< The order number of the dof 5933 INTEGER :: NDOFs !< the total number of DOFs for this equation 5934 INTEGER, TARGET :: Perm(:) !< The node reordering info, this has been generated at the 5935 !< beginning of the simulation for bandwidth optimization 5936!------------------------------------------------------------------------------ 5937 INTEGER :: p,q,i,j,k,l,m,n,nn,ii,nlen,jmp,size0 5938 INTEGER, POINTER :: PPerm(:) 5939 LOGICAL :: GotIt, Found, Jump 5940 REAL(KIND=dp) :: Scale, weight, coeff 5941 TYPE(Matrix_t), POINTER :: F, G, Projector, Projector1 5942 TYPE(Variable_t), POINTER :: Var, WeightVar 5943 TYPE(ValueList_t), POINTER :: BC 5944 TYPE(MortarBC_t), POINTER :: MortarBC 5945!------------------------------------------------------------------------------ 5946 5947 nlen = LEN_TRIM(Name) 5948 BC => Model % BCs(This) % Values 5949 5950 IF ( ListGetLogical( BC,& 5951 'Periodic BC ' // Name(1:nlen), GotIt ) ) THEN 5952 IF( ListGetLogical( BC,'Antisymmetric BC',GotIt ) ) THEN 5953 Scale = 1.0_dp 5954 ELSE 5955 Scale = -1.0_dp 5956 END IF 5957 ELSE IF ( ListGetLogical( BC, & 5958 'Anti Periodic BC ' // Name(1:nlen), GotIt ) ) THEN 5959 Scale = 1.0d0 5960 ELSE 5961 Scale = ListGetConstReal( BC, & 5962 'Periodic BC Scale ' // Name(1:nlen), GotIt) 5963 IF(.NOT. GotIt ) RETURN 5964 END IF 5965 5966 Projector => Model % BCs(This) % PMatrix 5967 IF ( .NOT. ASSOCIATED(Projector) ) RETURN 5968 5969! For explicit conditions just create the dependency almost like a normal Dirichlet BC, 5970! For implicit one (otherwise) do the assembly of the projector: 5971! --------------------------------- 5972 IF ( ListGetLogical( BC, & 5973 'Periodic BC Explicit', Found ) ) THEN 5974 5975 Var => VariableGet( Model % Variables,Name(1:nlen) ) 5976 5977 DO i=1,Projector % NumberOfRows 5978 ii = Projector % InvPerm(i) 5979 IF( ii == 0 ) CYCLE 5980 k = Perm(ii) 5981 IF ( .NOT. Done(ii) .AND. k>0 ) THEN 5982 k = NDOFs * (k-1) + DOF 5983 !IF( .NOT.A % NoDirichlet ) THEN 5984 ! CALL ZeroRow( A,k ) 5985 ! CALL AddToMatrixElement( A, k, k, 1.0_dp ) 5986 !ELSE 5987 !END IF 5988 !IF(ALLOCATED(A % Dvalues)) 5989 A % Dvalues(k) = 0._dp 5990 !IF(ALLOCATED(A % ConstrainedDOF)) 5991 A % ConstrainedDOF(k) = .TRUE. 5992 5993 DO l = Projector % Rows(i), Projector % Rows(i+1)-1 5994 IF ( Projector % Cols(l) <= 0 ) CYCLE 5995 m = Perm( Projector % Cols(l) ) 5996 IF ( m > 0 ) THEN 5997 m = NDOFs * (m-1) + DOF 5998 !IF(ALLOCATED(A % Dvalues)) THEN 5999 A % Dvalues(k) = A % Dvalues(k) - Scale * Projector % Values(l) * & 6000 Var % Values(m) !/DiagScaling(k) 6001 !ELSE 6002 ! b(k) = b(k) - Scale * Projector % Values(l) * & 6003 ! Var % Values(m)/DiagScaling(k) 6004 !END IF 6005 END IF 6006 END DO 6007 END IF 6008 END DO 6009 6010 ELSE IF ( ListGetLogical( BC, & 6011 'Periodic BC Use Lagrange Coefficient', Found ) ) THEN 6012 6013 Jump = ListCheckPresent( BC, & 6014 'Periodic BC Coefficient '//Name(1:nlen)) 6015 6016 IF( .NOT. ASSOCIATED( Model % Solver % MortarBCs ) ) THEN 6017 CALL Info('SetPeriodicBoundariesPass1',& 6018 'Allocating mortar BCs for solver',Level=8) 6019 ALLOCATE( Model % Solver % MortarBCs( Model % NumberOfBCs ) ) 6020 DO i=1, Model % NumberOfBCs 6021 Model % Solver % MortarBCs(i) % Projector => NULL() 6022 END DO 6023 END IF 6024 6025 IF( ASSOCIATED( Projector, & 6026 Model % Solver % MortarBCs(This) % Projector) ) THEN 6027 CALL Info('SetPeriodicBoundariesPass1','Using existing projector: '& 6028 //TRIM(I2S(This)),Level=8) 6029 RETURN 6030 END IF 6031 6032 Model % Solver % MortarBCs(This) % Projector => Projector 6033 CALL Info('SetPeridociBoundariesPass1','Using projector as mortar constraint: '& 6034 //TRIM(I2S(This)),Level=8) 6035 6036 MortarBC => Model % Solver % MortarBCs(This) 6037 IF( Jump ) THEN 6038 IF( ASSOCIATED( MortarBC % Diag ) ) THEN 6039 IF( SIZE( MortarBC % Diag ) < NDofs * Projector % NumberOfRows ) THEN 6040 DEALLOCATE( MortarBC % Diag ) 6041 END IF 6042 END IF 6043 IF( .NOT. ASSOCIATED( MortarBC % Diag ) ) THEN 6044 CALL Info('SetPeriodicBoundariesPass1','Allocating projector mortar diag',Level=10) 6045 ALLOCATE( MortarBC % Diag( NDofs * Projector % NumberOfRows ) ) 6046 MortarBC % Diag = 0.0_dp 6047 ELSE 6048 MortarBC % Diag( DOF::NDOFs ) = 0.0_dp 6049 END IF 6050 6051 IF( ASSOCIATED( MortarBC % Rhs ) ) THEN 6052 IF( SIZE( MortarBC % Rhs ) < NDofs * Projector % NumberOfRows ) THEN 6053 DEALLOCATE( MortarBC % Rhs ) 6054 END IF 6055 END IF 6056 IF( .NOT. ASSOCIATED( MortarBC % Rhs ) ) THEN 6057 CALL Info('SetPeriodicBoundariesPass1','Allocating projector mortar rhs',Level=10) 6058 ALLOCATE( MortarBC % Rhs( NDofs * Projector % NumberOfRows ) ) 6059 MortarBC % Rhs = 0.0_dp 6060 ELSE 6061 MortarBC % Rhs( DOF::NDOFs ) = 0.0_dp 6062 END IF 6063 END IF 6064 6065 ! Create the permutation that is later need in putting the diag and rhs to correct position 6066 IF( ASSOCIATED( MortarBC % Perm ) ) THEN 6067 IF( SIZE( MortarBC % Perm ) < SIZE( Perm ) ) THEN 6068 DEALLOCATE( MortarBC % Perm ) 6069 END IF 6070 END IF 6071 IF( .NOT. ASSOCIATED( MortarBC % Perm ) ) THEN 6072 CALL Info('SetPeriodicBoundariesPass1','Allocating projector mortar perm',Level=10) 6073 ALLOCATE( MortarBC % Perm( SIZE( Perm ) ) ) 6074 END IF 6075 6076 MortarBC % Perm = 0 6077 DO i=1,SIZE( Projector % InvPerm ) 6078 j = Projector % InvPerm(i) 6079 IF( j > 0 .AND. j <= SIZE( Perm ) ) THEN 6080 MortarBC % Perm( j ) = i 6081 END IF 6082 END DO 6083 6084 ! We can use directly the nodal projector 6085 MortarBC % Projector => Projector 6086 MortarBC % SlaveScale = -Scale 6087 MortarBC % MasterScale = -1.0_dp 6088 6089 IF( Jump ) THEN 6090 PPerm => Perm 6091 CALL CalculateNodalWeights(Model % Solver,.TRUE.,& 6092 PPerm,'Periodic BC Coefficient '//Name(1:nlen),WeightVar ) 6093 IF(.NOT. ASSOCIATED( WeightVar ) ) THEN 6094 CALL Fatal('SetPeriodicBoundariesPass1','Nodal weights needed for setting jumps!') 6095 END IF 6096 6097 DO i=1,Projector % NumberOfRows 6098 k = Projector % InvPerm(i) 6099 IF ( k<=0 ) CYCLE 6100 6101 ! Add the diagonal unity projector (scaled) 6102 weight = WeightVar % Values( PPerm( k ) ) 6103 coeff = ListGetRealAtNode( BC,'Periodic BC Coefficient '& 6104 //Name(1:nlen), k, Found ) 6105 6106 ! For Nodal projector the entry is 1/(weight*coeff) 6107 ! For Galerkin projector the is weight/coeff 6108 IF( Found ) THEN 6109 MortarBC % Diag( NDOFS* (i-1) + DOF ) = 1.0_dp / ( weight * coeff ) 6110 END IF 6111 END DO 6112 END IF 6113 6114 Model % Solver % MortarBCsChanged = .TRUE. 6115 6116 ELSE 6117 6118 ALLOCATE(F) 6119 F = A 6120 F % RHS => F % BulkRHS 6121 F % Values => F % BulkValues 6122 6123 DO i=1,Projector % NumberOfRows 6124 ii = Projector % InvPerm(i) 6125 IF( ii == 0 ) CYCLE 6126 k = Perm(ii) 6127 IF ( .NOT. Done(ii) .AND. k>0 ) THEN 6128 k = NDOFs * (k-1) + DOF 6129 DO l=Projector % Rows(i),Projector % Rows(i+1)-1 6130 IF ( Projector % Cols(l) <= 0 .OR. Projector % Values(l)==0.0d0 ) CYCLE 6131 6132 m = Perm(Projector % Cols(l)) 6133 IF ( m > 0 ) THEN 6134 m = NDOFs*(m-1) + DOF 6135 DO nn=A % Rows(k),A % Rows(k+1)-1 6136 CALL AddToMatrixElement( A, m, A % Cols(nn), & 6137 -scale*Projector % Values(l) * A % Values(nn) ) !/ & 6138 !DiagScaling(k) * DiagScaling(m)) 6139 IF (ASSOCIATED(F % Values)) THEN 6140 CALL AddToMatrixElement( F, m, F % Cols(nn), & 6141 -scale*Projector % Values(l) * F % Values(nn) ) 6142 END IF 6143 END DO 6144 b(m)=b(m) - scale*Projector % Values(l)*b(k) !*& 6145 !DiagScaling(m) / DiagScaling(k) 6146 IF (ASSOCIATED(F % RHS)) THEN 6147 F % RHS(m) = F % RHS(m) - scale*Projector % Values(l)*F % RHS(k) 6148 END IF 6149 END IF 6150 END DO 6151 END IF 6152 Done(ii) = .TRUE. 6153 END DO 6154 DEALLOCATE(F) 6155 END IF 6156 6157!------------------------------------------------------------------------------ 6158 END SUBROUTINE SetPeriodicBoundariesPass1 6159!------------------------------------------------------------------------------ 6160 6161 6162!> At second pass add the [...1 .. -1 ...] row structure that results to the 6163!> equality of the periodic dofs. 6164!------------------------------------------------------------------------------ 6165 SUBROUTINE SetPeriodicBoundariesPass2( Model, A, b, & 6166 Name, DOF, NDOFs, Perm, This, Done ) 6167!------------------------------------------------------------------------------ 6168 TYPE(Model_t) :: Model !< The current model structure 6169 TYPE(Matrix_t), POINTER :: A !< The global matrix 6170 REAL(KIND=dp) :: b(:) !< The global RHS vector 6171 CHARACTER(LEN=*) :: Name !< name of the dof to be set 6172 LOGICAL :: Done(:) !< Has the node already been done. 6173 INTEGER :: This !< Number of the current boundary. 6174 INTEGER :: DOF !< The order number of the dof 6175 INTEGER :: NDOFs !< the total number of DOFs for this equation 6176 INTEGER, TARGET :: Perm(:) !< The node reordering info, this has been generated at the 6177!------------------------------------------------------------------------------ 6178 INTEGER :: i,j,k,l,m,n,nn,ii,nlen 6179 LOGICAL :: GotIt, Jump, Found 6180 REAL(KIND=dp) :: Scale,s,ValueOffset,val,coeff,weight 6181 TYPE(Matrix_t), POINTER :: Projector 6182 INTEGER, POINTER :: PPerm(:) 6183 TYPE(ValueList_t), POINTER :: BC 6184 TYPE(Variable_t), POINTER :: WeightVar 6185!------------------------------------------------------------------------------ 6186 6187 6188 BC => Model % BCs(This) % Values 6189 IF ( ListGetLogical( BC, & 6190 'Periodic BC Use Lagrange Coefficient', GotIt ) ) RETURN 6191 6192 IF ( ListGetLogical( BC, & 6193 'Periodic BC Explicit', GotIt ) ) RETURN 6194 6195 nlen = LEN_TRIM(Name) 6196 6197 IF ( ListGetLogical( BC, & 6198 'Periodic BC ' // Name(1:nlen), GotIt ) ) THEN 6199 IF( ListGetLogical( BC,'Antisymmetric BC',GotIt ) ) THEN 6200 Scale = 1.0_dp 6201 ELSE 6202 Scale = -1.0_dp 6203 END IF 6204 ELSE IF ( ListGetLogical( BC, & 6205 'Anti Periodic BC ' // Name(1:nlen), GotIt ) ) THEN 6206 Scale = 1.0d0 6207 ELSE 6208 Scale = ListGetCReal( BC, & 6209 'Periodic BC Scale ' // Name(1:nlen), GotIt) 6210 IF(.NOT. GotIt ) RETURN 6211 END IF 6212 6213 ValueOffset = ListGetCReal( BC, & 6214 'Periodic BC Offset ' // Name(1:nlen), GotIt) 6215 6216 Jump = ListCheckPresent( BC, & 6217 'Periodic BC Coefficient '//Name(1:nlen)) 6218 IF( Jump ) THEN 6219 PPerm => Perm 6220 CALL CalculateNodalWeights(Model % Solver,.TRUE.,& 6221 PPerm,'Periodic BC Coefficient '//Name(1:nlen),WeightVar ) 6222 IF(.NOT. ASSOCIATED( WeightVar ) ) THEN 6223 CALL Fatal('SetPeriodicBoundariesPass1','Nodal weights needed for setting jumps!') 6224 END IF 6225 END IF 6226 6227 Projector => Model % BCs(This) % PMatrix 6228 IF ( .NOT. ASSOCIATED(Projector) ) RETURN 6229 6230 6231! Do the assembly of the projector: 6232! --------------------------------- 6233 DO i=1,Projector % NumberOfRows 6234 ii = Projector % InvPerm(i) 6235 IF( ii == 0 ) CYCLE 6236 6237 k = Perm( ii ) 6238 IF ( .NOT. Done(ii) .AND. k > 0 ) THEN 6239 6240 IF( Jump ) THEN 6241 weight = WeightVar % Values( k ) 6242 coeff = ListGetRealAtNode( BC,'Periodic BC Coefficient '& 6243 //Name(1:nlen),ii, Found ) 6244 val = -weight * coeff !* DiagScaling(k)**2 6245 scale = -1.0 6246 ELSE 6247 val = 1.0_dp 6248 END IF 6249 6250 k = NDOFs * (k-1) + DOF 6251 IF(.NOT. Jump) THEN 6252 CALL ZeroRow( A,k ) 6253 b(k) = 0.0_dp 6254 END IF 6255 6256 DO l = Projector % Rows(i), Projector % Rows(i+1)-1 6257 IF ( Projector % Cols(l) <= 0 ) CYCLE 6258 m = Perm( Projector % Cols(l) ) 6259 IF ( m > 0 ) THEN 6260 m = NDOFs * (m-1) + DOF 6261 CALL AddToMatrixElement( A,k,m,val * Projector % Values(l) ) !* & 6262 !( DiagScaling(m) / DiagScaling(k) ) ) 6263 END IF 6264 END DO 6265 6266 !IF(.NOT. Jump) THEN 6267 ! A % ConstrainedDof(k) = .TRUE. 6268 ! A % DValues(k) = -ValueOffset 6269 !ELSE 6270 b(k) = b(k) - ValueOffset !/ DiagScaling(k) 6271 !END IF 6272 CALL AddToMatrixElement( A,k,k,scale*val ) 6273 6274 END IF 6275 Done(ii) = .TRUE. 6276 END DO 6277!------------------------------------------------------------------------------ 6278 END SUBROUTINE SetPeriodicBoundariesPass2 6279!------------------------------------------------------------------------------ 6280 6281 6282 6283 6284!> At first pass sum together the rows related to the periodic dofs. 6285!------------------------------------------------------------------------------ 6286 SUBROUTINE SetFrictionBoundaries( Model, A, b, & 6287 Name, NDOFs, Perm ) 6288!------------------------------------------------------------------------------ 6289 TYPE(Model_t) :: Model !< The current model structure 6290 TYPE(Matrix_t), POINTER :: A !< The global matrix 6291 REAL(KIND=dp) :: b(:) !< The global RHS vector 6292 CHARACTER(LEN=*) :: Name !< name of the dof to be set 6293 INTEGER :: NDOFs !< the total number of DOFs for this equation 6294 INTEGER, TARGET :: Perm(:) !< The node reordering info, this has been generated at the 6295 !< beginning of the simulation for bandwidth optimization 6296!------------------------------------------------------------------------------ 6297 INTEGER :: t,u,j,k,k2,l,l2,n,bc_id,nlen,NormalInd 6298 LOGICAL :: Found 6299 REAL(KIND=dp),ALLOCATABLE :: Coeff(:) 6300 LOGICAL, ALLOCATABLE :: NodeDone(:) 6301 TYPE(ValueList_t), POINTER :: BC 6302 TYPE(Mesh_t), POINTER :: Mesh 6303 TYPE(Element_t), POINTER :: Element 6304 INTEGER, POINTER :: NodeIndexes(:) 6305!------------------------------------------------------------------------------ 6306 6307 6308 CALL Info('SetFrictionBoundaries','Setting friction boundaries for variable: '//TRIM(Name),& 6309 Level=8) 6310 6311 IF( NDOFs /= 2 ) THEN 6312 CALL Warn('SetFrictionBoundaries','Assumes friction only in 2D system') 6313 END IF 6314 6315 nlen = LEN_TRIM(Name) 6316 Mesh => Model % Mesh 6317 6318 ALLOCATE( NodeDone( SIZE( Perm ) ) ) 6319 ALLOCATE( Coeff( Mesh % MaxElementNodes ) ) 6320 6321 NodeDone = .FALSE. 6322 Coeff = 0.0_dp 6323 6324 DO t = Mesh % NumberOfBulkElements+1, & 6325 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 6326 Element => Mesh % Elements(t) 6327 6328 Model % CurrentElement => Element 6329 6330 DO bc_id = 1,Model % NumberOfBCs 6331 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc_id) % Tag ) EXIT 6332 END DO 6333 IF ( bc_id > CurrentModel % NumberOfBCs ) CYCLE 6334 BC => Model % BCs(bc_id) % Values 6335 6336 IF( .NOT. ListGetLogical( BC,& 6337 'Friction BC ' // Name(1:nlen), Found ) ) CYCLE 6338 6339 NodeIndexes => Element % NodeIndexes 6340 n = Element % TYPE % NumberOfNodes 6341 6342 Coeff(1:n) = ListGetReal( BC,& 6343 'Friction Coefficient ' // Name(1:nlen), n, NodeIndexes ) 6344 IF( ListGetLogical( BC,& 6345 'Normal-Tangential ' // Name(1:nlen), Found ) ) THEN 6346 NormalInd = 1 6347 ELSE 6348 NormalInd = ListGetInteger( BC,& 6349 'Friction Normal Component ' // Name(1:nlen) ) 6350 END IF 6351 6352 DO i = 1, n 6353 j = Perm( Nodeindexes(i) ) 6354 IF( NodeDone( j ) ) CYCLE 6355 6356 k = NDOFs * (j-1) + NormalInd 6357 k2 = NDOFs * (j-1) + ( 3 - NormalInd ) 6358 6359 DO l = A % Rows(k),A % Rows(k+1)-1 6360 DO l2 = A % Rows(k2), A % Rows(k2+1)-1 6361 IF( A % Cols(l2) == A % Cols(l) ) EXIT 6362 END DO 6363 A % Values(l2) = A % Values(l2) - Coeff(i) * A % Values(l) 6364 END DO 6365 A % Rhs(k2) = A % Rhs(k2) - Coeff(i) * A % Rhs(k) 6366 NodeDone( j ) = .TRUE. 6367 END DO 6368 END DO 6369 6370 n = COUNT( NodeDone ) 6371 CALL Info('SetFrictionBoundaries','Number of friction nodes: '//TRIM(I2S(n)),Level=10) 6372 6373 DEALLOCATE( NodeDone, Coeff ) 6374 6375!------------------------------------------------------------------------------ 6376 END SUBROUTINE SetFrictionBoundaries 6377!------------------------------------------------------------------------------ 6378 6379 6380!> Set the diagonal entry related to mortar BCs. 6381!> This implements the implicit jump condition. 6382!------------------------------------------------------------------------------ 6383 SUBROUTINE SetWeightedProjectorJump( Model, A, b, & 6384 Name, DOF, NDOFs, Perm ) 6385 !------------------------------------------------------------------------------ 6386 TYPE(Model_t) :: Model !< The current model structure 6387 TYPE(Matrix_t), POINTER :: A !< The global matrix 6388 REAL(KIND=dp) :: b(:) !< The global RHS vector 6389 CHARACTER(LEN=*) :: Name !< name of the dof to be set 6390 INTEGER :: DOF !< The order number of the dof 6391 INTEGER :: NDOFs !< the total number of DOFs for this equation 6392 INTEGER, TARGET :: Perm(:) !< The node reordering info 6393 !------------------------------------------------------------------------------ 6394 INTEGER :: i,j,k,i2,j2,k2,n,u,v,node,totsize,nodesize,bc_ind,& 6395 nnodes,nlen,TargetBC 6396 INTEGER, POINTER :: PPerm(:) 6397 INTEGER, ALLOCATABLE :: InvInvPerm(:) 6398 LOGICAL :: Found, AddRhs, AddCoeff, AddRes 6399 LOGICAL, ALLOCATABLE :: NodeDone(:) 6400 REAL(KIND=dp) :: coeff, weight, voff, res 6401 TYPE(Matrix_t), POINTER :: Projector 6402 TYPE(ValueList_t), POINTER :: BC 6403 TYPE(Element_t), POINTER :: Element, Left, Right 6404 LOGICAL :: SomethingDone 6405 TYPE(MortarBC_t), POINTER :: MortarBC 6406 !------------------------------------------------------------------------------ 6407 6408 ! If there is no mortar projector then nothing to do 6409 SomethingDone = .FALSE. 6410 6411 ! Go through the projectors and check for jumps 6412 ! If there is a jump add an entry to the diagonal-to-be 6413 DO bc_ind=1,Model % NumberOFBCs 6414 6415 MortarBC => Model % Solver % MortarBCs(bc_ind) 6416 6417 Projector => MortarBC % Projector 6418 IF( .NOT. ASSOCIATED( Projector ) ) CYCLE 6419 6420 ! For this boundary there should also be a coefficient 6421 ! otherwise nothing needs to be done. 6422 nlen = LEN_TRIM(Name) 6423 BC => Model % BCs(bc_ind) % Values 6424 6425 AddCoeff = ListCheckPresent( BC,'Mortar BC Coefficient '//Name(1:nlen)) 6426 AddRes = ListCheckPresent( BC,'Mortar BC Resistivity '//Name(1:nlen)) 6427 AddRhs = ListCheckPresent( BC,'Mortar BC Offset '//Name(1:nlen)) 6428 6429 IF( .NOT. (AddCoeff .OR. AddRes .OR. AddRhs) ) CYCLE 6430 6431 Model % Solver % MortarBCsChanged = .TRUE. 6432 6433 IF( .NOT. ASSOCIATED( Projector % InvPerm ) ) THEN 6434 CALL Fatal('SetWeightedProjectorJump','The > Projector % InvPerm < is really needed here!') 6435 END IF 6436 6437 totsize = MAXVAL( Perm ) 6438 nodesize = MAXVAL( Perm(1:Model % Mesh % NumberOfNodes ) ) 6439 6440 IF( AddCoeff .OR. AddRes ) THEN 6441 IF( ASSOCIATED( MortarBC % Diag ) ) THEN 6442 IF( SIZE( MortarBC % Diag ) < NDofs * Projector % NumberOfRows ) THEN 6443 DEALLOCATE( MortarBC % Diag ) 6444 END IF 6445 END IF 6446 IF( .NOT. ASSOCIATED( MortarBC % Diag ) ) THEN 6447 CALL Info('SetWeightedProjectorJump','Allocating projector mortar diag',Level=10) 6448 ALLOCATE( MortarBC % Diag( NDofs * Projector % NumberOfRows ) ) 6449 MortarBC % Diag = 0.0_dp 6450 ELSE 6451 MortarBC % Diag(DOF::NDOFs) = 0.0_dp 6452 END IF 6453 END IF 6454 6455 IF( AddRhs ) THEN 6456 IF( ASSOCIATED( MortarBC % Rhs ) ) THEN 6457 IF( SIZE( MortarBC % Rhs ) < NDofs * Projector % NumberOfRows ) THEN 6458 DEALLOCATE( MortarBC % Rhs ) 6459 END IF 6460 END IF 6461 IF( .NOT. ASSOCIATED( MortarBC % Rhs ) ) THEN 6462 CALL Info('SetWeightedProjectorJump','Allocating projector mortar rhs',Level=10) 6463 ALLOCATE( MortarBC % Rhs( NDofs * Projector % NumberOfRows ) ) 6464 MortarBC % Rhs = 0.0_dp 6465 ELSE 6466 MortarBC % Rhs(DOF::NDOFs) = 0.0_dp 6467 END IF 6468 END IF 6469 6470 ! Create the permutation that is later need in putting the diag and rhs to correct position 6471 IF( ASSOCIATED( MortarBC % Perm ) ) THEN 6472 IF( SIZE( MortarBC % Perm ) < SIZE( Perm ) ) THEN 6473 DEALLOCATE( MortarBC % Perm ) 6474 END IF 6475 END IF 6476 IF( .NOT. ASSOCIATED( MortarBC % Perm ) ) THEN 6477 CALL Info('SetWeightedProjectorJump','Allocating projector mortar perm',Level=10) 6478 ALLOCATE( MortarBC % Perm( SIZE( Perm ) ) ) 6479 END IF 6480 6481 MortarBC % Perm = 0 6482 DO i=1,SIZE( Projector % InvPerm ) 6483 j = Projector % InvPerm(i) 6484 IF( j > 0 .AND. j <= nodesize ) THEN 6485 MortarBC % Perm( j ) = i 6486 END IF 6487 END DO 6488 6489 6490 TargetBC = ListGetInteger( BC,'Mortar BC',Found ) 6491 6492 CALL Info('SetWeightedProjectorJump','Setting jump to mortar projector in BC '& 6493 //TRIM(I2S(bc_ind)),Level=7) 6494 6495 ! Create a table that shows how the additional degrees of freedom map 6496 ! to their corresponding regular dof. This is needed when creating the jump. 6497 ALLOCATE( NodeDone( Projector % NumberOfRows ) ) 6498 NodeDone = .FALSE. 6499 6500 ! Looping through elements rather than looping through projector rows directly 6501 ! is done in order to be able to refer to boundary properties associated 6502 ! with the element. 6503 DO t=1,Model % Mesh % NumberOfBoundaryElements 6504 Element => Model % Mesh % Elements( t + Model % Mesh % NumberOfBulkElements ) 6505 6506 IF( Element % BoundaryInfo % Constraint /= Model % BCs(bc_ind) % Tag ) CYCLE 6507 6508 ! Outside code this tells the active element 6509 Model % CurrentElement => Element 6510 6511 Left => Element % BoundaryInfo % Left 6512 Right => Element % BoundaryInfo % Right 6513 6514 IF( TargetBC > 0 ) THEN 6515 IF( ASSOCIATED( Left ) ) THEN 6516 IF( Left % PartIndex /= ParEnv % myPE ) CYCLE 6517 ELSE IF ( ASSOCIATED( Right ) ) THEN 6518 IF( Left % PartIndex /= ParEnv % myPE ) CYCLE 6519 ELSE 6520 CYCLE 6521 END IF 6522 ELSE 6523 ! This case is for the case when TargetBC = 0 i.e. for Discontinuous BC 6524 ! These are conditions that resulted to creation of zero 6525 ! constraint matrix entries in this partition so no need to do them. 6526 IF(.NOT. ASSOCIATED( Left ) .OR. .NOT. ASSOCIATED( Right ) ) THEN 6527 CYCLE 6528 END IF 6529 6530 ! For this we have a zero mass matrix entry so don't bother to add zero 6531! IF( Left % PartIndex /= ParEnv % myPE .AND. & 6532! Right % PartIndex /= ParEnv % myPe ) THEN 6533! CYCLE 6534! END IF 6535 END IF 6536 6537 nnodes = Element % TYPE % NumberOfNodes 6538 DO u=1, nnodes 6539 node = Element % NodeIndexes(u) 6540 6541 IF( Perm( node ) == 0 ) CYCLE 6542 6543 i = MortarBC % Perm( node ) 6544 IF( i == 0 ) CYCLE 6545 6546 IF( NodeDone( i ) ) CYCLE 6547 NodeDone( i ) = .TRUE. 6548 6549 Found = .FALSE. 6550 6551 IF( AddCoeff ) THEN 6552 coeff = ListGetRealAtNode( BC,'Mortar BC Coefficient '& 6553 //Name(1:nlen),node, Found ) 6554 res = 1.0_dp / coeff 6555 END IF 6556 6557 IF( AddRes ) THEN 6558 res = ListGetRealAtNode( BC,'Mortar BC Resistivity '& 6559 //Name(1:nlen),node, Found ) 6560 END IF 6561 6562 ! For Nodal projector the entry is 1/(weight*coeff) 6563 ! For Galerkin projector the is weight/coeff 6564 IF( Found ) THEN 6565 IF( AddCoeff .OR. Addres ) THEN 6566 MortarBC % Diag(NDOFs*(i-1)+DOF) = res 6567 END IF 6568 END IF 6569 6570 IF( AddRhs ) THEN 6571 voff = ListGetRealAtNode( BC,'Mortar BC Offset '& 6572 //Name(1:nlen),node, Found ) 6573 IF( Found ) THEN 6574 MortarBC % Rhs(NDofs*(i-1)+DOF) = voff 6575 END IF 6576 END IF 6577 6578 END DO 6579 END DO 6580 6581 SomethingDone = .TRUE. 6582 6583 DEALLOCATE( NodeDone ) 6584 END DO 6585 6586 IF( SomethingDone ) THEN 6587 CALL Info('setWeightedProjectorJump','Created a jump for weighted projector',Level=7) 6588 END IF 6589 6590!------------------------------------------------------------------------------ 6591 END SUBROUTINE SetWeightedProjectorJump 6592!------------------------------------------------------------------------------ 6593 6594 6595!------------------------------------------------------------------------------ 6596 END SUBROUTINE SetDirichletBoundaries 6597!------------------------------------------------------------------------------ 6598 6599 6600 6601 6602 6603!> Prepare to set Dirichlet conditions for attachment DOFs in the case of 6604!> component mode synthesis 6605!------------------------------------------------------------------------------ 6606 SUBROUTINE SetConstraintModesBoundaries( Model, A, b, & 6607 Name, NDOFs, Perm ) 6608 !------------------------------------------------------------------------------ 6609 TYPE(Model_t) :: Model !< The current model structure 6610 TYPE(Matrix_t), POINTER :: A !< The global matrix 6611 REAL(KIND=dp) :: b(:) !< The global RHS vector 6612 CHARACTER(LEN=*) :: Name !< name of the dof to be set 6613 INTEGER :: NDOFs !< the total number of DOFs for this equation 6614 INTEGER, TARGET :: Perm(:) !< The node reordering info, this has been generated at the 6615 !< beginning of the simulation for bandwidth optimization 6616!------------------------------------------------------------------------------ 6617 INTEGER :: i,t,u,j,k,k2,l,l2,n,bc_id,nlen,NormalInd 6618 LOGICAL :: Found 6619 TYPE(ValueList_t), POINTER :: BC 6620 TYPE(Mesh_t), POINTER :: Mesh 6621 TYPE(Solver_t), POINTER :: Solver 6622 TYPE(Element_t), POINTER :: Element 6623 TYPE(Variable_t), POINTER :: Var 6624 INTEGER, POINTER :: NodeIndexes(:) 6625 INTEGER, ALLOCATABLE :: BCPerm(:) 6626 6627!------------------------------------------------------------------------------ 6628 6629 nlen = LEN_TRIM(Name) 6630 Mesh => Model % Mesh 6631 Solver => Model % Solver 6632 Var => Solver % Variable 6633 6634 ! This needs to be allocated only once, hence return if already set 6635 IF( Var % NumberOfConstraintModes > 0 ) RETURN 6636 6637 CALL Info('SetConstraintModesBoundaries','Setting constraint modes boundaries for variable: '& 6638 //TRIM(Name),Level=7) 6639 6640 ! Allocate the indeces for the constraint modes 6641 ALLOCATE( Var % ConstraintModesIndeces( A % NumberOfRows ) ) 6642 Var % ConstraintModesIndeces = 0 6643 6644 ALLOCATE( BCPerm( Model % NumberOfBCs ) ) 6645 BCPerm = 0 6646 6647 j = 0 6648 DO bc_id = 1,Model % NumberOfBCs 6649 BC => Model % BCs(bc_id) % Values 6650 k = ListGetInteger( BC,& 6651 'Constraint Mode '// Name(1:nlen), Found ) 6652 IF( Found ) THEN 6653 IF( k == 0 ) k = -1 ! Ground gets negative value 6654 BCPerm(bc_id) = k 6655 ELSE IF( ListGetLogical( BC,& 6656 'Constraint Modes ' // Name(1:nlen), Found ) ) THEN 6657 j = j + 1 6658 BCPerm(bc_id) = j 6659 END IF 6660 END DO 6661 6662 j = MAXVAL( BCPerm ) 6663 CALL Info('SetConstraintModesBoundaries','Number of active constraint modes boundaries: '& 6664 //TRIM(I2S(j)),Level=7) 6665 IF( j == 0 ) THEN 6666 CALL Fatal('SetConstraintModesBoundaries',& 6667 'Constraint Modes Analysis requested but no constrained BCs given!') 6668 END IF 6669 6670 Var % NumberOfConstraintModes = NDOFS * j 6671 6672 6673 DO t = Mesh % NumberOfBulkElements+1, & 6674 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 6675 Element => Mesh % Elements(t) 6676 6677 DO bc_id = 1,Model % NumberOfBCs 6678 IF ( Element % BoundaryInfo % Constraint == Model % BCs(bc_id) % Tag ) EXIT 6679 END DO 6680 IF( bc_id > Model % NumberOfBCs ) CYCLE 6681 IF( BCPerm(bc_id) == 0 ) CYCLE 6682 6683 NodeIndexes => Element % NodeIndexes 6684 6685 ! For vector valued problems treat each component as separate dof 6686 DO k=1,NDOFs 6687 Var % ConstraintModesIndeces( NDOFS*(Perm(NodeIndexes)-1)+k) = NDOFS*(BCPerm(bc_id)-1)+k 6688 END DO 6689 END DO 6690 6691 ! The constraint modes can be either lumped or not. 6692 ! If they are not lumped then mark each individually 6693 IF( .NOT. ListGetLogical(Solver % Values,'Constraint Modes Lumped',Found ) ) THEN 6694 j = 0 6695 DO i=1,A % NumberOfRows 6696 IF( Var % ConstraintModesIndeces(i) > 0 ) THEN 6697 j = j + 1 6698 Var % ConstraintModesIndeces(i) = j 6699 END IF 6700 END DO 6701 CALL Info('SetConstraintModesBoundaries','Number of active constraint modes: '& 6702 //TRIM(I2S(j)),Level=7) 6703 Var % NumberOfConstraintModes = j 6704 END IF 6705 6706 6707 ! Manipulate the boundaries such that we need to modify only the r.h.s. in the actual linear solver 6708 DO k=1,A % NumberOfRows 6709 IF( Var % ConstraintModesIndeces(k) == 0 ) CYCLE 6710 A % ConstrainedDOF(k) = .TRUE. 6711 A % DValues(k) = 0.0_dp 6712 END DO 6713 6714 ALLOCATE( Var % ConstraintModes( Var % NumberOfConstraintModes, A % NumberOfRows ) ) 6715 Var % ConstraintModes = 0.0_dp 6716 6717 DEALLOCATE( BCPerm ) 6718 6719 CALL Info('SetConstraintModesBoundaries','All done',Level=10) 6720 6721!------------------------------------------------------------------------------ 6722 END SUBROUTINE SetConstraintModesBoundaries 6723!------------------------------------------------------------------------------ 6724 6725 6726 6727 6728!------------------------------------------------------------------------------ 6729!> Sets just one Dirichlet point in contrast to setting the whole field. 6730!> This is a lower order routine that the previous one. 6731!------------------------------------------------------------------------------ 6732 SUBROUTINE SetDirichletPoint( A, b,DOF, NDOFs, Perm, NodeIndex, NodeValue) 6733!------------------------------------------------------------------------------ 6734 IMPLICIT NONE 6735 TYPE(Matrix_t), POINTER :: A 6736 REAL(KIND=dp) :: b(:) 6737 REAL(KIND=dp) :: NodeValue 6738 INTEGER :: DOF, NDOFs, Perm(:), NodeIndex 6739!------------------------------------------------------------------------------ 6740 6741 REAL(KIND=dp) :: s 6742 INTEGER :: PermIndex 6743 6744!------------------------------------------------------------------------------ 6745 PermIndex = Perm(NodeIndex) 6746 IF ( PermIndex > 0 ) THEN 6747 PermIndex = NDOFs * (PermIndex-1) + DOF 6748 A % ConstrainedDOF(PermIndex) = .TRUE. 6749 A % DValues(PermIndex) = NodeValue 6750 END IF 6751!------------------------------------------------------------------------------ 6752 END SUBROUTINE SetDirichletPoint 6753!------------------------------------------------------------------------------ 6754 6755 6756!------------------------------------------------------------------------------ 6757!> Set distributed loads to vector b. 6758!------------------------------------------------------------------------------ 6759 SUBROUTINE SetNodalSources( Model, Mesh, SourceName, dofs, Perm, GotSrc, SrcVec ) 6760!------------------------------------------------------------------------------ 6761 TYPE(Model_t), POINTER :: Model !< The current model structure 6762 TYPE(Mesh_t), POINTER :: Mesh !< The current mesh structure 6763 CHARACTER(LEN=*) :: SourceName !< Name of the keyword setting the source term 6764 INTEGER :: DOFs !< The total number of DOFs for this equation 6765 INTEGER :: Perm(:) !< The node reordering info 6766 LOGICAL :: GotSrc !< Did we get something? 6767 REAL(KIND=dp) :: SrcVec(:) !< The assemblied source vector 6768!------------------------------------------------------------------------------ 6769 TYPE(Element_t), POINTER :: Element 6770 INTEGER :: i,t,n,bc,bf,FirstElem,LastElem,nlen 6771 LOGICAL :: Found,AnyBC,AnyBF,Axisymmetric 6772 REAL(KIND=dp) :: Coeff 6773 REAL(KIND=dp), ALLOCATABLE :: FORCE(:,:) 6774 LOGICAL, ALLOCATABLE :: ActiveBC(:), ActiveBF(:) 6775 TYPE(ValueList_t), POINTER :: ValueList 6776 INTEGER, POINTER :: Indexes(:) 6777 CHARACTER(*), PARAMETER :: Caller = 'SetNodalSources' 6778 6779 nlen = LEN_TRIM(SourceName) 6780 6781 CALL Info(Caller,'Checking for generalized source terms: '& 6782 //SourceName(1:nlen),Level=15) 6783 6784 ALLOCATE( ActiveBC(Model % NumberOfBCs ), & 6785 ActiveBF(Model % NumberOfBodyForces) ) 6786 6787 ! First make a quick test going through the short boundary condition and 6788 ! body force lists. 6789 ActiveBC = .FALSE. 6790 DO BC=1,Model % NumberOfBCs 6791 IF(.NOT. ListCheckPresent( Model % BCs(BC) % Values,'Target Boundaries')) CYCLE 6792 ActiveBC(BC) = ListCheckPrefix( Model % BCs(BC) % Values, SourceName(1:nlen) ) 6793 END DO 6794 6795 ActiveBF = .FALSE. 6796 DO bf=1,Model % NumberOFBodyForces 6797 ActiveBF(bf) = ListCheckPrefix( Model % BodyForces(bf) % Values, SourceName(1:nlen) ) 6798 END DO 6799 6800 AnyBC = ANY(ActiveBC) 6801 AnyBF = ANY(ActiveBF) 6802 6803 GotSrc = (AnyBC .OR. AnyBF) 6804 IF(.NOT. GotSrc ) RETURN 6805 6806 CALL Info(Caller,'Assembling generalized source terms: '& 6807 //SourceName(1:nlen),Level=10) 6808 6809 6810 AxiSymmetric = ( CurrentCoordinateSystem() /= Cartesian ) 6811 6812 ! Only loop over BCs and BFs if needed. Here determine the loop. 6813 FirstElem = HUGE( FirstElem ) 6814 LastElem = 0 6815 IF(AnyBC) THEN 6816 FirstElem = Mesh % NumberOfBulkElements + 1 6817 LastElem = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 6818 END IF 6819 IF(AnyBF) THEN 6820 FirstElem = 1 6821 LastElem = MAX( LastElem, Mesh % NumberOfBulkElements ) 6822 END IF 6823 6824 n = Mesh % MaxElementNodes 6825 ALLOCATE( FORCE(dofs,n) ) 6826 FORCE = 0.0_dp 6827 6828 ! Here do the actual assembly loop. 6829 DO t=FirstElem, LastElem 6830 Element => Mesh % Elements(t) 6831 Indexes => Element % NodeIndexes 6832 6833 IF( t > Mesh % NumberOfBulkElements ) THEN 6834 Found = .FALSE. 6835 DO BC=1,Model % NumberOfBCs 6836 IF( .NOT. ActiveBC(BC) ) CYCLE 6837 IF ( Element % BoundaryInfo % Constraint == Model % BCs(BC) % Tag ) THEN 6838 Found = .TRUE. 6839 EXIT 6840 END IF 6841 END DO 6842 IF(.NOT. Found) CYCLE 6843 ValueList => Model % BCs(BC) % Values 6844 ELSE 6845 bf = ListGetInteger( Model % Bodies(Element % BodyId) % Values,'Body Force',Found) 6846 IF(.NOT. Found) CYCLE 6847 IF(.NOT. ActiveBF(bf) ) CYCLE 6848 ValueList => Model % BodyForces(bf) % Values 6849 END IF 6850 6851 ! In parallel we may have halos etc. By default scaling is one. 6852 Coeff = ParallelScalingFactor() 6853 IF(ABS(Coeff) < TINY(Coeff)) CYCLE 6854 6855 CALL LocalSourceAssembly(Element, dofs, FORCE ) 6856 6857 DO i=1,dofs 6858 SrcVec(dofs*(Perm(Indexes)-1)+i) = SrcVec(dofs*(Perm(Indexes)-1)+i) + & 6859 Coeff * FORCE(i,1:n) 6860 END DO 6861 END DO 6862 6863 6864 CONTAINS 6865 6866!------------------------------------------------------------------------------ 6867 FUNCTION ParallelScalingFactor() RESULT ( Coeff ) 6868!------------------------------------------------------------------------------ 6869 REAL(KIND=dp) :: Coeff 6870 TYPE(Element_t), POINTER :: P1, P2 6871 6872 ! Default weight 6873 Coeff = 1.0_dp 6874 6875 IF ( ParEnv % PEs > 1 ) THEN 6876 IF ( ASSOCIATED(Element % BoundaryInfo) ) THEN 6877 P1 => Element % BoundaryInfo % Left 6878 P2 => Element % BoundaryInfo % Right 6879 IF ( ASSOCIATED(P1) .AND. ASSOCIATED(P2) ) THEN 6880 IF ( P1 % PartIndex /= ParEnv % myPE .AND. & 6881 P2 % PartIndex /= ParEnv % myPE ) THEN 6882 Coeff = 0.0_dp 6883 ELSE IF ( P1 % PartIndex /= ParEnv % myPE .OR. & 6884 P2 % PartIndex /= ParEnv % myPE ) THEN 6885 Coeff = 0.5_dp 6886 END IF 6887 ELSE IF ( ASSOCIATED(P1) ) THEN 6888 IF ( P1 % PartIndex /= ParEnv % myPE ) Coeff = 0.0_dp 6889 ELSE IF ( ASSOCIATED(P2) ) THEN 6890 IF ( P2 % PartIndex /= ParEnv % myPE ) Coeff = 0.0_dp 6891 END IF 6892 ELSE IF ( Element % PartIndex/=ParEnv % myPE ) THEN 6893 Coeff = 0.0_dp 6894 END IF 6895 END IF 6896 6897 END FUNCTION ParallelScalingFactor 6898!------------------------------------------------------------------------------ 6899 6900 6901!------------------------------------------------------------------------------ 6902 SUBROUTINE LocalSourceAssembly(Element, dofs, FORCE) 6903!------------------------------------------------------------------------------ 6904 IMPLICIT NONE 6905 INTEGER, INTENT(IN) :: dofs 6906 TYPE(Element_t), POINTER :: Element 6907 REAL(KIND=dp) :: FORCE(:,:) 6908!------------------------------------------------------------------------------ 6909 REAL(KIND=dp), ALLOCATABLE :: Basis(:),ElemSource(:,:) 6910 REAL(KIND=dp) :: weight, SourceAtIp, DetJ 6911 INTEGER, POINTER :: Indexes(:) 6912 LOGICAL :: Stat,Found 6913 INTEGER :: i,j,t,m,n,allocstat 6914 TYPE(GaussIntegrationPoints_t) :: IP 6915 TYPE(Nodes_t) :: Nodes 6916 6917 SAVE Nodes,Basis,ElemSource 6918!------------------------------------------------------------------------------ 6919 6920 ! Allocate storage if needed 6921 IF (.NOT. ALLOCATED(Basis)) THEN 6922 m = Mesh % MaxElementNodes 6923 ALLOCATE(ElemSource(dofs,m), Basis(m), Nodes % x(m), & 6924 Nodes % y(m), Nodes % z(m), STAT=allocstat) 6925 IF (allocstat /= 0) THEN 6926 CALL Fatal(Caller,'Local storage allocation failed in LocalMatrix') 6927 END IF 6928 END IF 6929 6930 IP = GaussPoints( Element, PReferenceElement = .FALSE.) 6931 Indexes => Element % NodeIndexes 6932 n = Element % Type % NumberOfNodes 6933 6934 Nodes % x(1:n) = Mesh % Nodes % x(Indexes) 6935 Nodes % y(1:n) = Mesh % Nodes % y(Indexes) 6936 Nodes % z(1:n) = Mesh % Nodes % z(Indexes) 6937 6938 FORCE = 0._dp 6939 6940 IF( dofs == 1 ) THEN 6941 ElemSource(1,1:n) = ListGetReal( ValueList,SourceName(1:nlen), n, Indexes ) 6942 ELSE 6943 j = 0 6944 DO i=1,dofs 6945 ElemSource(i,1:n) = ListGetReal( ValueList,& 6946 SourceName(1:nlen)//' '//TRIM(I2S(i)), n, Indexes, Found ) 6947 IF( Found ) j = j + 1 6948 END DO 6949 IF( j == 0 ) CALL Fatal(Caller,'Could not find for any component: '//SourceName(1:nlen) ) 6950 END IF 6951 6952 DO t=1,IP % n 6953 ! Basis function at the integration point: 6954 !----------------------------------------- 6955 stat = ElementInfo( Element, Nodes, & 6956 IP % U(t), IP % V(t), IP % W(t), detJ, Basis ) 6957 Weight = IP % s(t) * DetJ 6958 6959 IF ( AxiSymmetric ) THEN 6960 Weight = Weight * SUM( Nodes % x(1:n) * Basis(1:n) ) 6961 END IF 6962 6963 DO i=1,dofs 6964 SourceAtIP = SUM( ElemSource(i,1:n) * Basis(1:n) ) 6965 FORCE(i,1:n) = FORCE(i,1:n) + & 6966 Weight * Basis(1:n) * SourceAtIp 6967 END DO 6968 END DO 6969 6970 END SUBROUTINE LocalSourceAssembly 6971 6972!------------------------------------------------------------------------------ 6973END SUBROUTINE SetNodalSources 6974!------------------------------------------------------------------------------ 6975 6976 6977 6978!------------------------------------------------------------------------------ 6979!> Sets nodal loads directly to the matrix structure. 6980!> The intended use for this is, for example, in multiphysics coupling where 6981!> the nodal loads may have been computed by another solver. 6982!------------------------------------------------------------------------------ 6983 SUBROUTINE SetNodalLoads( Model, A, b, Name, DOF, NDOFs, Perm ) 6984!------------------------------------------------------------------------------ 6985 TYPE(Model_t) :: Model !< The current model structure 6986 TYPE(Matrix_t), POINTER :: A !< The global matrix 6987 REAL(KIND=dp) :: b(:) !< The global RHS vector 6988 CHARACTER(LEN=*) :: Name !< Name of the dof to be set 6989 INTEGER :: DOF !< The order number of the dof 6990 INTEGER :: NDOFs !< The total number of DOFs for this equation 6991 INTEGER :: Perm(:) !< The node reordering info, this has been generated at the 6992 !< beginning of the simulation for bandwidth optimization. 6993!------------------------------------------------------------------------------ 6994 6995 TYPE(Element_t), POINTER :: Element 6996 INTEGER, ALLOCATABLE :: Indexes(:) 6997 INTEGER, POINTER :: NodeIndexes(:), Neigh(:) 6998 INTEGER :: BC,i,j,k,l,n,t,k1,k2 6999 LOGICAL :: GotIt 7000 REAL(KIND=dp), POINTER :: WorkA(:,:,:) => NULL() 7001 REAL(KIND=dp) :: s 7002 7003 LOGICAL :: Conditional 7004 CHARACTER(LEN=MAX_NAME_LEN) :: LoadName 7005 7006 INTEGER, POINTER :: IndNodes(:) 7007 INTEGER :: NoNodes,NoDims,bf_id,nlen,NOFNodesFound 7008 REAL(KIND=dp), POINTER :: CoordNodes(:,:), DiagScaling(:),MinDist(:) 7009 REAL(KIND=dp) :: GlobalMinDist,Dist,Eps 7010 LOGICAL, ALLOCATABLE :: ActivePart(:), ActivePartAll(:), DoneLoad(:) 7011 LOGICAL :: NodesFound 7012 TYPE(ValueList_t), POINTER :: ValueList 7013 7014 LoadName = TRIM(Name) // ' Load' 7015 nlen = LEN_TRIM(LoadName) 7016 7017 CALL Info('SetNodalLoads','Checking for nodal loads for variable: '//TRIM(Name),Level=12) 7018 7019 n = MAX(Model % NumberOfBCs, Model % NumberOFBodyForces) 7020 ALLOCATE( ActivePart(n), ActivePartAll(n) ) 7021 7022 ALLOCATE( Indexes(Model % Solver % Mesh % MaxElementDOFs) ) 7023!------------------------------------------------------------------------------ 7024! Go through the boundaries 7025!------------------------------------------------------------------------------ 7026 7027 ActivePart = .FALSE. 7028 ActivePartAll = .FALSE. 7029 DO BC=1,Model % NumberOfBCs 7030 IF(.NOT. ListCheckPresent( Model % BCs(BC) % Values,'Target Boundaries')) CYCLE 7031 ActivePart(BC) = ListCheckPresent( Model % BCs(BC) % Values, LoadName ) 7032 ActivePartAll(BC) = ListCheckPresent( & 7033 Model % BCs(BC) % Values, LoadName(1:nlen) // ' DOFs' ) 7034 END DO 7035 7036 IF ( ANY(ActivePart) .OR. ANY(ActivePartAll) ) THEN 7037 CALL Info('SetNodalLoads','Setting nodal loads on boundaries: '//TRIM(LoadName),Level=9) 7038 ALLOCATE(DoneLoad( SIZE(b)/NDOFs) ) 7039 DoneLoad = .FALSE. 7040 7041 DO BC=1,Model % NumberOfBCs 7042 IF(.NOT. ActivePart(BC) .AND. .NOT. ActivePartAll(BC) ) CYCLE 7043 7044 DO t = Model % NumberOfBulkElements + 1, & 7045 Model % NumberOfBulkElements + Model % NumberOfBoundaryElements 7046 7047 Element => Model % Elements(t) 7048 IF ( Element % BoundaryInfo % Constraint /= Model % BCs(BC) % Tag ) CYCLE 7049 7050 Model % CurrentElement => Element 7051 IF ( ActivePart(BC) ) THEN 7052 n = Element % TYPE % NumberOfNodes 7053 Indexes(1:n) = Element % NodeIndexes 7054 ELSE 7055 n = SgetElementDOFs( Indexes ) 7056 END IF 7057 ValueList => Model % BCs(BC) % Values 7058 7059 CALL SetElementLoads( n ) 7060 END DO 7061 END DO 7062 END IF 7063 7064!------------------------------------------------------------------------------ 7065! Go through the nodal load conditions for the body force list 7066!------------------------------------------------------------------------------ 7067 7068 ActivePart = .FALSE. 7069 ActivePartAll = .FALSE. 7070 DO bf_id=1,Model % NumberOFBodyForces 7071 ActivePart(bf_id) = ListCheckPresent( Model % BodyForces(bf_id) % Values, LoadName ) 7072 ActivePartAll(bf_id) = ListCheckPresent( & 7073 Model % BodyForces(bf_id) % Values, LoadName(1:nlen) // ' DOFs' ) 7074 END DO 7075 7076 IF ( ANY( ActivePart ) .OR. ANY(ActivePartAll) ) THEN 7077 CALL Info('SetNodalLoads','Setting nodal loads on body force: '//TRIM(LoadName),Level=9) 7078 IF(.NOT. ALLOCATED(DoneLoad)) ALLOCATE(DoneLoad( SIZE(b)/NDOFs) ) 7079 DoneLoad = .FALSE. 7080 7081 DO t = 1, Model % NumberOfBulkElements 7082 Element => Model % Elements(t) 7083 bf_id = ListGetInteger( Model % Bodies(Element % BodyId) % Values,'Body Force', GotIt) 7084 7085 IF(.NOT. GotIt) CYCLE 7086 IF(.NOT. ActivePart(bf_id) .AND. .NOT. ActivePartAll(bf_id) ) CYCLE 7087 7088 Model % CurrentElement => Element 7089 IF ( ActivePart(bf_id) ) THEN 7090 n = Element % TYPE % NumberOfNodes 7091 Indexes(1:n) = Element % NodeIndexes 7092 ELSE 7093 n = SgetElementDOFs( Indexes ) 7094 END IF 7095 ValueList => Model % BodyForces(bf_id) % Values 7096 7097 CALL SetElementLoads( n ) 7098 END DO 7099 END IF 7100 7101 DEALLOCATE(ActivePart) 7102 IF(ALLOCATED(DoneLoad)) DEALLOCATE(DoneLoad) 7103 7104 7105!------------------------------------------------------------------------------ 7106! Go through the point loads that are created on-the-fly 7107!------------------------------------------------------------------------------ 7108 7109 DO BC=1,Model % NumberOfBCs 7110 ValueList => Model % BCs(BC) % Values 7111 IF( .NOT. ListCheckPresent( ValueList,LoadName )) CYCLE 7112 NodesFound = ListCheckPresent(ValueList,'Target Nodes') 7113 7114 ! At the first calling the list of coordinates is transformed to list of nodes. 7115 IF(.NOT. NodesFound) THEN 7116 CoordNodes => ListGetConstRealArray(ValueList, 'Target Coordinates',GotIt) 7117 IF(GotIt) THEN 7118 Eps = ListGetConstReal( ValueList, 'Target Coordinates Eps', Gotit ) 7119 IF ( .NOT. GotIt ) THEN 7120 Eps = HUGE(Eps) 7121 ELSE 7122 ! We are looking at square of distance 7123 Eps = Eps**2 7124 END IF 7125 7126 NoNodes = SIZE(CoordNodes,1) 7127 NoDims = SIZE(CoordNodes,2) 7128 7129 IF(NoNodes > 0) THEN 7130 ALLOCATE( IndNodes(NoNodes), MinDist(NoNodes) ) 7131 IndNodes = -1 7132 MinDist = HUGE( Dist ) 7133 DO j=1,NoNodes 7134 DO i=1,Model % NumberOfNodes 7135 IF( Perm(i) == 0) CYCLE 7136 7137 Dist = (Model % Mesh % Nodes % x(i) - CoordNodes(j,1))**2 7138 IF(NoDims >= 2) Dist = Dist + (Model % Mesh % Nodes % y(i) - CoordNodes(j,2))**2 7139 IF(NoDims == 3) Dist = Dist + (Model % Mesh % Nodes % z(i) - CoordNodes(j,3))**2 7140 Dist = SQRT(Dist) 7141 7142 IF(Dist < MinDist(j) .AND. Dist <= Eps ) THEN 7143 MinDist(j) = Dist 7144 IndNodes(j) = i 7145 END IF 7146 END DO 7147 END DO 7148 7149 IF( InfoActive( 20 ) ) THEN 7150 DO j=1,NoNodes 7151 i = IndNodes(j) 7152 IF(i<1) CYCLE 7153 PRINT *,'Nearest node is:',i,MinDist(j) 7154 PRINT *,'Target Coordinates:',CoordNodes(j,:) 7155 PRINT *,'Nearest coordinates:',Model % Mesh % Nodes % x(i),& 7156 Model % Mesh % Nodes % y(i), Model % Mesh % Nodes % z(i) 7157 END DO 7158 END IF 7159 7160 ! In parallel case eliminate all except the nearest node. 7161 ! This relies on the fact that for each node partition the 7162 ! distance to nearest node is computed accurately. 7163 DO j=1,NoNodes 7164 GlobalMinDist = ParallelReduction( MinDist(j), 1 ) 7165 IF(ABS(GlobalMinDist - MinDist(j) )>TINY(Dist)) THEN 7166 IndNodes(j) = 0 7167 ELSE IF(ParEnv % PEs>1) THEN 7168 ! In parallel apply load only on the owner partition: 7169 ! --------------------------------------------------- 7170 neigh=>Model % Mesh % ParallelInfo % NeighbourList(IndNodes(j)) % Neighbours 7171 DO i=1,SIZE(Neigh) 7172 IF(ParEnv % Active(neigh(i))) EXIT 7173 END DO 7174 IF(neigh(i)/=ParEnv % MyPE) IndNodes(j) = 0 7175 END IF 7176 END DO 7177 7178 NOFNodesFound = 0 7179 DO j=1,NoNodes 7180 IF ( IndNodes(j)>0 ) THEN 7181 NOFNodesFound = NOFNodesFound+1 7182 IndNodes(NOFNodesFound) = IndNodes(j) 7183 END IF 7184 END DO 7185 7186 ! In the first time add the found nodes to the list structure 7187 IF ( NOFNodesFound > 0 ) THEN 7188 DO i=1,NOFNodesFound 7189 CALL Info('SetNodalLoads','Target Nodes('//TRIM(I2S(i))//& 7190 ') = '//TRIM(I2S(IndNodes(i))),Level=7) 7191 END DO 7192 CALL ListAddIntegerArray( ValueList,'Target Nodes', & 7193 NOFNodesFound, IndNodes) 7194 NodesFound = .TRUE. 7195 ELSE 7196 ! If no nodes found, add still an empty list and make sure the 7197 ! zero is not treated later on. Otherwise this search would be 7198 ! retreated each time. 7199 CALL ListAddIntegerArray( ValueList,'Target Nodes', 0, IndNodes) 7200 END IF 7201 7202 ! Finally deallocate the temporal vectors 7203 DEALLOCATE( IndNodes, MinDist ) 7204 END IF 7205 END IF 7206 END IF 7207 7208 IF(NodesFound) THEN 7209 CALL Info('SetNodalLoads','Setting nodal loads on target nodes: '//TRIM(Name),Level=9) 7210 NodeIndexes => ListGetIntegerArray( ValueList,'Target Nodes') 7211 n = SIZE(NodeIndexes) 7212 CALL SetPointLoads(n) 7213 END IF 7214 7215 END DO 7216 7217 DEALLOCATE( Indexes ) 7218 7219 CALL Info('SetNodalLoads','Finished checking for nodal loads',Level=12) 7220 7221 7222CONTAINS 7223 7224 SUBROUTINE SetElementLoads(n) 7225 INTEGER :: n 7226 REAL(KIND=dp) :: Work(n) 7227 7228 NodeIndexes => Element % NodeIndexes(1:n) 7229 7230 IF ( DOF > 0 ) THEN 7231 Work(1:n) = ListGetReal( ValueList, LoadName, n, Indexes, gotIt ) 7232 IF ( .NOT. Gotit ) THEN 7233 Work(1:n) = ListGetReal( ValueList, LoadName(1:nlen) // ' DOFs', n, Indexes, gotIt ) 7234 END IF 7235 ELSE 7236 CALL ListGetRealArray( ValueList, LoadName, WorkA, n, Indexes, gotIt ) 7237 END IF 7238 7239 IF ( gotIt ) THEN 7240 7241 DO j=1,n 7242 k = Perm(Indexes(j)) 7243 7244 IF ( k > 0 ) THEN 7245 IF ( DoneLoad(k) ) CYCLE 7246 DoneLoad(k) = .TRUE. 7247 7248 IF ( DOF>0 ) THEN 7249 k = NDOFs * (k-1) + DOF 7250 IF( ParEnv % Pes > 1 ) THEN 7251 IF( A % ParallelInfo % NeighbourList(k) % Neighbours(1) /= ParEnv % MyPe ) CYCLE 7252 END IF 7253 b(k) = b(k) + Work(j) 7254 ELSE 7255 DO l=1,MIN( NDOFs, SIZE(Worka,1) ) 7256 k1 = NDOFs * (k-1) + l 7257 b(k1) = b(k1) + WorkA(l,1,j) 7258 END DO 7259 END IF 7260 END IF 7261 END DO 7262 END IF 7263 7264 END SUBROUTINE SetElementLoads 7265 7266 7267 SUBROUTINE SetPointLoads(n) 7268 INTEGER :: n 7269 REAL(KIND=dp) :: Work(n) 7270 LOGICAL :: ImaginaryLoads 7271 CHARACTER(LEN=MAX_NAME_LEN) :: LoadNameIm 7272 7273 IF(n<=0) RETURN 7274 ImaginaryLoads = ASSOCIATED(A % RHS_im) 7275 7276 IF ( DOF > 0 ) THEN 7277 Work(1:n) = ListGetReal( ValueList, LoadName, n, NodeIndexes, gotIt ) 7278 ELSE 7279 CALL ListGetRealArray( ValueList, LoadName, WorkA, n, NodeIndexes, gotIt ) 7280 END IF 7281 7282 IF ( GotIt ) THEN 7283 DO j=1,n 7284 IF ( NodeIndexes(j) > SIZE(Perm) .OR. NodeIndexes(j) < 1 ) THEN 7285 CALL Warn('SetPointLoads','Invalid Node Number') 7286 CYCLE 7287 END IF 7288 7289 k = Perm(NodeIndexes(j)) 7290 IF ( k > 0 ) THEN 7291 IF ( DOF>0 ) THEN 7292 k = NDOFs * (k-1) + DOF 7293 b(k) = b(k) + Work(j) 7294 ELSE 7295 DO l=1,MIN( NDOFs, SIZE(WorkA,1) ) 7296 k1 = NDOFs * (k-1) + l 7297 b(k1) = b(k1) + WorkA(l,1,j) 7298 END DO 7299 END IF 7300 END IF 7301 END DO 7302 END IF 7303 7304 IF (ImaginaryLoads) THEN 7305 IF (DOF > 0) THEN 7306 Work(1:n) = ListGetReal(ValueList, LoadName(1:nlen) // ' im', n, NodeIndexes, gotIt) 7307 ELSE 7308 CALL ListGetRealArray(ValueList, LoadName(1:nlen) // ' im', WorkA, n, NodeIndexes, gotIt) 7309 END IF 7310 7311 IF (GotIt) THEN 7312 DO j=1,n 7313 IF ( NodeIndexes(j) > SIZE(Perm) .OR. NodeIndexes(j) < 1 ) THEN 7314 CALL Warn('SetPointLoads','Invalid Node Number') 7315 CYCLE 7316 END IF 7317 7318 k = Perm(NodeIndexes(j)) 7319 IF ( k > 0 ) THEN 7320 IF (DOF > 0) THEN 7321 k = NDOFs * (k-1) + DOF 7322 A % RHS_im(k) = A % RHS_im(k) + Work(j) 7323 ELSE 7324 DO l=1,MIN( NDOFs, SIZE(WorkA,1) ) 7325 k1 = NDOFs * (k-1) + l 7326 A % RHS_im(k1) = A % RHS_im(k1) + WorkA(l,1,j) 7327 END DO 7328 END IF 7329 END IF 7330 END DO 7331 END IF 7332 END IF 7333 7334 END SUBROUTINE SetPointLoads 7335 7336!------------------------------------------------------------------------------ 7337 END SUBROUTINE SetNodalLoads 7338!------------------------------------------------------------------------------ 7339 7340 7341!------------------------------------------------------------------------------ 7342!> This subroutine seeks for nodes which are adjacent to the given target node 7343!> and then creates a couple which corresponds to a given torque. If the 7344!> optional definition of the director vector d is given, the torque arm should 7345!> ideally be parallel to d and the couple created does not have a d-component. 7346!> This version may be more convenient when the torque comes from a dimensionally 7347!> reduced model over a thin body. Without specifying the director, this 7348!> subroutine expects a 3-D geometry. 7349! 7350! TO DO: - The target nodes can now be defined only by their indices 7351! - Add a way to find the director from the specification of a shell model. 7352!------------------------------------------------------------------------------ 7353 SUBROUTINE SetCoupleLoads(Model, Perm, A, F, Dofs) 7354!------------------------------------------------------------------------------ 7355 IMPLICIT NONE 7356 TYPE(Model_t) :: Model !< The current model structure 7357 INTEGER, POINTER, INTENT(IN) :: Perm(:) !< The permutation of the associated variable 7358 TYPE(Matrix_t), INTENT(INOUT) :: A !< The coefficient matrix of the problem 7359 REAL(KIND=dp), POINTER, INTENT(INOUT) :: F(:) !< The RHS vector of the problem 7360 INTEGER, INTENT(IN) :: Dofs !< The DOF count of the associated variable 7361!------------------------------------------------------------------------------ 7362 TYPE(Mesh_t), POINTER :: Mesh 7363 TYPE(ValueList_t), POINTER :: ValueList 7364 7365 LOGICAL :: WithDirector 7366 LOGICAL :: Found, NoUpperNode, NoLowerNode 7367 7368 INTEGER, ALLOCATABLE :: NearNodes(:) 7369 INTEGER, POINTER :: NodeIndexes(:) 7370 INTEGER, POINTER :: Cols(:), Rows(:), Diag(:) 7371 INTEGER :: Row, TargetNode, TargetInd, BC, TargetCount 7372 INTEGER :: i, j, k, l, n, p 7373 INTEGER :: jx, lx, jy, ly, jz, lz 7374 INTEGER :: intarray(1) 7375 7376 REAL(KIND=dp), ALLOCATABLE :: NearCoordinates(:,:), AllDirectors(:,:), Work(:,:) 7377 REAL(KIND=dp) :: E(3,3) 7378 REAL(KIND=dp) :: Torque(3) ! The torque vector with respect to the global frame 7379 REAL(KIND=dp) :: d(3) ! Director at a solid-shell/plate interface 7380 REAL(KIND=dp) :: ex(3), ey(3), ez(3) 7381 REAL(KIND=dp) :: e1(3), e2(3), e3(3) 7382 REAL(KIND=dp) :: T(3), Force(3), v(3) 7383 REAL(KIND=dp) :: M1, M2, F1, F2, F3 7384 REAL(KIND=dp) :: res_x, maxres_x, minres_x 7385 REAL(KIND=dp) :: res_y, maxres_y, minres_y 7386 REAL(KIND=dp) :: res_z, maxres_z, minres_z 7387 REAL(KIND=dp) :: rlower, rupper, FVal, MVal 7388!------------------------------------------------------------------------------ 7389 IF (.NOT. ListCheckPrefixAnyBC(Model, 'Torque')) RETURN 7390 7391 Mesh => Model % Solver % Mesh 7392 7393 IF (.NOT. ASSOCIATED(A % InvPerm)) THEN 7394 ALLOCATE(A % InvPerm(A % NumberOfRows)) 7395 DO i = 1,SIZE(Perm) 7396 IF (Perm(i) > 0) THEN 7397 A % InvPerm(Perm(i)) = i 7398 END IF 7399 END DO 7400 END IF 7401 7402 ex = [1.0d0, 0.0d0, 0.0d0] 7403 ey = [0.0d0, 1.0d0, 0.0d0] 7404 ez = [0.0d0, 0.0d0, 1.0d0] 7405 E(:,1) = ex 7406 E(:,2) = ey 7407 E(:,3) = ez 7408 7409 Diag => A % Diag 7410 Rows => A % Rows 7411 Cols => A % Cols 7412 7413 DO BC=1,Model % NumberOfBCs 7414 ValueList => Model % BCs(BC) % Values 7415 IF (.NOT.ListCheckPresent(ValueList, 'Torque 1') .AND. & 7416 .NOT.ListCheckPresent(ValueList, 'Torque 2') .AND. & 7417 .NOT.ListCheckPresent(ValueList, 'Torque 3')) CYCLE 7418 NodeIndexes => ListGetIntegerArray(ValueList, 'Target Nodes', UnfoundFatal=.TRUE.) 7419 7420 TargetCount = SIZE(NodeIndexes) 7421 ALLOCATE(Work(3,TargetCount)) 7422 Work(1,1:TargetCount) = ListGetReal(ValueList, 'Torque 1', TargetCount, NodeIndexes, Found) 7423 Work(2,1:TargetCount) = ListGetReal(ValueList, 'Torque 2', TargetCount, NodeIndexes, Found) 7424 Work(3,1:TargetCount) = ListGetReal(ValueList, 'Torque 3', TargetCount, NodeIndexes, Found) 7425 7426 ! 7427 ! Check whether the torque arm is given by the director vector. This option 7428 ! is not finalized yet. Here the director definition is sought from the BC 7429 ! definition, while the director might already be available from the specification 7430 ! of a shell model. 7431 ! 7432 IF (.NOT.ListCheckPresent(ValueList, 'Director 1') .AND. & 7433 .NOT.ListCheckPresent(ValueList, 'Director 2') .AND. & 7434 .NOT.ListCheckPresent(ValueList, 'Director 3')) THEN 7435 WithDirector = .FALSE. 7436 ELSE 7437 WithDirector = .TRUE. 7438 ALLOCATE(AllDirectors(3,TargetCount)) 7439 AllDirectors(1,1:TargetCount) = ListGetReal(ValueList, 'Director 1', TargetCount, NodeIndexes, Found) 7440 AllDirectors(2,1:TargetCount) = ListGetReal(ValueList, 'Director 2', TargetCount, NodeIndexes, Found) 7441 AllDirectors(3,1:TargetCount) = ListGetReal(ValueList, 'Director 3', TargetCount, NodeIndexes, Found) 7442 END IF 7443 7444 DO p=1,TargetCount 7445 TargetNode = NodeIndexes(p) 7446 TargetInd = Perm(NodeIndexes(p)) 7447 IF (TargetInd == 0) CYCLE 7448 7449 !------------------------------------------------------------------------------ 7450 ! Find nodes which can potentially be used to make a representation of couple: 7451 !------------------------------------------------------------------------------ 7452 Row = TargetInd * Dofs 7453 n = (Rows(Row+1)-1 - Rows(Row)-Dofs+1)/DOFs + 1 7454 ALLOCATE(NearNodes(n), NearCoordinates(3,n)) 7455 7456 k = 0 7457 DO i = Rows(Row)+Dofs-1, Rows(Row+1)-1, Dofs 7458 j = Cols(i)/Dofs 7459 k = k + 1 7460 NearNodes(k) = A % InvPerm(j) 7461 END DO 7462 ! PRINT *, 'POTENTIAL NODE CONNECTIONS:' 7463 ! print *, 'Nodes near target=', NearNodes(1:k) 7464 7465 ! 7466 ! The position vectors for the potential nodes where forces may be applied: 7467 ! 7468 NearCoordinates(1,1:n) = Mesh % Nodes % x(NearNodes(1:n)) - Mesh % Nodes % x(TargetNode) 7469 NearCoordinates(2,1:n) = Mesh % Nodes % y(NearNodes(1:n)) - Mesh % Nodes % y(TargetNode) 7470 NearCoordinates(3,1:n) = Mesh % Nodes % z(NearNodes(1:n)) - Mesh % Nodes % z(TargetNode) 7471 7472 7473 IF (WithDirector) THEN 7474 ! 7475 ! In this case the torque arm should ideally be parallel to the director vector d. 7476 ! Construct an orthonormal basis, with d giving the third basis vector. 7477 ! 7478 d = AllDirectors(:,p) 7479 e3 = d/SQRT(DOT_PRODUCT(d,d)) 7480 v(1:3) = ABS([DOT_PRODUCT(ex,e3), DOT_PRODUCT(ey,e3), DOT_PRODUCT(ez,e3)]) 7481 intarray = MINLOC(v) 7482 k = intarray(1) 7483 v(1:3) = E(1:3,k) 7484 e1 = v - DOT_PRODUCT(v,e3)*e3 7485 e1 = e1/SQRT(DOT_PRODUCT(e1,e1)) 7486 e2 = CrossProduct(e3,e1) 7487 ! 7488 ! The torque is supposed to have no component in the direction of d, so remove it 7489 ! and also find the representation of the altered torque with respect to the local basis: 7490 ! 7491 Torque = Work(:,p) 7492 v = DOT_PRODUCT(Torque,e3)*e3 7493 T = Torque - v 7494 M1 = DOT_PRODUCT(T,e1) 7495 M2 = DOT_PRODUCT(T,e2) 7496 7497 !------------------------------------------------------------------------------ 7498 ! Seek torque arms which are closest to be parallel to d: 7499 !------------------------------------------------------------------------------ 7500 maxres_z = 0.0d0 7501 minres_z = 0.0d0 7502 jz = 0 7503 lz = 0 7504 DO i=1,n 7505 IF (NearNodes(i) == TargetNode) CYCLE 7506 res_z = DOT_PRODUCT(e3(:), NearCoordinates(:,i)) / & 7507 SQRT(DOT_PRODUCT(NearCoordinates(:,i), NearCoordinates(:,i))) 7508 IF (res_z > 0.0d0) THEN 7509 ! 7510 ! A near node is on +d side 7511 ! 7512 IF (res_z > maxres_z) THEN 7513 jz = NearNodes(i) 7514 maxres_z = res_z 7515 END IF 7516 ELSE 7517 ! 7518 ! A near node is on -d side 7519 ! 7520 IF (res_z < minres_z) THEN 7521 lz = NearNodes(i) 7522 minres_z = res_z 7523 END IF 7524 END IF 7525 END DO 7526 7527 ! 7528 ! Calculate arm lengths with respect to the coordinate axis parallel to d: 7529 ! 7530 NoUpperNode = .FALSE. 7531 NoLowerNode = .FALSE. 7532 IF (jz == 0 .OR. ABS(maxres_z) < AEPS) THEN 7533 NoUpperNode = .TRUE. 7534 ELSE 7535 rupper = DOT_PRODUCT(e3(:), [ Mesh % Nodes % x(jz) - Mesh % Nodes % x(TargetNode), & 7536 Mesh % Nodes % y(jz) - Mesh % Nodes % y(TargetNode), & 7537 Mesh % Nodes % z(jz) - Mesh % Nodes % z(TargetNode) ]) 7538 ! print *, 'THE NODE ON +d SIDE = ', JZ 7539 ! print *, 'TORQUE ARM = ', rupper 7540 END IF 7541 7542 IF (lz == 0 .OR. ABS(minres_z) < AEPS) THEN 7543 NoLowerNode = .TRUE. 7544 ELSE 7545 rlower = DOT_PRODUCT(-e3(:), [ Mesh % Nodes % x(lz) - Mesh % Nodes % x(TargetNode), & 7546 Mesh % Nodes % y(lz) - Mesh % Nodes % y(TargetNode), & 7547 Mesh % Nodes % z(lz) - Mesh % Nodes % z(TargetNode) ]) 7548 ! print *, 'THE NODE ON -d SIDE = ', LZ 7549 ! print *, 'TORQUE ARM = ', rlower 7550 END IF 7551 7552 IF (NoUpperNode .OR. NoLowerNode) THEN 7553 CALL Warn('SetCoupleLoads', 'A couple BC would need two nodes on opposite sides') 7554 ELSE 7555 ! 7556 ! The torque generated from point loads as M1 * e1 + M2 * e2 = (r e3) x (f1 * e1 - f2 * e2) = 7557 ! (r*f2)* e1 + (r*f1)* e2 7558 ! 7559 F2 = M1/(rupper + rlower) 7560 F1 = M2/(rupper + rlower) 7561 Force = F1 * e1 - F2 * e2 7562 ! 7563 ! Finally compute the components of force with respect to the global frame and 7564 ! add to the RHS: 7565 ! 7566 F1 = DOT_PRODUCT(Force,ex) 7567 F2 = DOT_PRODUCT(Force,ey) 7568 F3 = DOT_PRODUCT(Force,ez) 7569 7570 k = Perm(jz) 7571 F((k-1)*Dofs+1) = F((k-1)*Dofs+1) + F1 7572 F((k-1)*Dofs+2) = F((k-1)*Dofs+2) + F2 7573 IF (Dofs > 2) F((k-1)*Dofs+3) = F((k-1)*Dofs+3) + F3 7574 k = Perm(lz) 7575 F((k-1)*Dofs+1) = F((k-1)*Dofs+1) - F1 7576 F((k-1)*Dofs+2) = F((k-1)*Dofs+2) - F2 7577 IF (Dofs > 2) F((k-1)*Dofs+3) = F((k-1)*Dofs+3) - F3 7578 END IF 7579 7580 ELSE 7581 !------------------------------------------------------------------------------ 7582 ! Seek torque arms which are closest to be parallel to the global coordinate 7583 ! axes: 7584 !------------------------------------------------------------------------------ 7585 maxres_x = 0.0d0 7586 minres_x = 0.0d0 7587 maxres_y = 0.0d0 7588 minres_y = 0.0d0 7589 maxres_z = 0.0d0 7590 minres_z = 0.0d0 7591 jx = 0 7592 lx = 0 7593 jy = 0 7594 ly = 0 7595 jz = 0 7596 lz = 0 7597 DO i=1,n 7598 IF (NearNodes(i) == TargetNode) CYCLE 7599 7600 IF (ABS(Torque(3)) > AEPS) THEN 7601 res_x = DOT_PRODUCT(ex(:), NearCoordinates(:,i)) / & 7602 SQRT(DOT_PRODUCT(NearCoordinates(:,i), NearCoordinates(:,i))) 7603 IF (res_x > 0.0d0) THEN 7604 ! 7605 ! A near node is on +E_X side 7606 ! 7607 IF (res_x > maxres_x) THEN 7608 jx = NearNodes(i) 7609 maxres_x = res_x 7610 END IF 7611 ELSE 7612 ! 7613 ! A near node is on -E_X side 7614 ! 7615 IF (res_x < minres_x) THEN 7616 lx = NearNodes(i) 7617 minres_x = res_x 7618 END IF 7619 END IF 7620 END IF 7621 7622 IF (ABS(Torque(1)) > AEPS) THEN 7623 res_y = DOT_PRODUCT(ey(:), NearCoordinates(:,i)) / & 7624 SQRT(DOT_PRODUCT(NearCoordinates(:,i), NearCoordinates(:,i))) 7625 IF (res_y > 0.0d0) THEN 7626 ! 7627 ! A near node is on +E_Y side 7628 ! 7629 IF (res_y > maxres_y) THEN 7630 jy = NearNodes(i) 7631 maxres_y = res_y 7632 END IF 7633 ELSE 7634 ! 7635 ! A near node is on -E_Y side 7636 ! 7637 IF (res_y < minres_y) THEN 7638 ly = NearNodes(i) 7639 minres_y = res_y 7640 END IF 7641 END IF 7642 END IF 7643 7644 IF (ABS(Torque(2)) > AEPS) THEN 7645 res_z = DOT_PRODUCT(ez(:), NearCoordinates(:,i)) / & 7646 SQRT(DOT_PRODUCT(NearCoordinates(:,i), NearCoordinates(:,i))) 7647 IF (res_z > 0.0d0) THEN 7648 ! 7649 ! A near node is on +E_Z side 7650 ! 7651 IF (res_z > maxres_z) THEN 7652 jz = NearNodes(i) 7653 maxres_z = res_z 7654 END IF 7655 ELSE 7656 ! 7657 ! A near node is on -E_Z side 7658 ! 7659 IF (res_z < minres_z) THEN 7660 lz = NearNodes(i) 7661 minres_z = res_z 7662 END IF 7663 END IF 7664 END IF 7665 END DO 7666 7667 IF (ABS(Torque(1)) > AEPS) THEN 7668 !------------------------------------------------------------------------------ 7669 ! Calculate arm lengths with respect to the Y-axis: 7670 !------------------------------------------------------------------------------ 7671 NoUpperNode = .FALSE. 7672 NoLowerNode = .FALSE. 7673 IF (jy == 0) THEN 7674 NoUpperNode = .TRUE. 7675 ELSE 7676 rupper = DOT_PRODUCT(ey(:), [ Mesh % Nodes % x(jy) - Mesh % Nodes % x(TargetNode), & 7677 Mesh % Nodes % y(jy) - Mesh % Nodes % y(TargetNode), & 7678 Mesh % Nodes % z(jy) - Mesh % Nodes % z(TargetNode) ]) 7679 END IF 7680 7681 IF (ly == 0) THEN 7682 NoLowerNode = .TRUE. 7683 ELSE 7684 rlower = DOT_PRODUCT(-ey(:), [ Mesh % Nodes % x(ly) - Mesh % Nodes % x(TargetNode), & 7685 Mesh % Nodes % y(ly) - Mesh % Nodes % y(TargetNode), & 7686 Mesh % Nodes % z(ly) - Mesh % Nodes % z(TargetNode) ]) 7687 END IF 7688 7689 !------------------------------------------------------------------------------ 7690 ! Finally, create a couple which tends to cause rotation about the X-axis 7691 ! provided nodes on both sides have been identified 7692 !------------------------------------------------------------------------------ 7693 IF (NoUpperNode .OR. NoLowerNode) THEN 7694 CALL Warn('SetCoupleLoads', 'A couple BC would need two nodes on opposite Y-sides') 7695 ELSE 7696 ! 7697 ! The torque M_X E_X = (r E_Y) x (f E_Z), with the force f>0 applied on +E_Y side: 7698 ! 7699 MVal = Torque(1) 7700 FVal = Mval/(rupper + rlower) 7701 k = Perm(jy) 7702 F((k-1)*Dofs+3) = F((k-1)*Dofs+3) + Fval 7703 k = Perm(ly) 7704 F((k-1)*Dofs+3) = F((k-1)*Dofs+3) - Fval 7705 END IF 7706 END IF 7707 7708 IF (ABS(Torque(2)) > AEPS) THEN 7709 ! 7710 ! Calculate arm lengths with respect to the Z-axis: 7711 ! 7712 NoUpperNode = .FALSE. 7713 NoLowerNode = .FALSE. 7714 IF (jz == 0) THEN 7715 NoUpperNode = .TRUE. 7716 ELSE 7717 rupper = DOT_PRODUCT(ez(:), [ Mesh % Nodes % x(jz) - Mesh % Nodes % x(TargetNode), & 7718 Mesh % Nodes % y(jz) - Mesh % Nodes % y(TargetNode), & 7719 Mesh % Nodes % z(jz) - Mesh % Nodes % z(TargetNode) ]) 7720 END IF 7721 7722 IF (lz == 0) THEN 7723 NoLowerNode = .TRUE. 7724 ELSE 7725 rlower = DOT_PRODUCT(-ez(:), [ Mesh % Nodes % x(lz) - Mesh % Nodes % x(TargetNode), & 7726 Mesh % Nodes % y(lz) - Mesh % Nodes % y(TargetNode), & 7727 Mesh % Nodes % z(lz) - Mesh % Nodes % z(TargetNode) ]) 7728 END IF 7729 7730 IF (NoUpperNode .OR. NoLowerNode) THEN 7731 CALL Warn('SetCoupleLoads', 'A couple BC would need two nodes on opposite Z-sides') 7732 ELSE 7733 ! 7734 ! The torque M_Y E_Y = (r E_Z) x (f E_X), with the force f>0 applied on +E_Z side: 7735 ! 7736 MVal = Torque(2) 7737 FVal = Mval/(rupper + rlower) 7738 k = Perm(jz) 7739 F((k-1)*Dofs+1) = F((k-1)*Dofs+1) + Fval 7740 k = Perm(lz) 7741 F((k-1)*Dofs+1) = F((k-1)*Dofs+1) - Fval 7742 END IF 7743 END IF 7744 7745 IF (ABS(Torque(3)) > AEPS) THEN 7746 ! 7747 ! Calculate arm lengths with respect to the X-axis: 7748 ! 7749 NoUpperNode = .FALSE. 7750 NoLowerNode = .FALSE. 7751 IF (jx == 0) THEN 7752 NoUpperNode = .TRUE. 7753 ELSE 7754 rupper = DOT_PRODUCT(ex(:), [ Mesh % Nodes % x(jx) - Mesh % Nodes % x(TargetNode), & 7755 Mesh % Nodes % y(jx) - Mesh % Nodes % y(TargetNode), & 7756 Mesh % Nodes % z(jx) - Mesh % Nodes % z(TargetNode) ]) 7757 END IF 7758 7759 IF (lx == 0) THEN 7760 NoLowerNode = .TRUE. 7761 ELSE 7762 rlower = DOT_PRODUCT(-ex(:), [ Mesh % Nodes % x(lx) - Mesh % Nodes % x(TargetNode), & 7763 Mesh % Nodes % y(lx) - Mesh % Nodes % y(TargetNode), & 7764 Mesh % Nodes % z(lx) - Mesh % Nodes % z(TargetNode) ]) 7765 END IF 7766 7767 IF (NoUpperNode .OR. NoLowerNode) THEN 7768 CALL Warn('SetCoupleLoads', 'A couple BC would need two nodes on opposite Y-sides') 7769 ELSE 7770 ! 7771 ! The torque M_Z E_Z = (r E_X) x (f E_Y), with the force f>0 applied on +E_X side: 7772 ! 7773 MVal = Torque(3) 7774 FVal = Mval/(rupper + rlower) 7775 k = Perm(jx) 7776 F((k-1)*Dofs+1) = F((k-1)*Dofs+1) - Fval 7777 k = Perm(lx) 7778 F((k-1)*Dofs+1) = F((k-1)*Dofs+1) + Fval 7779 END IF 7780 END IF 7781 END IF 7782 7783 DEALLOCATE(NearNodes, NearCoordinates) 7784 END DO 7785 DEALLOCATE(Work) 7786 IF (WithDirector) DEALLOCATE(AllDirectors) 7787 END DO 7788!------------------------------------------------------------------------------ 7789 END SUBROUTINE SetCoupleLoads 7790!------------------------------------------------------------------------------ 7791 7792 7793 !------------------------------------------------------------------------------- 7794 SUBROUTINE CommunicateDirichletBCs(A) 7795 !------------------------------------------------------------------------------- 7796 TYPE(Matrix_t) :: A 7797 7798 REAL(KIND=dp), ALLOCATABLE :: d_e(:,:), g_e(:) 7799 INTEGER, ALLOCATABLE :: s_e(:,:), r_e(:), fneigh(:), ineigh(:) 7800 INTEGER :: i,j,k,l,n,nn,ii(ParEnv % PEs), ierr, status(MPI_STATUS_SIZE) 7801 7802 IF( ParEnv % PEs<=1 ) RETURN 7803 7804 ALLOCATE( fneigh(ParEnv % PEs), ineigh(ParEnv % PEs) ) 7805 7806 nn = 0 7807 ineigh = 0 7808 DO i=0, ParEnv % PEs-1 7809 k = i+1 7810 IF(.NOT.ParEnv % Active(k) ) CYCLE 7811 IF(i==ParEnv % myPE) CYCLE 7812 IF(.NOT.ParEnv % IsNeighbour(k) ) CYCLE 7813 nn = nn + 1 7814 fneigh(nn) = k 7815 ineigh(k) = nn 7816 END DO 7817 7818 n = COUNT(A % ConstrainedDOF .AND. A % ParallelInfo % Interface) 7819 ALLOCATE( s_e(n, nn ), r_e(n) ) 7820 ALLOCATE( d_e(n, nn ), g_e(n) ) 7821 7822 CALL CheckBuffer( nn*3*n ) 7823 7824 ii = 0 7825 DO i=1, A % NumberOfRows 7826 IF(A % ConstrainedDOF(i) .AND. A % ParallelInfo % Interface(i) ) THEN 7827 DO j=1,SIZE(A % ParallelInfo % Neighbourlist(i) % Neighbours) 7828 k = A % ParallelInfo % Neighbourlist(i) % Neighbours(j) 7829 IF ( k == ParEnv % MyPE ) CYCLE 7830 k = k + 1 7831 k = ineigh(k) 7832 IF ( k> 0) THEN 7833 ii(k) = ii(k) + 1 7834 d_e(ii(k),k) = A % DValues(i) 7835 s_e(ii(k),k) = A % ParallelInfo % GlobalDOFs(i) 7836 END IF 7837 END DO 7838 END IF 7839 END DO 7840 7841 DO i=1, nn 7842 j = fneigh(i) 7843 7844 CALL MPI_BSEND( ii(i),1,MPI_INTEGER,j-1,110,ELMER_COMM_WORLD,ierr ) 7845 IF( ii(i) > 0 ) THEN 7846 CALL MPI_BSEND( s_e(1:ii(i),i),ii(i),MPI_INTEGER,j-1,111,ELMER_COMM_WORLD,ierr ) 7847 CALL MPI_BSEND( d_e(1:ii(i),i),ii(i),MPI_DOUBLE_PRECISION,j-1,112,ELMER_COMM_WORLD,ierr ) 7848 END IF 7849 END DO 7850 7851 DO i=1, nn 7852 j = fneigh(i) 7853 CALL MPI_RECV( n,1,MPI_INTEGER,j-1,110,ELMER_COMM_WORLD, status,ierr ) 7854 IF ( n>0 ) THEN 7855 IF( n>SIZE(r_e)) THEN 7856 DEALLOCATE(r_e,g_e) 7857 ALLOCATE(r_e(n),g_e(n)) 7858 END IF 7859 7860 CALL MPI_RECV( r_e,n,MPI_INTEGER,j-1,111,ELMER_COMM_WORLD,status,ierr ) 7861 CALL MPI_RECV( g_e,n,MPI_DOUBLE_PRECISION,j-1,112,ELMER_COMM_WORLD, status,ierr ) 7862 DO j=1,n 7863 k = SearchNode( A % ParallelInfo, r_e(j), Order=A % ParallelInfo % Gorder ) 7864 IF ( k>0 ) THEN 7865 IF(.NOT. A % ConstrainedDOF(k)) THEN 7866 CALL ZeroRow(A, k ) 7867 A % Values(A % Diag(k)) = 1._dp 7868 A % Dvalues(k) = g_e(j) 7869 A % ConstrainedDOF(k) = .TRUE. 7870 END IF 7871 END IF 7872 END DO 7873 END IF 7874 END DO 7875 DEALLOCATE(s_e, r_e, d_e, g_e) 7876 !------------------------------------------------------------------------------- 7877 END SUBROUTINE CommunicateDirichletBCs 7878 !------------------------------------------------------------------------------- 7879 7880 7881 !------------------------------------------------------------------------------- 7882 !> Communicate logical tag related to linear system. 7883 !> This could related to setting Neumann BCs to zero, for example. 7884 !------------------------------------------------------------------------------- 7885 SUBROUTINE CommunicateLinearSystemTag(A,ZeroDof) 7886 !------------------------------------------------------------------------------- 7887 TYPE(Matrix_t) :: A 7888 LOGICAL, POINTER :: ZeroDof(:) 7889 7890 INTEGER, ALLOCATABLE :: s_e(:,:), r_e(:), fneigh(:), ineigh(:) 7891 INTEGER :: i,j,k,l,n,nn,ii(ParEnv % PEs), ierr, status(MPI_STATUS_SIZE) 7892 INTEGER :: NewZeros 7893 7894 IF( ParEnv % PEs<=1 ) RETURN 7895 7896 ALLOCATE( fneigh(ParEnv % PEs), ineigh(ParEnv % PEs) ) 7897 7898 nn = 0 7899 ineigh = 0 7900 DO i=0, ParEnv % PEs-1 7901 k = i+1 7902 IF(.NOT.ParEnv % Active(k) ) CYCLE 7903 IF(i==ParEnv % myPE) CYCLE 7904 IF(.NOT.ParEnv % IsNeighbour(k) ) CYCLE 7905 nn = nn + 1 7906 fneigh(nn) = k 7907 ineigh(k) = nn 7908 END DO 7909 7910 n = COUNT(ZeroDof .AND. A % ParallelInfo % Interface) 7911 ALLOCATE( s_e(n, nn ), r_e(n) ) 7912 7913 CALL CheckBuffer( nn*3*n ) 7914 7915 ii = 0 7916 DO i=1, A % NumberOfRows 7917 IF(ZeroDof(i) .AND. A % ParallelInfo % Interface(i) ) THEN 7918 DO j=1,SIZE(A % ParallelInfo % Neighbourlist(i) % Neighbours) 7919 k = A % ParallelInfo % Neighbourlist(i) % Neighbours(j) 7920 IF ( k == ParEnv % MyPE ) CYCLE 7921 k = k + 1 7922 k = ineigh(k) 7923 IF ( k> 0) THEN 7924 ii(k) = ii(k) + 1 7925 s_e(ii(k),k) = A % ParallelInfo % GlobalDOFs(i) 7926 END IF 7927 END DO 7928 END IF 7929 END DO 7930 7931 DO i=1, nn 7932 j = fneigh(i) 7933 CALL MPI_BSEND( ii(i),1,MPI_INTEGER,j-1,110,ELMER_COMM_WORLD,ierr ) 7934 IF( ii(i) > 0 ) THEN 7935 CALL MPI_BSEND( s_e(1:ii(i),i),ii(i),MPI_INTEGER,j-1,111,ELMER_COMM_WORLD,ierr ) 7936 END IF 7937 END DO 7938 7939 NewZeros = 0 7940 7941 DO i=1, nn 7942 j = fneigh(i) 7943 CALL MPI_RECV( n,1,MPI_INTEGER,j-1,110,ELMER_COMM_WORLD, status,ierr ) 7944 IF ( n>0 ) THEN 7945 IF( n>SIZE(r_e)) THEN 7946 DEALLOCATE(r_e) 7947 ALLOCATE(r_e(n)) 7948 END IF 7949 7950 CALL MPI_RECV( r_e,n,MPI_INTEGER,j-1,111,ELMER_COMM_WORLD,status,ierr ) 7951 DO j=1,n 7952 k = SearchNode( A % ParallelInfo, r_e(j), Order=A % ParallelInfo % Gorder ) 7953 IF ( k>0 ) THEN 7954 IF(.NOT. ZeroDof(k)) THEN 7955 ZeroDof(k) = .TRUE. 7956 NewZeros = NewZeros + 1 7957 END IF 7958 END IF 7959 END DO 7960 END IF 7961 END DO 7962 DEALLOCATE(s_e, r_e ) 7963 7964 !PRINT *,'New Zeros:',ParEnv % MyPe, NewZeros 7965 7966 !------------------------------------------------------------------------------- 7967 END SUBROUTINE CommunicateLinearSystemTag 7968 !------------------------------------------------------------------------------- 7969 7970 7971 7972!------------------------------------------------------------------------------- 7973 SUBROUTINE EnforceDirichletConditions( Solver, A, b, OffDiagonal ) 7974!------------------------------------------------------------------------------ 7975 IMPLICIT NONE 7976 TYPE(Solver_t) :: Solver 7977 TYPE(Matrix_t), POINTER :: A 7978 REAL(KIND=dp) :: b(:) 7979 LOGICAL, OPTIONAL :: OffDiagonal 7980 7981 TYPE(ValueList_t), POINTER :: Params 7982 LOGICAL :: ScaleSystem, DirichletComm, Found, NoDiag 7983 REAL(KIND=dp), POINTER :: DiagScaling(:) 7984 REAL(KIND=dp) :: dval, s 7985 INTEGER :: i,j,k,n 7986 CHARACTER(*), PARAMETER :: Caller = 'EnforceDirichletConditions' 7987 7988 7989 Params => Solver % Values 7990 7991 IF(.NOT. ALLOCATED( A % ConstrainedDOF ) ) THEN 7992 CALL Info(Caller,& 7993 'ConstrainedDOF not associated, returning...',Level=8) 7994 RETURN 7995 END IF 7996 7997 7998 n = COUNT( A % ConstrainedDOF ) 7999 n = NINT( ParallelReduction(1.0_dp * n ) ) 8000 8001 IF( n == 0 ) THEN 8002 CALL Info(Caller,'No Dirichlet conditions to enforce, exiting!',Level=10) 8003 RETURN 8004 END IF 8005 8006 8007 IF( PRESENT( OffDiagonal ) ) THEN 8008 NoDiag = OffDiagonal 8009 ELSE 8010 NoDiag = .FALSE. 8011 END IF 8012 8013 IF( NoDiag ) THEN 8014 ScaleSystem = .FALSE. 8015 ELSE 8016 ScaleSystem = ListGetLogical(Params,'Linear System Dirichlet Scaling',Found) 8017 IF(.NOT.Found) THEN 8018 ScaleSystem = ListGetLogical(Params,'Linear System Scaling',Found) 8019 IF(.NOT.Found) ScaleSystem=.TRUE. 8020 END IF 8021 END IF 8022 8023 IF( ScaleSystem ) THEN 8024 CALL Info(Caller,'Applying Dirichlet conditions using scaled diagonal',Level=8) 8025 CALL ScaleLinearSystem(Solver,A,b,ApplyScaling=.FALSE.) 8026 DiagScaling => A % DiagScaling 8027 END IF 8028 8029 ! Communicate the Dirichlet conditions for parallel cases since there may be orphans 8030 IF ( ParEnv % PEs > 1 ) THEN 8031 DirichletComm = ListGetLogical( CurrentModel % Simulation, 'Dirichlet Comm', Found) 8032 IF(.NOT. Found) DirichletComm = .TRUE. 8033 IF( DirichletComm) CALL CommunicateDirichletBCs(A) 8034 END IF 8035 8036 ! Eliminate all entries in matrix that may be eliminated in one sweep 8037 ! If this is an offdiagonal entry this cannot be done. 8038 IF ( A % Symmetric .AND. .NOT. NoDiag ) THEN 8039 CALL CRS_ElimSymmDirichlet(A,b) 8040 END IF 8041 8042 8043 DO k=1,A % NumberOfRows 8044 8045 IF ( A % ConstrainedDOF(k) ) THEN 8046 8047 dval = A % Dvalues(k) 8048 8049 IF( ScaleSystem ) THEN 8050 s = DiagScaling(k) 8051 IF( ABS(s) <= TINY(s) ) s = 1.0_dp 8052 ELSE 8053 s = 1.0_dp 8054 END IF 8055 s = 1._dp / s**2 8056 8057 CALL ZeroRow(A, k) 8058 8059 ! Off-diagonal entries for a block matrix are neglected since the code will 8060 ! also go through the diagonal entries where the r.h.s. target value will be set. 8061 IF(.NOT. NoDiag ) THEN 8062 CALL SetMatrixElement(A,k,k,s) 8063 b(k) = s * dval 8064 END IF 8065 8066 END IF 8067 END DO 8068 8069 ! Deallocate scaling since otherwise it could be misused out of context 8070 IF (ScaleSystem) DEALLOCATE( A % DiagScaling ) 8071 8072 CALL Info(Caller,'Dirichlet boundary conditions enforced', Level=12) 8073 8074 END SUBROUTINE EnforceDirichletConditions 8075!------------------------------------------------------------------------------- 8076 8077 8078 8079!------------------------------------------------------------------------------ 8080 FUNCTION sGetElementDOFs( Indexes, UElement, USolver ) RESULT(NB) 8081!------------------------------------------------------------------------------ 8082 TYPE(Element_t), OPTIONAL, TARGET :: UElement 8083 TYPE(Solver_t), OPTIONAL, TARGET :: USolver 8084 INTEGER :: Indexes(:) 8085 8086 TYPE(Solver_t), POINTER :: Solver 8087 TYPE(Element_t), POINTER :: Element, Parent 8088 8089 LOGICAL :: Found, GB 8090 INTEGER :: nb,i,j,EDOFs, FDOFs, BDOFs,FaceDOFs, EdgeDOFs, BubbleDOFs 8091 8092 IF ( PRESENT( UElement ) ) THEN 8093 Element => UElement 8094 ELSE 8095 Element => CurrentModel % CurrentElement 8096 END IF 8097 8098 IF ( PRESENT( USolver ) ) THEN 8099 Solver => USolver 8100 ELSE 8101 Solver => CurrentModel % Solver 8102 END IF 8103 8104 NB = 0 8105 8106 IF ( Solver % DG ) THEN 8107 DO i=1,Element % DGDOFs 8108 NB = NB + 1 8109 Indexes(NB) = Element % DGIndexes(i) 8110 END DO 8111 8112 IF ( ASSOCIATED( Element % BoundaryInfo ) ) THEN 8113 IF ( ASSOCIATED( Element % BoundaryInfo % Left ) ) THEN 8114 DO i=1,Element % BoundaryInfo % Left % DGDOFs 8115 NB = NB + 1 8116 Indexes(NB) = Element % BoundaryInfo % Left % DGIndexes(i) 8117 END DO 8118 END IF 8119 IF ( ASSOCIATED( Element % BoundaryInfo % Right ) ) THEN 8120 DO i=1,Element % BoundaryInfo % Right % DGDOFs 8121 NB = NB + 1 8122 Indexes(NB) = Element % BoundaryInfo % Right % DGIndexes(i) 8123 END DO 8124 END IF 8125 END IF 8126 8127 IF ( NB > 0 ) RETURN 8128 END IF 8129 8130 DO i=1,Element % NDOFs 8131 NB = NB + 1 8132 Indexes(NB) = Element % NodeIndexes(i) 8133 END DO 8134 8135 FaceDOFs = Solver % Mesh % MaxFaceDOFs 8136 EdgeDOFs = Solver % Mesh % MaxEdgeDOFs 8137 BubbleDOFs = Solver % Mesh % MaxBDOFs 8138 8139 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 8140 DO j=1,Element % TYPE % NumberOFEdges 8141 EDOFs = Solver % Mesh % Edges( Element % EdgeIndexes(j) ) % BDOFs 8142 DO i=1,EDOFs 8143 NB = NB + 1 8144 Indexes(NB) = EdgeDOFs*(Element % EdgeIndexes(j)-1) + & 8145 i + Solver % Mesh % NumberOfNodes 8146 END DO 8147 END DO 8148 END IF 8149 8150 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 8151 DO j=1,Element % TYPE % NumberOFFaces 8152 FDOFs = Solver % Mesh % Faces( Element % FaceIndexes(j) ) % BDOFs 8153 DO i=1,FDOFs 8154 NB = NB + 1 8155 Indexes(NB) = FaceDOFs*(Element % FaceIndexes(j)-1) + i + & 8156 Solver % Mesh % NumberOfNodes + EdgeDOFs*Solver % Mesh % NumberOfEdges 8157 END DO 8158 END DO 8159 END IF 8160 8161 GB = ListGetLogical( Solver % Values, 'Bubbles in Global System', Found ) 8162 IF (.NOT. Found) GB = .TRUE. 8163 8164 IF ( ASSOCIATED(Element % BoundaryInfo) ) THEN 8165 IF (.NOT. isActivePElement(Element) ) RETURN 8166 8167 Parent => Element % BoundaryInfo % Left 8168 IF (.NOT.ASSOCIATED(Parent) ) & 8169 Parent => Element % BoundaryInfo % Right 8170 IF (.NOT.ASSOCIATED(Parent) ) RETURN 8171 8172 IF ( ASSOCIATED( Parent % EdgeIndexes ) ) THEN 8173 EDOFs = Element % BDOFs 8174 DO i=1,EDOFs 8175 NB = NB + 1 8176 Indexes(NB) = EdgeDOFs*(Parent % EdgeIndexes(Element % PDefs % LocalNumber)-1) + & 8177 i + Solver % Mesh % NumberOfNodes 8178 END DO 8179 END IF 8180 8181 IF ( ASSOCIATED( Parent % FaceIndexes ) ) THEN 8182 FDOFs = Element % BDOFs 8183 DO i=1,FDOFs 8184 NB = NB + 1 8185 Indexes(NB) = FaceDOFs*(Parent % FaceIndexes(Element % PDefs % LocalNumber)-1) + i + & 8186 Solver % Mesh % NumberOfNodes + EdgeDOFs*Solver % Mesh % NumberOfEdges 8187 END DO 8188 END IF 8189 ELSE IF ( GB ) THEN 8190 IF ( ASSOCIATED( Element % BubbleIndexes ) ) THEN 8191 DO i=1,Element % BDOFs 8192 NB = NB + 1 8193 Indexes(NB) = FaceDOFs*Solver % Mesh % NumberOfFaces + & 8194 Solver % Mesh % NumberOfNodes + EdgeDOFs*Solver % Mesh % NumberOfEdges + & 8195 Element % BubbleIndexes(i) 8196 END DO 8197 END IF 8198 END IF 8199!------------------------------------------------------------------------------ 8200 END FUNCTION SgetElementDOFs 8201!------------------------------------------------------------------------------ 8202 8203!------------------------------------------------------------------------------ 8204!> Check if Normal / Tangential vector boundary conditions present and 8205!> allocate space for normals, and if in 3D for two tangent direction 8206!> vectors. 8207!------------------------------------------------------------------------------ 8208 SUBROUTINE CheckNormalTangentialBoundary( Model, VariableName, & 8209 NumberOfBoundaryNodes, BoundaryReorder, BoundaryNormals, & 8210 BoundaryTangent1, BoundaryTangent2, dim ) 8211!------------------------------------------------------------------------------ 8212 TYPE(Model_t) :: Model 8213 8214 CHARACTER(LEN=*) :: VariableName 8215 8216 INTEGER, POINTER :: BoundaryReorder(:) 8217 INTEGER :: NumberOfBoundaryNodes,dim 8218 8219 REAL(KIND=dp), POINTER :: BoundaryNormals(:,:),BoundaryTangent1(:,:), & 8220 BoundaryTangent2(:,:) 8221!------------------------------------------------------------------------------ 8222 8223 TYPE(Element_t), POINTER :: CurrentElement 8224 INTEGER :: i,j,k,n,t,ierr,iter, proc 8225 LOGICAL :: GotIt, Found, Conditional 8226 TYPE(Mesh_t), POINTER :: Mesh 8227 INTEGER, POINTER :: NodeIndexes(:) 8228 REAL(KIND=dp), ALLOCATABLE :: Condition(:) 8229 8230 TYPE buff_t 8231 INTEGER, ALLOCATABLE :: buff(:) 8232 END TYPE buff_t 8233 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status 8234 INTEGER, POINTER :: nlist(:) 8235 TYPE(Buff_t), ALLOCATABLE, TARGET :: n_index(:) 8236 INTEGER, ALLOCATABLE :: n_count(:), gbuff(:) 8237!------------------------------------------------------------------------------ 8238 8239 ! need an early initialization to average normals across partitions: 8240 !------------------------------------------------------------------- 8241 IF ( Parenv % PEs >1 ) THEN 8242 IF (.NOT. ASSOCIATED(Model % Solver % Matrix % ParMatrix) ) & 8243 CALL ParallelInitMatrix( Model % Solver, Model % Solver % Matrix ) 8244 END IF 8245 8246 NumberOfBoundaryNodes = 0 8247 8248 Found = .FALSE. 8249 DO i=1,Model % NumberOfBCs 8250 IF ( ListGetLogical(Model % BCs(i) % Values, VariableName, Gotit) ) THEN 8251 Found = ListGetLogical( Model % BCs(i) % Values, & 8252 TRIM(VariableName) // ' Rotate',Gotit ) 8253 IF (.NOT. Gotit ) Found = .TRUE. 8254 IF ( Found ) EXIT 8255 END IF 8256 END DO 8257 IF ( .NOT. Found ) RETURN 8258 8259 Mesh => Model % Mesh 8260 n = Mesh % NumberOFNodes 8261 8262 IF ( .NOT. ASSOCIATED( BoundaryReorder ) ) THEN 8263 ALLOCATE( BoundaryReorder(n) ) 8264 ELSE IF ( SIZE(BoundaryReorder)<n ) THEN 8265 DEALLOCATE( BoundaryReorder ) 8266 ALLOCATE( BoundaryReorder(n) ) 8267 END IF 8268 BoundaryReorder = 0 8269 8270!------------------------------------------------------------------------------ 8271 DO t=Mesh % NumberOfBulkElements + 1, Mesh % NumberOfBulkElements + & 8272 Mesh % NumberOfBoundaryElements 8273 8274 CurrentElement => Model % Elements(t) 8275 IF ( CurrentElement % TYPE % ElementCode == 101 ) CYCLE 8276 8277 n = CurrentElement % TYPE % NumberOfNodes 8278 NodeIndexes => CurrentElement % NodeIndexes 8279 ALLOCATE( Condition(n) ) 8280 DO i=1,Model % NumberOfBCs 8281 IF ( CurrentElement % BoundaryInfo % Constraint == & 8282 Model % BCs(i) % Tag ) THEN 8283 IF ( ListGetLogical( Model % BCs(i) % Values,VariableName, gotIt) ) THEN 8284 Found = ListGetLogical( Model % BCs(i) % Values, & 8285 TRIM(VariableName) // ' Rotate',gotIt) 8286 IF ( Found .OR. .NOT. GotIt ) THEN 8287 Condition(1:n) = ListGetReal( Model % BCs(i) % Values, & 8288 TRIM(VariableName) // ' Condition', n, NodeIndexes, Conditional ) 8289 8290 DO j=1,n 8291 IF ( Conditional .AND. Condition(j)<0._dp ) CYCLE 8292 8293 k = NodeIndexes(j) 8294 IF ( BoundaryReorder(k)==0 ) THEN 8295 NumberOfBoundaryNodes = NumberOfBoundaryNodes + 1 8296 BoundaryReorder(k) = NumberOfBoundaryNodes 8297 END IF 8298 END DO 8299 END IF 8300 END IF 8301 END IF 8302 END DO 8303 DEALLOCATE( Condition ) 8304 END DO 8305 8306 IF (ParEnv % PEs>1 ) THEN 8307!------------------------------------------------------------------------------ 8308! If parallel execution, check for parallel matrix initializations 8309!------------------------------------------------------------------------------ 8310 ALLOCATE( n_count(ParEnv% PEs),n_index(ParEnv % PEs) ) 8311 n_count = 0 8312 IF ( NumberOfBoundaryNodes>0 ) THEN 8313 DO i=1,Mesh % NumberOfNodes 8314 IF (BoundaryReorder(i)<=0 ) CYCLE 8315 IF (.NOT.Mesh % ParallelInfo % INTERFACE(i) ) CYCLE 8316 8317 nlist => Mesh % ParallelInfo % NeighbourList(i) % Neighbours 8318 DO j=1,SIZE(nlist) 8319 k = nlist(j)+1 8320 IF ( k-1 == ParEnv % myPE ) CYCLE 8321 n_count(k) = n_count(k)+1 8322 END DO 8323 END DO 8324 DO i=1,ParEnv % PEs 8325 IF ( n_count(i)>0 ) & 8326 ALLOCATE( n_index(i) % buff(n_count(i)) ) 8327 END DO 8328 n_count = 0 8329 DO i=1,Mesh % NumberOfNodes 8330 IF (BoundaryReorder(i)<=0 ) CYCLE 8331 IF (.NOT.Mesh % ParallelInfo % INTERFACE(i) ) CYCLE 8332 8333 nlist => Mesh % ParallelInfo % NeighbourList(i) % Neighbours 8334 DO j=1,SIZE(nlist) 8335 k = nlist(j)+1 8336 IF ( k == ParEnv % myPE+1 ) CYCLE 8337 n_count(k) = n_count(k)+1 8338 n_index(k) % buff(n_count(k)) = Mesh % Parallelinfo % & 8339 GlobalDOFs(i) 8340 END DO 8341 END DO 8342 END IF 8343 8344 DO i=1,ParEnv % PEs 8345 IF ( ParEnv % Active(i) .AND. ParEnv % IsNeighbour(i) ) THEN 8346 CALL MPI_BSEND( n_count(i), 1, MPI_INTEGER, i-1, & 8347 800, ELMER_COMM_WORLD, ierr ) 8348 IF ( n_count(i)>0 ) & 8349 CALL MPI_BSEND( n_index(i) % buff, n_count(i), MPI_INTEGER, i-1, & 8350 801, ELMER_COMM_WORLD, ierr ) 8351 END IF 8352 END DO 8353 8354 DO i=1,ParEnv % PEs 8355 IF ( n_count(i)>0 ) DEALLOCATE( n_index(i) % Buff) 8356 8357 IF ( ParEnv % Active(i) .AND. ParEnv % IsNeighbour(i) ) THEN 8358 CALL MPI_RECV( n, 1, MPI_INTEGER, MPI_ANY_SOURCE, & 8359 800, ELMER_COMM_WORLD, status, ierr ) 8360 IF ( n>0 ) THEN 8361 ALLOCATE( gbuff(n) ) 8362 proc = status(MPI_SOURCE) 8363 CALL MPI_RECV( gbuff, n, MPI_INTEGER, proc, & 8364 801, ELMER_COMM_WORLD, status, ierr ) 8365 8366 DO j=1,n 8367 k = SearchNodeL( Mesh % ParallelInfo, gbuff(j), Mesh % NumberOfNodes ) 8368 IF ( k>0 ) THEN 8369 IF ( BoundaryReorder(k)<= 0 ) THEN 8370 NumberOfBoundaryNodes = NumberOfBoundaryNodes + 1 8371 BoundaryReorder(k) = NumberOfBoundaryNodes 8372 END IF 8373 END IF 8374 END DO 8375 DEALLOCATE(gbuff) 8376 END IF 8377 END IF 8378 END DO 8379 DEALLOCATE( n_index, n_count ) 8380 END IF 8381 8382!------------------------------------------------------------------------------ 8383 8384 IF ( NumberOfBoundaryNodes == 0 ) THEN 8385! DEALLOCATE( BoundaryReorder ) 8386! NULLIFY( BoundaryReorder, BoundaryNormals,BoundaryTangent1, & 8387! BoundaryTangent2) 8388 ELSE 8389 IF ( ASSOCIATED(BoundaryNormals) ) THEN 8390 DEALLOCATE( BoundaryNormals, BoundaryTangent1, & 8391 BoundaryTangent2, NTelement, NTzeroing_done) 8392 END IF 8393 8394 ALLOCATE( NTelement(NumberOfBoundaryNodes,3) ) 8395 ALLOCATE( NTzeroing_done(NumberOfBoundaryNodes,3) ) 8396 ALLOCATE( BoundaryNormals(NumberOfBoundaryNodes,3) ) 8397 ALLOCATE( BoundaryTangent1(NumberOfBoundaryNodes,3) ) 8398 ALLOCATE( BoundaryTangent2(NumberOfBoundaryNodes,3) ) 8399 8400 BoundaryNormals = 0.0d0 8401 BoundaryTangent1 = 0.0d0 8402 BoundaryTangent2 = 0.0d0 8403 END IF 8404 8405!------------------------------------------------------------------------------ 8406 END SUBROUTINE CheckNormalTangentialBoundary 8407!------------------------------------------------------------------------------ 8408 8409 8410!------------------------------------------------------------------------------ 8411!> Average boundary normals for nodes. The average boundary normals 8412!> may be beneficial as they provide more continuous definition of normal 8413!> over curved boundaries. 8414!------------------------------------------------------------------------------ 8415 SUBROUTINE AverageBoundaryNormals( Model, VariableName, & 8416 NumberOfBoundaryNodes, BoundaryReorder, BoundaryNormals, & 8417 BoundaryTangent1, BoundaryTangent2, dim ) 8418!------------------------------------------------------------------------------ 8419 TYPE(Model_t) :: Model 8420 8421 INTEGER, POINTER :: BoundaryReorder(:) 8422 INTEGER :: NumberOfBoundaryNodes,DIM 8423 8424 REAL(KIND=dp), POINTER :: BoundaryNormals(:,:),BoundaryTangent1(:,:), & 8425 BoundaryTangent2(:,:) 8426 8427 CHARACTER(LEN=*) :: VariableName 8428!------------------------------------------------------------------------------ 8429 TYPE(Element_t), POINTER :: Element 8430 TYPE(Nodes_t) :: ElementNodes 8431 INTEGER :: i,j,k,l,m,n,t, iBC, ierr, proc 8432 LOGICAL :: GotIt, Found, PeriodicNormals, Conditional 8433 REAL(KIND=dp) :: s,Bu,Bv,Nrm(3),Basis(32),DetJ 8434 INTEGER, POINTER :: NodeIndexes(:) 8435 TYPE(Matrix_t), POINTER :: Projector 8436 REAL(KIND=dp), ALLOCATABLE :: Condition(:) 8437 8438 TYPE(Variable_t), POINTER :: NrmVar, Tan1Var, Tan2Var 8439 8440 LOGICAL, ALLOCATABLE :: Done(:), NtMasterBC(:), NtSlaveBC(:) 8441 8442 REAL(KIND=dp), POINTER :: SetNormal(:,:), Rot(:,:) 8443 8444 REAL(KIND=dp), TARGET :: x(Model % MaxElementNodes) 8445 REAL(KIND=dp), TARGET :: y(Model % MaxElementNodes) 8446 REAL(KIND=dp), TARGET :: z(Model % MaxElementNodes) 8447 8448 TYPE buff_t 8449 INTEGER, ALLOCATABLE :: buff(:) 8450 REAL(KIND=dp), ALLOCATABLE :: normals(:) 8451 END TYPE buff_t 8452 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status 8453 INTEGER, POINTER :: nlist(:) 8454 TYPE(Buff_t), ALLOCATABLE :: n_index(:) 8455 REAL(KIND=dp), ALLOCATABLE :: nbuff(:) 8456 INTEGER, ALLOCATABLE :: n_count(:), gbuff(:), n_comp(:) 8457 8458 LOGICAL :: MassConsistent, LhsSystem, RotationalNormals 8459 LOGICAL, ALLOCATABLE :: LhsTangent(:),RhsTangent(:) 8460 INTEGER :: LhsConflicts 8461 8462 TYPE(ValueList_t), POINTER :: BC 8463 TYPE(Mesh_t), POINTER :: Mesh 8464 REAL(KIND=dp) :: Origin(3),Axis(3) 8465 REAL(KIND=dp), POINTER :: Pwrk(:,:) 8466 LOGICAL :: GotOrigin,GotAxis 8467 CHARACTER(*), PARAMETER :: Caller = 'AverageBoundaryNormals' 8468 8469 !------------------------------------------------------------------------------ 8470 8471 ElementNodes % x => x 8472 ElementNodes % y => y 8473 ElementNodes % z => z 8474 8475 Mesh => Model % Mesh 8476 NrmVar => VariableGet( Mesh % Variables, 'Normals' ) 8477 8478 8479 IF ( ASSOCIATED(NrmVar) ) THEN 8480 8481 IF ( NumberOfBoundaryNodes >0 ) THEN 8482 BoundaryNormals = 0._dp 8483 DO i=1,Model % NumberOfNodes 8484 k = BoundaryReorder(i) 8485 IF (k>0 ) THEN 8486 DO l=1,NrmVar % DOFs 8487 BoundaryNormals(k,l) = NrmVar % Values( NrmVar % DOFs* & 8488 (NrmVar % Perm(i)-1)+l) 8489 END DO 8490 END IF 8491 END DO 8492 END IF 8493 8494 ELSE 8495 8496!------------------------------------------------------------------------------ 8497! Compute sum of elementwise normals for nodes on boundaries 8498!------------------------------------------------------------------------------ 8499 ALLOCATE( n_comp(Model % NumberOfNodes) ) 8500 n_comp = 0 8501 8502 IF ( NumberOfBoundaryNodes>0 ) THEN 8503 BoundaryNormals = 0._dp 8504 8505 DO t=Model % NumberOfBulkElements + 1, Model % NumberOfBulkElements + & 8506 Model % NumberOfBoundaryElements 8507 Element => Model % Elements(t) 8508 IF ( Element % TYPE % ElementCode < 200 ) CYCLE 8509 8510 n = Element % TYPE % NumberOfNodes 8511 NodeIndexes => Element % NodeIndexes 8512 8513 ElementNodes % x(1:n) = Model % Nodes % x(NodeIndexes) 8514 ElementNodes % y(1:n) = Model % Nodes % y(NodeIndexes) 8515 ElementNodes % z(1:n) = Model % Nodes % z(NodeIndexes) 8516 8517 ALLOCATE(Condition(n)) 8518 8519 DO i=1,Model % NumberOfBCs 8520 IF ( Element % BoundaryInfo % Constraint == Model % BCs(i) % Tag ) THEN 8521 BC => Model % BCs(i) % Values 8522 8523 IF ( ListGetLogical( BC, VariableName, gotIt) ) THEN 8524 Found = ListGetLogical( BC, TRIM(VariableName) // ' Rotate',gotIt) 8525 IF ( Found .OR. .NOT. Gotit ) THEN 8526 MassConsistent = ListGetLogical( BC,'Mass Consistent Normals',gotIt) 8527 RotationalNormals = ListGetLogical(BC,'Rotational Normals',gotIt) 8528 8529 IF( RotationalNormals ) THEN 8530 Pwrk => ListGetConstRealArray(BC,'Normals Origin',GotOrigin ) 8531 IF( GotOrigin ) THEN 8532 IF( SIZE(Pwrk,1) /= 3 .OR. SIZE(Pwrk,2) /= 1 ) THEN 8533 CALL Fatal(Caller,'Size of > Normals Origin < should be 3!') 8534 END IF 8535 Origin = Pwrk(1:3,1) 8536 END IF 8537 Pwrk => ListGetConstRealArray(BC,'Normals Axis',GotAxis ) 8538 IF( GotAxis ) THEN 8539 IF( SIZE(Pwrk,1) /= 3 .OR. SIZE(Pwrk,2) /= 1 ) THEN 8540 CALL Fatal(Caller,'Size of > Normals Axis < should be 3!') 8541 END IF 8542 Axis = Pwrk(1:3,1) 8543 ! Normalize axis is it should just be used for the direction 8544 Axis = Axis / SQRT( SUM( Axis*Axis ) ) 8545 END IF 8546 END IF 8547 8548 Condition(1:n) = ListGetReal( BC,& 8549 TRIM(VariableName) // ' Condition', n, NodeIndexes, Conditional ) 8550 8551 DO j=1,n 8552 IF ( Conditional .AND. Condition(j) < 0._dp ) CYCLE 8553 8554 k = BoundaryReorder( NodeIndexes(j) ) 8555 IF (k>0) THEN 8556 nrm = 0._dp 8557 IF (MassConsistent) THEN 8558 CALL IntegMassConsistent(j,n,nrm) 8559 ELSE IF( RotationalNormals ) THEN 8560 nrm(1) = ElementNodes % x(j) 8561 nrm(2) = ElementNodes % y(j) 8562 nrm(3) = ElementNodes % z(j) 8563 8564 IF( GotOrigin ) nrm = nrm - Origin 8565 IF( GotAxis ) THEN 8566 nrm = nrm - SUM( nrm * Axis ) * Axis 8567 ELSE ! Default axis is (0,0,1) 8568 nrm(3) = 0.0_dp 8569 END IF 8570 8571 nrm = nrm / SQRT( SUM( nrm * nrm ) ) 8572 ELSE 8573 Bu = Element % TYPE % NodeU(j) 8574 Bv = Element % TYPE % NodeV(j) 8575 nrm = NormalVector(Element,ElementNodes,Bu,Bv,.TRUE.) 8576 END IF 8577 n_comp(NodeIndexes(j)) = 1 8578 BoundaryNormals(k,:) = BoundaryNormals(k,:) + nrm 8579 END IF 8580 END DO 8581 END IF 8582 END IF 8583 END IF 8584 END DO 8585 DEALLOCATE(Condition) 8586 END DO 8587 8588 DO iBC=1,Model % NumberOfBCs 8589 Projector => Model % BCs(iBC) % PMatrix 8590 IF ( .NOT. ASSOCIATED( Projector ) ) CYCLE 8591 8592 ! 8593 ! TODO: consistent normals, if rotations given: 8594 ! --------------------------------------------- 8595 BC => Model % BCs(iBC) % Values 8596 Rot => ListGetConstRealArray(BC,'Periodic BC Rotate', Found ) 8597 IF ( Found .AND. ASSOCIATED(Rot) ) THEN 8598 IF ( ANY(Rot/=0) ) THEN 8599 ALLOCATE( Done(SIZE(BoundaryNormals,1)) ) 8600 Done=.FALSE. 8601 DO i=1,Projector % NumberOfRows 8602 k = BoundaryReorder(Projector % InvPerm(i)) 8603 IF ( k <= 0 ) CYCLE 8604 DO l=Projector % Rows(i),Projector % Rows(i+1)-1 8605 IF ( Projector % Cols(l) <= 0 ) CYCLE 8606 m = BoundaryReorder(Projector % Cols(l)) 8607 IF ( m>0 ) THEN 8608 IF ( .NOT.Done(m) ) THEN 8609 Done(m) = .TRUE. 8610 BoundaryNormals(m,:) = -BoundaryNormals(m,:) 8611 END IF 8612 END IF 8613 END DO 8614 END DO 8615 DEALLOCATE(Done) 8616 CYCLE 8617 END IF 8618 END IF 8619 8620 DO i=1,Projector % NumberOfRows 8621 k = BoundaryReorder(Projector % InvPerm(i)) 8622 IF ( k <= 0 ) CYCLE 8623 DO l=Projector % Rows(i),Projector % Rows(i+1)-1 8624 IF ( Projector % Cols(l) <= 0 ) CYCLE 8625 m = BoundaryReorder(Projector % Cols(l)) 8626 IF ( m>0 ) BoundaryNormals(m,:) = 0._dp 8627 END DO 8628 END DO 8629 END DO 8630 8631 DO iBC=1,Model % NumberOfBCs 8632 Projector => Model % BCs(iBC) % PMatrix 8633 IF ( .NOT. ASSOCIATED( Projector ) ) CYCLE 8634 8635 ! 8636 ! TODO: consistent normals, if rotations given: 8637 ! --------------------------------------------- 8638 BC => Model % BCs(iBC) % Values 8639 Rot => ListGetConstRealArray(BC,'Periodic BC Rotate', Found ) 8640 IF ( Found .AND. ASSOCIATED(Rot) ) THEN 8641 IF ( ANY(Rot/=0) ) CYCLE 8642 END IF 8643 8644 DO i=1,Projector % NumberOfRows 8645 k = BoundaryReorder(Projector % InvPerm(i)) 8646 IF ( k <= 0 ) CYCLE 8647 DO l=Projector % Rows(i),Projector % Rows(i+1)-1 8648 IF ( Projector % Cols(l) <= 0 ) CYCLE 8649 m = BoundaryReorder(Projector % Cols(l)) 8650 IF ( m > 0 ) & 8651 BoundaryNormals(m,:) = BoundaryNormals(m,:) + & 8652 Projector % Values(l) * BoundaryNormals(k,:) 8653 END DO 8654 END DO 8655 END DO 8656 END IF 8657 8658 IF (ParEnv % PEs>1 ) THEN 8659 ALLOCATE( n_count(ParEnv% PEs),n_index(ParEnv % PEs) ) 8660 n_count = 0 8661 8662 IF ( NumberOfBoundaryNodes>0 ) THEN 8663 DO i=1,Mesh % NumberOfNodes 8664 IF (BoundaryReorder(i)<=0 .OR. n_comp(i)<=0 ) CYCLE 8665 IF (.NOT.Mesh % ParallelInfo % INTERFACE(i) ) CYCLE 8666 8667 nlist => Mesh % ParallelInfo % NeighbourList(i) % Neighbours 8668 DO j=1,SIZE(nlist) 8669 k = nlist(j)+1 8670 IF ( k-1 == ParEnv % myPE ) CYCLE 8671 n_count(k) = n_count(k)+1 8672 END DO 8673 END DO 8674 DO i=1,ParEnv % PEs 8675 IF ( n_count(i)>0 ) & 8676 ALLOCATE( n_index(i) % buff(n_count(i)), & 8677 n_index(i) % normals(3*n_count(i)) ) 8678 END DO 8679 8680 n_count = 0 8681 DO i=1,Model % NumberOfNodes 8682 IF (BoundaryReorder(i)<=0 .OR. n_comp(i)<=0 ) CYCLE 8683 IF (.NOT.Mesh % ParallelInfo % INTERFACE(i) ) CYCLE 8684 8685 nlist => Mesh % ParallelInfo % NeighbourList(i) % Neighbours 8686 DO j=1,SIZE(nlist) 8687 k = nlist(j)+1 8688 IF ( k-1 == ParEnv % myPE ) CYCLE 8689 n_count(k) = n_count(k)+1 8690 n_index(k) % buff(n_count(k)) = Mesh % Parallelinfo % & 8691 GlobalDOFs(i) 8692 l = BoundaryReorder(i) 8693 n_index(k) % normals(3*n_count(k)-2)=BoundaryNormals(l,1) 8694 n_index(k) % normals(3*n_count(k)-1)=BoundaryNormals(l,2) 8695 n_index(k) % normals(3*n_count(k)-0)=BoundaryNormals(l,3) 8696 END DO 8697 END DO 8698 END IF 8699 8700 DO i=1,ParEnv % PEs 8701 IF ( ParEnv % Active(i) .AND. ParEnv % IsNeighbour(i) ) THEN 8702 CALL MPI_BSEND( n_count(i), 1, MPI_INTEGER, i-1, & 8703 900, ELMER_COMM_WORLD, ierr ) 8704 IF ( n_count(i)>0 ) THEN 8705 CALL MPI_BSEND( n_index(i) % buff, n_count(i), MPI_INTEGER, i-1, & 8706 901, ELMER_COMM_WORLD, ierr ) 8707 CALL MPI_BSEND( n_index(i) % normals, 3*n_count(i), MPI_DOUBLE_PRECISION, & 8708 i-1, 902, ELMER_COMM_WORLD, ierr ) 8709 END IF 8710 END IF 8711 END DO 8712 DO i=1,ParEnv % PEs 8713 IF ( n_count(i)>0 ) DEALLOCATE( n_index(i) % Buff, n_index(i) % Normals) 8714 8715 IF ( ParEnv % Active(i) .AND. ParEnv % IsNeighbour(i) ) THEN 8716 CALL MPI_RECV( n, 1, MPI_INTEGER, MPI_ANY_SOURCE, & 8717 900, ELMER_COMM_WORLD, status, ierr ) 8718 IF ( n>0 ) THEN 8719 proc = status(MPI_SOURCE) 8720 ALLOCATE( gbuff(n), nbuff(3*n) ) 8721 CALL MPI_RECV( gbuff, n, MPI_INTEGER, proc, & 8722 901, ELMER_COMM_WORLD, status, ierr ) 8723 8724 CALL MPI_RECV( nbuff, 3*n, MPI_DOUBLE_PRECISION, proc, & 8725 902, ELMER_COMM_WORLD, status, ierr ) 8726 8727 DO j=1,n 8728 k = SearchNodeL( Mesh % ParallelInfo, gbuff(j), Mesh % NumberOfNodes ) 8729 IF ( k>0 ) THEN 8730 n_comp(k) = n_comp(k)+1 8731 l = BoundaryReorder(k) 8732 IF ( l>0 ) THEN 8733 BoundaryNormals(l,1)=BoundaryNormals(l,1)+nbuff(3*j-2) 8734 BoundaryNormals(l,2)=BoundaryNormals(l,2)+nbuff(3*j-1) 8735 BoundaryNormals(l,3)=BoundaryNormals(l,3)+nbuff(3*j-0) 8736 END IF 8737 END IF 8738 END DO 8739 DEALLOCATE(gbuff, nbuff) 8740 END IF 8741 END IF 8742 END DO 8743 DEALLOCATE( n_index, n_count ) 8744 END IF 8745 8746 DEALLOCATE(n_comp) 8747 END IF 8748 8749!------------------------------------------------------------------------------ 8750! normalize 8751!------------------------------------------------------------------------------ 8752 IF ( NumberOfBoundaryNodes>0 ) THEN 8753 8754 LhsSystem = ListGetLogical(Model % Simulation,'Use Lhs System',Found) 8755 IF(.NOT. Found ) LhsSystem = ( dim == 3 ) 8756 8757 IF( LhsSystem ) THEN 8758 ALLOCATE( NtMasterBC( Model % NumberOfBCs ), NtSlaveBC( Model % NumberOfBCs ) ) 8759 NtMasterBC = .FALSE.; NtSlaveBC = .FALSE. 8760 8761 DO i = 1, Model % NumberOfBcs 8762 IF( .NOT. ListCheckPrefix( Model % BCs(i) % Values,'Normal-Tangential') ) CYCLE 8763 8764 j = ListGetInteger( Model % BCs(i) % Values,'Mortar BC',Found ) 8765 IF( .NOT. Found ) THEN 8766 j = ListGetInteger( Model % BCs(i) % Values,'Contact BC',Found ) 8767 END IF 8768 IF( j == 0 .OR. j > Model % NumberOfBCs ) CYCLE 8769 8770 NtSlaveBC( i ) = .TRUE. 8771 NtMasterBC( j ) = .TRUE. 8772 END DO 8773 LhsSystem = ANY( NtMasterBC ) 8774 END IF 8775 8776 IF( LhsSystem ) THEN 8777 DO i = 1, Model % NumberOfBcs 8778 IF( NtSlaveBC( i ) .AND. NtMasterBC( i ) ) THEN 8779 CALL Warn(Caller,'BC '//TRIM(I2S(i))//' is both N-T master and slave!') 8780 END IF 8781 END DO 8782 8783 ALLOCATE( LhsTangent( Model % NumberOfNodes ) ) 8784 LhsTangent = .FALSE. 8785 8786 ALLOCATE( RhsTangent( Model % NumberOfNodes ) ) 8787 RhsTangent = .FALSE. 8788 8789 DO t=Model % NumberOfBulkElements + 1, Model % NumberOfBulkElements + & 8790 Model % NumberOfBoundaryElements 8791 Element => Model % Elements(t) 8792 IF ( Element % TYPE % ElementCode < 200 ) CYCLE 8793 8794 n = Element % TYPE % NumberOfNodes 8795 NodeIndexes => Element % NodeIndexes 8796 8797 DO i=1,Model % NumberOfBCs 8798 IF ( Element % BoundaryInfo % Constraint == Model % BCs(i) % Tag ) THEN 8799 IF( NtMasterBC(i) ) LhsTangent( NodeIndexes ) = .TRUE. 8800 IF( NtSlaveBC(i) ) RhsTangent( NodeIndexes ) = .TRUE. 8801 EXIT 8802 END IF 8803 END DO 8804 END DO 8805 8806 LhsConflicts = COUNT( LhsTangent .AND. RhsTangent ) 8807 IF( LhsConflicts > 0 ) THEN 8808 CALL Warn(Caller,& 8809 'There are '//TRIM(I2S(LhsConflicts))//' nodes that could be both rhs and lhs!') 8810 END IF 8811 END IF 8812 8813 8814 DO i=1,Model % NumberOfNodes 8815 k = BoundaryReorder(i) 8816 IF ( k > 0 ) THEN 8817 s = SQRT( SUM( BoundaryNormals(k,:)**2 ) ) 8818 IF ( s /= 0.0d0 ) & 8819 BoundaryNormals(k,:) = BoundaryNormals(k,:) / s 8820 IF ( dim > 2 ) THEN 8821 CALL TangentDirections( BoundaryNormals(k,:), & 8822 BoundaryTangent1(k,:), BoundaryTangent2(k,:) ) 8823 IF( LhsSystem ) THEN 8824 IF( LhsTangent(i) ) THEN 8825 BoundaryTangent2(k,:) = -BoundaryTangent2(k,:) 8826 END IF 8827 END IF 8828 END IF 8829 END IF 8830 END DO 8831 8832 IF( ListGetLogical( Model % Simulation,'Save Averaged Normals',Found ) ) THEN 8833 CALL Info(Caller,'Saving averaged boundary normals to variable: Averaged Normals') 8834 NrmVar => VariableGet( Mesh % Variables, 'Averaged Normals' ) 8835 8836 IF(.NOT. ASSOCIATED( NrmVar ) ) THEN 8837 CALL VariableAddVector( Mesh % Variables, Mesh, Model % Solver,'Averaged Normals',3,& 8838 Perm = BoundaryReorder ) 8839 NrmVar => VariableGet( Mesh % Variables, 'Averaged Normals' ) 8840 END IF 8841 8842 DO i=1,Model % NumberOfNodes 8843 k = BoundaryReorder(i) 8844 IF (k>0 ) THEN 8845 DO l=1,NrmVar % DOFs 8846 NrmVar % Values( NrmVar % DOFs* & 8847 (NrmVar % Perm(i)-1)+l) = BoundaryNormals(k,l) 8848 END DO 8849 END IF 8850 END DO 8851 8852 IF( dim > 2 .AND. ListGetLogical( Model % Simulation,'Save Averaged Tangents',Found ) ) THEN 8853 Tan1Var => VariableGet( Mesh % Variables, 'Averaged First Tangent' ) 8854 Tan2Var => VariableGet( Mesh % Variables, 'Averaged Second Tangent' ) 8855 8856 IF(.NOT. ASSOCIATED( Tan1Var ) ) THEN 8857 CALL VariableAddVector( Mesh % Variables, Mesh, Model % Solver,& 8858 'Averaged First Tangent',3, Perm = BoundaryReorder ) 8859 Tan1Var => VariableGet( Mesh % Variables, 'Averaged First Tangent' ) 8860 CALL VariableAddVector( Mesh % Variables, Mesh, Model % Solver,& 8861 'Averaged Second Tangent',3, Perm = BoundaryReorder ) 8862 Tan2Var => VariableGet( Mesh % Variables, 'Averaged Second Tangent' ) 8863 END IF 8864 8865 DO i=1,Model % NumberOfNodes 8866 k = BoundaryReorder(i) 8867 IF (k>0 ) THEN 8868 DO l=1,Tan1Var % DOFs 8869 Tan1Var % Values( Tan1Var % DOFs* & 8870 (Tan1Var % Perm(i)-1)+l) = BoundaryTangent1(k,l) 8871 Tan2Var % Values( Tan2Var % DOFs* & 8872 (Tan2Var % Perm(i)-1)+l) = BoundaryTangent2(k,l) 8873 END DO 8874 END IF 8875 END DO 8876 END IF 8877 END IF 8878 END IF 8879 8880 8881 8882 CONTAINS 8883 8884 SUBROUTINE IntegMassConsistent(j,n,nrm) 8885 INTEGER :: t,j,n 8886 LOGICAL :: stat 8887 REAL(KIND=dp) :: detJ,Basis(n),nrm(:),lnrm(3) 8888 8889 TYPE(GaussIntegrationPoints_t) :: IP 8890 8891 !---------------------- 8892 IP = GaussPoints(Element) 8893 DO t=1,IP % n 8894 stat = ElementInfo(Element, ElementNodes, IP % U(t), & 8895 IP % v(t), IP % W(t), detJ, Basis) 8896 8897 lnrm = NormalVector(Element,ElementNodes, & 8898 IP % U(t),IP % v(t),.TRUE.) 8899 8900 nrm = nrm + IP % s(t) * lnrm * detJ * Basis(j) 8901 END DO 8902 END SUBROUTINE IntegMassConsistent 8903 8904!------------------------------------------------------------------------------ 8905 END SUBROUTINE AverageBoundaryNormals 8906!------------------------------------------------------------------------------ 8907 8908 8909!------------------------------------------------------------------------------ 8910!> Search an element QueriedNode from an ordered set Nodes and return 8911!> Index to Nodes structure. Return value -1 means QueriedNode was 8912!> not found. 8913!------------------------------------------------------------------------------ 8914FUNCTION SearchNodeL( ParallelInfo, QueriedNode,n ) RESULT(Indx) 8915 8916 USE Types 8917 IMPLICIT NONE 8918 8919 TYPE (ParallelInfo_t) :: ParallelInfo 8920 INTEGER :: QueriedNode, Indx,n 8921 8922 ! Local variables 8923 8924 INTEGER :: Lower, Upper, Lou, i 8925 8926!------------------------------------------------------------------------------ 8927 8928 Indx = -1 8929 Upper = n 8930 Lower = 1 8931 8932 ! Handle the special case 8933 8934 IF ( Upper == 0 ) RETURN 8935 893610 CONTINUE 8937 IF ( ParallelInfo % GlobalDOFs(Lower) == QueriedNode ) THEN 8938 Indx = Lower 8939 RETURN 8940 ELSE IF ( ParallelInfo % GlobalDOFs(Upper) == QueriedNode ) THEN 8941 Indx = Upper 8942 RETURN 8943 END IF 8944 8945 IF ( (Upper - Lower) > 1 ) THEN 8946 Lou = ISHFT((Upper + Lower), -1) 8947 IF ( ParallelInfo % GlobalDOFs(Lou) < QueriedNode ) THEN 8948 Lower = Lou 8949 GOTO 10 8950 ELSE 8951 Upper = Lou 8952 GOTO 10 8953 END IF 8954 END IF 8955 8956 RETURN 8957!------------------------------------------------------------------------------ 8958END FUNCTION SearchNodeL 8959!------------------------------------------------------------------------------ 8960 8961 8962 8963!------------------------------------------------------------------------------ 8964!> Initialize solver for next timestep. 8965!------------------------------------------------------------------------------ 8966 SUBROUTINE InitializeTimestep( Solver ) 8967!------------------------------------------------------------------------------ 8968 TYPE(Solver_t) :: Solver !< Solver to be initialized. 8969!------------------------------------------------------------------------------ 8970 CHARACTER(LEN=MAX_NAME_LEN) :: Method 8971 LOGICAL :: GotIt 8972 INTEGER :: i, Order,ndofs 8973 REAL(KIND=dp), POINTER CONTIG :: SaveValues(:) 8974 TYPE(Matrix_t), POINTER :: A 8975 TYPE(Variable_t), POINTER :: Var 8976 8977!------------------------------------------------------------------------------ 8978 Solver % DoneTime = Solver % DoneTime + 1 8979!------------------------------------------------------------------------------ 8980 8981 IF ( .NOT. ASSOCIATED( Solver % Matrix ) .OR. & 8982 .NOT. ASSOCIATED( Solver % Variable % Values ) ) RETURN 8983 8984 IF ( Solver % TimeOrder <= 0 ) RETURN 8985!------------------------------------------------------------------------------ 8986 8987 Method = ListGetString( Solver % Values, 'Timestepping Method', GotIt ) 8988 IF ( Method == 'none' ) RETURN 8989 8990 IF ( .NOT.GotIt ) THEN 8991 8992 Solver % Beta = ListGetConstReal( Solver % Values, 'Newmark Beta', GotIt ) 8993 IF ( .NOT. GotIt ) THEN 8994 Solver % Beta = ListGetConstReal( CurrentModel % Simulation, 'Newmark Beta', GotIt ) 8995 END IF 8996 8997 IF ( .NOT.GotIt ) THEN 8998 IF (Solver % TimeOrder > 1) THEN 8999 Method = 'bossak' 9000 Solver % Beta = 1.0d0 9001 ELSE 9002 CALL Warn( 'InitializeTimestep', & 9003 'Timestepping method defaulted to IMPLICIT EULER' ) 9004 9005 Solver % Beta = 1.0D0 9006 Method = 'implicit euler' 9007 END IF 9008 END IF 9009 9010 ELSE 9011 9012 Solver % Beta = 1._dp 9013 SELECT CASE( Method ) 9014 CASE('implicit euler') 9015 Solver % Beta = 1.0d0 9016 9017 CASE('explicit euler') 9018 Solver % Beta = 0.0d0 9019 9020 CASE('runge-kutta') 9021 Solver % Beta = 0.0d0 9022 9023 CASE('crank-nicolson') 9024 Solver % Beta = 0.5d0 9025 9026 CASE('fs') 9027 Solver % Beta = 0.5d0 9028 9029 CASE('adams-bashforth') 9030 Solver % Beta = 0.0d0 9031 9032 CASE('adams-moulton') 9033 Solver % Beta = 1.0d0 9034 9035 CASE('newmark') 9036 Solver % Beta = ListGetConstReal( Solver % Values, 'Newmark Beta', GotIt ) 9037 IF ( .NOT. GotIt ) THEN 9038 Solver % Beta = ListGetConstReal( CurrentModel % Simulation, & 9039 'Newmark Beta', GotIt ) 9040 END IF 9041 9042 IF ( Solver % Beta<0 .OR. Solver % Beta>1 ) THEN 9043 WRITE( Message, * ) 'Invalid value of Beta ', Solver % Beta 9044 CALL Warn( 'InitializeTimestep', Message ) 9045 END IF 9046 9047 CASE('bdf') 9048 IF ( Solver % Order < 1 .OR. Solver % Order > 5 ) THEN 9049 WRITE( Message, * ) 'Invalid order BDF ', Solver % Order 9050 CALL Fatal( 'InitializeTimestep', Message ) 9051 END IF 9052 9053 CASE('bossak') 9054 Solver % Beta = 1.0d0 9055 9056 CASE DEFAULT 9057 WRITE( Message, * ) 'Unknown timestepping method: ',Method 9058 CALL Fatal( 'InitializeTimestep', Message ) 9059 END SELECT 9060 9061 END IF 9062 9063 ndofs = Solver % Matrix % NumberOfRows 9064 Var => Solver % Variable 9065 9066 IF ( Method /= 'bdf' .OR. Solver % TimeOrder > 1 ) THEN 9067 9068 IF ( Solver % DoneTime == 1 .AND. Solver % Beta /= 0.0d0 ) THEN 9069 Solver % Beta = 1.0d0 9070 END IF 9071 IF( Solver % TimeOrder == 2 ) THEN 9072 Solver % Alpha = ListGetConstReal( Solver % Values, & 9073 'Bossak Alpha', GotIt ) 9074 IF ( .NOT. GotIt ) THEN 9075 Solver % Alpha = ListGetConstReal( CurrentModel % Simulation, & 9076 'Bossak Alpha', GotIt ) 9077 END IF 9078 IF ( .NOT. GotIt ) Solver % Alpha = -0.05d0 9079 END IF 9080 9081 SELECT CASE( Solver % TimeOrder ) 9082 9083 CASE(1) 9084 Order = MIN(Solver % DoneTime, Solver % Order) 9085 DO i=Order, 2, -1 9086 Var % PrevValues(:,i) = Var % PrevValues(:,i-1) 9087 END DO 9088 Var % PrevValues(:,1) = Var % Values 9089 Solver % Matrix % Force(:,2) = Solver % Matrix % Force(:,1) 9090 9091 CASE(2) 9092 Var % PrevValues(:,3) = Var % Values 9093 Var % PrevValues(:,4) = Var % PrevValues(:,1) 9094 Var % PrevValues(:,5) = Var % PrevValues(:,2) 9095 END SELECT 9096 ELSE 9097 Order = MIN(Solver % DoneTime, Solver % Order) 9098 DO i=Order, 2, -1 9099 Var % PrevValues(:,i) = Var % PrevValues(:,i-1) 9100 END DO 9101 Var % PrevValues(:,1) = Var % Values 9102 END IF 9103 9104 9105 IF( ListGetLogical( Solver % Values,'Nonlinear Timestepping', GotIt ) ) THEN 9106 IF( Solver % DoneTime > 1 ) THEN 9107 A => Solver % Matrix 9108 CALL Info('InitializeTimestep','Saving previous linear system for timestepping',Level=12) 9109 IF( .NOT. ASSOCIATED( A % BulkValues ) ) THEN 9110 CALL Fatal('InitializeTimestep','BulkValues should be associated!') 9111 END IF 9112 9113 IF( .NOT. ASSOCIATED( A % BulkResidual ) ) THEN 9114 ALLOCATE( A % BulkResidual( SIZE( A % BulkRhs ) ) ) 9115 END IF 9116 9117 SaveValues => A % Values 9118 A % Values => A % BulkValues 9119 CALL MatrixVectorMultiply( A, Var % Values, A % BulkResidual ) 9120 A % Values => SaveValues 9121 A % BulkResidual = A % BulkResidual - A % BulkRhs 9122 END IF 9123 END IF 9124 9125 9126 ! Advance also the exported variables if they happen to be time-dependent 9127 ! They only have normal prevvalues, when writing this always 2. 9128 BLOCK 9129 INTEGER :: VarNo,n 9130 CHARACTER(LEN=MAX_NAME_LEN) :: str, var_name 9131 LOGICAL :: Found 9132 9133 VarNo =0 9134 DO WHILE( .TRUE. ) 9135 VarNo = VarNo + 1 9136 str = ComponentName( 'exported variable', VarNo ) 9137 9138 var_name = ListGetString( Solver % Values, str, Found ) 9139 IF(.NOT. Found) EXIT 9140 9141 CALL VariableNameParser( var_name ) 9142 9143 Var => VariableGet( Solver % Mesh % Variables, Var_name ) 9144 IF( .NOT. ASSOCIATED(Var)) CYCLE 9145 IF( .NOT. ASSOCIATED(Var % PrevValues) ) CYCLE 9146 9147 n = SIZE( Var % PrevValues,2 ) 9148 DO i=n,2,-1 9149 Var % PrevValues(:,i) = Var % PrevValues(:,i-1) 9150 END DO 9151 Var % PrevValues(:,1) = Var % Values 9152 END DO 9153 END BLOCK 9154 9155!------------------------------------------------------------------------------ 9156 END SUBROUTINE InitializeTimestep 9157!------------------------------------------------------------------------------ 9158 9159 9160!------------------------------------------------------------------------------ 9161!> Update force vector AFTER ALL OTHER ASSEMBLY STEPS BUT BEFORE SETTING 9162!> DIRICHLET CONDITIONS. Required only for time dependent simulations.. 9163!------------------------------------------------------------------------------ 9164 SUBROUTINE FinishAssembly( Solver, ForceVector ) 9165!------------------------------------------------------------------------------ 9166 TYPE(Solver_t) :: Solver 9167 REAL(KIND=dp) :: ForceVector(:) 9168 CHARACTER(LEN=MAX_NAME_LEN) :: Method, Simulation 9169 INTEGER :: Order 9170 LOGICAL :: Found 9171!------------------------------------------------------------------------------ 9172 9173 IF ( Solver % Matrix % FORMAT == MATRIX_LIST ) THEN 9174 CALL List_toCRSMatrix(Solver % Matrix) 9175 END IF 9176 9177 Simulation = ListGetString( CurrentModel % Simulation, 'Simulation Type' ) 9178 IF ( Simulation == 'transient' ) THEN 9179 Method = ListGetString( Solver % Values, 'Timestepping Method' ) 9180 Order = MIN(Solver % DoneTime, Solver % Order) 9181 9182 IF ( Order <= 0 .OR. Solver % TimeOrder /= 1 .OR. Method=='bdf' ) RETURN 9183 9184 IF ( Solver % Beta /= 0.0d0 ) THEN 9185 ForceVector = ForceVector + ( Solver % Beta - 1 ) * & 9186 Solver % Matrix % Force(:,1) + & 9187 ( 1 - Solver % Beta ) * Solver % Matrix % Force(:,2) 9188 END IF 9189 END IF 9190 9191!------------------------------------------------------------------------------ 9192 END SUBROUTINE FinishAssembly 9193!------------------------------------------------------------------------------ 9194 9195 9196!------------------------------------------------------------------------------ 9197 RECURSIVE SUBROUTINE InvalidateVariable( TopMesh,PrimaryMesh,Name ) 9198!------------------------------------------------------------------------------ 9199 CHARACTER(LEN=*) :: Name 9200 TYPE(Mesh_t), POINTER :: TopMesh,PrimaryMesh 9201!------------------------------------------------------------------------------ 9202 CHARACTER(LEN=MAX_NAME_LEN) :: tmpname 9203 INTEGER :: i 9204 TYPE(Mesh_t), POINTER :: Mesh 9205 TYPE(Variable_t), POINTER :: Var,Var1, PrimVar 9206!------------------------------------------------------------------------------ 9207 Mesh => TopMesh 9208 9209 PrimVar => VariableGet( PrimaryMesh % Variables, Name, ThisOnly=.TRUE.) 9210 IF ( .NOT.ASSOCIATED( PrimVar) ) RETURN 9211 9212 DO WHILE( ASSOCIATED(Mesh) ) 9213 ! Make the same variable invalid in all other meshes. 9214 IF ( .NOT.ASSOCIATED( PrimaryMesh, Mesh) ) THEN 9215 Var => VariableGet( Mesh % Variables, Name, ThisOnly=.TRUE.) 9216 IF ( ASSOCIATED( Var ) ) THEN 9217 Var % Valid = .FALSE. 9218 Var % PrimaryMesh => PrimaryMesh 9219 END IF 9220 9221 IF ( PrimVar % DOFs > 1 ) THEN 9222 DO i=1,PrimVar % DOFs 9223 tmpname = ComponentName( Name, i ) 9224 Var1 => VariableGet( Mesh % Variables, tmpname, .TRUE. ) 9225 IF ( ASSOCIATED( Var1 ) ) THEN 9226 Var1 % Valid = .FALSE. 9227 Var1 % PrimaryMesh => PrimaryMesh 9228 END IF 9229 END DO 9230 END IF 9231 END IF 9232 Mesh => Mesh % Next 9233 END DO 9234 9235 ! Tell that values have changed in the primary mesh. 9236 ! Interpolation can then be activated if we request the same variable in the 9237 ! other meshes. 9238 PrimVar % ValuesChanged = .TRUE. 9239 IF ( PrimVar % DOFs > 1 ) THEN 9240 DO i=1,PrimVar % DOFs 9241 tmpname = ComponentName( Name, i ) 9242 Var => VariableGet( PrimaryMesh % Variables, tmpname, .TRUE. ) 9243 IF ( ASSOCIATED(Var) ) Var % ValuesChanged = .TRUE. 9244 END DO 9245 END IF 9246!------------------------------------------------------------------------------ 9247 END SUBROUTINE InvalidateVariable 9248!------------------------------------------------------------------------------ 9249 9250 9251!------------------------------------------------------------------------------ 9252!> Rotate a vector to normal-tangential coordinate system. 9253!------------------------------------------------------------------------------ 9254 SUBROUTINE RotateNTSystem( Vec, NodeNumber ) 9255!------------------------------------------------------------------------------ 9256 REAL(KIND=dp) :: Vec(:) 9257 INTEGER :: NodeNumber 9258!------------------------------------------------------------------------------ 9259 INTEGER :: i,j,k, dim 9260 REAL(KIND=dp) :: Bu,Bv,Bw,RM(3,3) 9261!------------------------------------------------------------------------------ 9262 9263 IF ( NormalTangentialNOFNodes <= 0 ) RETURN 9264 9265 dim = CoordinateSystemDimension() 9266 9267 k = BoundaryReorder(NodeNumber) 9268 IF ( k <= 0 ) RETURN 9269 9270 IF ( dim < 3 ) THEN 9271 Bu = Vec(1) 9272 Bv = Vec(2) 9273 Vec(1) = BoundaryNormals(k,1)*Bu + BoundaryNormals(k,2)*Bv 9274 Vec(2) = -BoundaryNormals(k,2)*Bu + BoundaryNormals(k,1)*Bv 9275 ELSE 9276 Bu = Vec(1) 9277 Bv = Vec(2) 9278 Bw = Vec(3) 9279 9280 RM(:,1) = BoundaryNormals(k,:) 9281 RM(:,2) = BoundaryTangent1(k,:) 9282 RM(:,3) = BoundaryTangent2(k,:) 9283 9284 Vec(1) = RM(1,1)*Bu + RM(2,1)*Bv + RM(3,1)*Bw 9285 Vec(2) = RM(1,2)*Bu + RM(2,2)*Bv + RM(3,2)*Bw 9286 Vec(3) = RM(1,3)*Bu + RM(2,3)*Bv + RM(3,3)*Bw 9287 END IF 9288!------------------------------------------------------------------------------ 9289 END SUBROUTINE RotateNTSystem 9290!------------------------------------------------------------------------------ 9291 9292!------------------------------------------------------------------------------------ 9293!> Rotate all components of a solution vector to normal-tangential coordinate system 9294!------------------------------------------------------------------------------------ 9295 SUBROUTINE RotateNTSystemAll( Solution, Perm, NDOFs ) 9296!------------------------------------------------------------------------------ 9297 REAL(KIND=dp) :: Solution(:) 9298 INTEGER :: Perm(:), NDOFs 9299!------------------------------------------------------------------------------ 9300 INTEGER :: i,j,k, dim 9301 REAL(KIND=dp) :: Bu,Bv,Bw,RM(3,3) 9302!------------------------------------------------------------------------------ 9303 dim = CoordinateSystemDimension() 9304 9305 IF ( NormalTangentialNOFNodes<=0.OR.ndofs<dim ) RETURN 9306 9307 DO i=1,SIZE(BoundaryReorder) 9308 k = BoundaryReorder(i) 9309 IF ( k <= 0 ) CYCLE 9310 j = Perm(i) 9311 IF ( j <= 0 ) CYCLE 9312 9313 IF ( dim < 3 ) THEN 9314 Bu = Solution(NDOFs*(j-1)+1) 9315 Bv = Solution(NDOFs*(j-1)+2) 9316 9317 Solution(NDOFs*(j-1)+1) = BoundaryNormals(k,1)*Bu + BoundaryNormals(k,2)*Bv 9318 Solution(NDOFs*(j-1)+2) = -BoundaryNormals(k,2)*Bu + BoundaryNormals(k,1)*Bv 9319 9320 ELSE 9321 Bu = Solution(NDOFs*(j-1)+1) 9322 Bv = Solution(NDOFs*(j-1)+2) 9323 Bw = Solution(NDOFs*(j-1)+3) 9324 9325 RM(:,1) = BoundaryNormals(k,:) 9326 RM(:,2) = BoundaryTangent1(k,:) 9327 RM(:,3) = BoundaryTangent2(k,:) 9328 9329 Solution(NDOFs*(j-1)+1) = RM(1,1)*Bu + RM(2,1)*Bv + RM(3,1)*Bw 9330 Solution(NDOFs*(j-1)+2) = RM(1,2)*Bu + RM(2,2)*Bv + RM(3,2)*Bw 9331 Solution(NDOFs*(j-1)+3) = RM(1,3)*Bu + RM(2,3)*Bv + RM(3,3)*Bw 9332 END IF 9333 END DO 9334!------------------------------------------------------------------------------ 9335 END SUBROUTINE RotateNTSystemAll 9336!------------------------------------------------------------------------------ 9337 9338 9339!------------------------------------------------------------------------------ 9340!> Backrotate a solution from normal-tangential coordinate system to cartesian one. 9341!------------------------------------------------------------------------------ 9342 SUBROUTINE BackRotateNTSystem( Solution, Perm, NDOFs ) 9343!------------------------------------------------------------------------------ 9344 REAL(KIND=dp) :: Solution(:) 9345 INTEGER :: Perm(:), NDOFs 9346!------------------------------------------------------------------------------ 9347 INTEGER :: i,j,k, dim 9348 REAL(KIND=dp) :: Bu,Bv,Bw,RM(3,3) 9349!------------------------------------------------------------------------------ 9350 dim = CoordinateSystemDimension() 9351 9352 IF ( NormalTangentialNOFNodes<=0.OR.ndofs<dim ) RETURN 9353 9354 DO i=1,SIZE(BoundaryReorder) 9355 k = BoundaryReorder(i) 9356 IF ( k <= 0 ) CYCLE 9357 j = Perm(i) 9358 IF ( j <= 0 ) CYCLE 9359 9360 IF ( dim < 3 ) THEN 9361 Bu = Solution(NDOFs*(j-1)+1) 9362 Bv = Solution(NDOFs*(j-1)+2) 9363 9364 Solution(NDOFs*(j-1)+1) = BoundaryNormals(k,1) * Bu - & 9365 BoundaryNormals(k,2) * Bv 9366 9367 Solution(NDOFs*(j-1)+2) = BoundaryNormals(k,2) * Bu + & 9368 BoundaryNormals(k,1) * Bv 9369 ELSE 9370 Bu = Solution(NDOFs*(j-1)+1) 9371 Bv = Solution(NDOFs*(j-1)+2) 9372 Bw = Solution(NDOFs*(j-1)+3) 9373 9374 RM(1,:) = BoundaryNormals(k,:) 9375 RM(2,:) = BoundaryTangent1(k,:) 9376 RM(3,:) = BoundaryTangent2(k,:) 9377 9378 Solution(NDOFs*(j-1)+1) = RM(1,1)*Bu + RM(2,1)*Bv + RM(3,1)*Bw 9379 Solution(NDOFs*(j-1)+2) = RM(1,2)*Bu + RM(2,2)*Bv + RM(3,2)*Bw 9380 Solution(NDOFs*(j-1)+3) = RM(1,3)*Bu + RM(2,3)*Bv + RM(3,3)*Bw 9381 END IF 9382 END DO 9383!------------------------------------------------------------------------------ 9384 END SUBROUTINE BackRotateNTSystem 9385!------------------------------------------------------------------------------ 9386 9387 9388!------------------------------------------------------------------------------ 9389 FUNCTION GetSolutionRotation(A,n) RESULT(rotated) 9390!------------------------------------------------------------------------------ 9391 INTEGER :: n 9392 LOGICAL :: rotated 9393 REAL(KIND=dp) :: A(3,3) 9394!------------------------------------------------------------------------------ 9395 INTEGER :: k,dim 9396!------------------------------------------------------------------------------ 9397 dim = CoordinateSystemDimension() 9398 9399 Rotated=.FALSE. 9400 9401 A=0._dp 9402 A(1,1)=1._dp 9403 A(2,2)=1._dp 9404 A(3,3)=1._dp 9405 IF (NormalTangentialNOFNodes<=0) RETURN 9406 9407 k = BoundaryReorder(n) 9408 IF (k>0) THEN 9409 Rotated = .TRUE. 9410 IF (dim==2) THEN 9411 A(1,1)= BoundaryNormals(k,1) 9412 A(1,2)=-BoundaryNormals(k,2) 9413 A(2,1)= BoundaryNormals(k,2) 9414 A(2,2)= BoundaryNormals(k,1) 9415 ELSE 9416 A(:,1)=BoundaryNormals(k,:) 9417 A(:,2)=BoundaryTangent1(k,:) 9418 A(:,3)=BoundaryTangent2(k,:) 9419 END IF 9420 END IF 9421!------------------------------------------------------------------------------ 9422 END FUNCTION GetSolutionRotation 9423!------------------------------------------------------------------------------ 9424 9425 9426!------------------------------------------------------------------------------ 9427!> Computes the norm related to a solution vector of the Solver. 9428!------------------------------------------------------------------------------ 9429 FUNCTION ComputeNorm(Solver, nin, values) RESULT (Norm) 9430!------------------------------------------------------------------------------ 9431 IMPLICIT NONE 9432 TYPE(Solver_t), TARGET :: Solver 9433 INTEGER :: nin 9434 REAL(KIND=dp), TARGET, OPTIONAL :: values(:) 9435 9436 INTEGER :: NormDim, NormDofs, Dofs,i,j,k,n,totn,PermStart 9437 INTEGER, POINTER :: NormComponents(:) 9438 INTEGER, ALLOCATABLE :: iPerm(:) 9439 REAL(KIND=dp) :: Norm, nscale, val 9440 LOGICAL :: Stat, ComponentsAllocated, ConsistentNorm 9441 REAL(KIND=dp), POINTER :: x(:) 9442 REAL(KIND=dp), ALLOCATABLE, TARGET :: y(:) 9443 9444 CALL Info('ComputeNorm','Computing norm of solution',Level=10) 9445 9446 IF(PRESENT(values)) THEN 9447 x => values 9448 ELSE 9449 x => Solver % Variable % Values 9450 END IF 9451 9452 9453 NormDim = ListGetInteger(Solver % Values,'Nonlinear System Norm Degree',Stat) 9454 IF(.NOT. Stat) NormDim = 2 9455 9456 Dofs = Solver % Variable % Dofs 9457 9458 ComponentsAllocated = .FALSE. 9459 NormComponents => ListGetIntegerArray(Solver % Values,& 9460 'Nonlinear System Norm Components',Stat) 9461 IF(Stat) THEN 9462 NormDofs = SIZE( NormComponents ) 9463 ELSE 9464 NormDofs = ListGetInteger(Solver % Values,'Nonlinear System Norm Dofs',Stat) 9465 IF(Stat) THEN 9466 ALLOCATE(NormComponents(NormDofs)) 9467 ComponentsAllocated = .TRUE. 9468 DO i=1,NormDofs 9469 NormComponents(i) = i 9470 END DO 9471 ELSE 9472 NormDofs = Dofs 9473 END IF 9474 END IF 9475 9476 n = nin 9477 totn = 0 9478 9479 IF( ParEnv % PEs > 1 ) THEN 9480 ConsistentNorm = ListGetLogical(Solver % Values,'Nonlinear System Consistent Norm',Stat) 9481 IF (ConsistentNorm) CALL Info('ComputeNorm','Using consistent norm in parallel',Level=10) 9482 ELSE 9483 ConsistentNorm = .FALSE. 9484 END IF 9485 9486 9487 PermStart = ListGetInteger(Solver % Values,'Norm Permutation',Stat) 9488 IF ( Stat ) THEN 9489 ALLOCATE(iPerm(SIZE(Solver % Variable % Perm))); iPerm=0 9490 n = 0 9491 DO i=PermStart,SIZE(iPerm) 9492 IF ( Solver % Variable % Perm(i)>0 ) THEN 9493 n = n + 1 9494 iPerm(n) = Solver % Variable % Perm(i) 9495 END IF 9496 END DO 9497 ALLOCATE(y(n)) 9498 y = x(iPerm(1:n)) 9499 x => y 9500 DEALLOCATE(iPerm) 9501 END IF 9502 9503 9504 IF( NormDofs < Dofs ) THEN 9505 IF( ConsistentNorm ) THEN 9506 CALL Warn('ComputeNorm','Consistent norm not implemented for selective norm') 9507 END IF 9508 9509 totn = NINT( ParallelReduction(1._dp*n) ) 9510 nscale = NormDOFs*totn/(1._dp*DOFs) 9511 Norm = 0.0_dp 9512 9513 SELECT CASE(NormDim) 9514 CASE(0) 9515 DO i=1,NormDofs 9516 j = NormComponents(i) 9517 Norm = MAX(Norm, MAXVAL( ABS(x(j::Dofs))) ) 9518 END DO 9519 Norm = ParallelReduction(Norm,2) 9520 CASE(1) 9521 DO i=1,NormDofs 9522 j = NormComponents(i) 9523 Norm = Norm + SUM( ABS(x(j::Dofs)) ) 9524 END DO 9525 Norm = ParallelReduction(Norm)/nscale 9526 CASE(2) 9527 DO i=1,NormDofs 9528 j = NormComponents(i) 9529 Norm = Norm + SUM( x(j::Dofs)**2 ) 9530 END DO 9531 Norm = SQRT(ParallelReduction(Norm)/nscale) 9532 CASE DEFAULT 9533 DO i=1,NormDofs 9534 j = NormComponents(i) 9535 Norm = Norm + SUM( x(j::Dofs)**NormDim ) 9536 END DO 9537 Norm = (ParallelReduction(Norm)/nscale)**(1.0d0/NormDim) 9538 END SELECT 9539 ELSE IF( ConsistentNorm ) THEN 9540 ! In consistent norm we have to skip the dofs not owned by the partition in order 9541 ! to count each dof only once. 9542 9543 Norm = 0.0_dp 9544 totn = 0 9545 DO j=1,n 9546 IF( Solver % Matrix % ParallelInfo % NeighbourList(j) % Neighbours(1) & 9547 == ParEnv % MyPE ) totn = totn + 1 9548 END DO 9549 9550 totn = NINT( ParallelReduction(1._dp*totn) ) 9551 nscale = 1.0_dp * totn 9552 9553 SELECT CASE(NormDim) 9554 9555 CASE(0) 9556 DO j=1,n 9557 IF( Solver % Matrix % ParallelInfo % NeighbourList(j) % Neighbours(1) & 9558 /= ParEnv % MyPE ) CYCLE 9559 val = x(j) 9560 Norm = MAX( Norm, ABS( val ) ) 9561 END DO 9562 9563 CASE(1) 9564 DO j=1,n 9565 IF( Solver % Matrix % ParallelInfo % NeighbourList(j) % Neighbours(1) & 9566 /= ParEnv % MyPE ) CYCLE 9567 val = x(j) 9568 Norm = Norm + ABS(val) 9569 END DO 9570 9571 CASE(2) 9572 DO j=1,n 9573 IF( Solver % Matrix % ParallelInfo % NeighbourList(j) % Neighbours(1) & 9574 /= ParEnv % MyPE ) CYCLE 9575 val = x(j) 9576 9577 Norm = Norm + val**2 9578 END DO 9579 9580 CASE DEFAULT 9581 DO j=1,n 9582 IF( Solver % Matrix % ParallelInfo % NeighbourList(j) % Neighbours(1) & 9583 /= ParEnv % MyPE ) CYCLE 9584 val = x(j) 9585 Norm = Norm + val**NormDim 9586 END DO 9587 END SELECT 9588 9589 SELECT CASE(NormDim) 9590 CASE(0) 9591 Norm = ParallelReduction(Norm,2) 9592 CASE(1) 9593 Norm = ParallelReduction(Norm) / nscale 9594 CASE(2) 9595 Norm = SQRT(ParallelReduction(Norm)/nscale) 9596 CASE DEFAULT 9597 Norm = (ParallelReduction(Norm)/nscale)**(1.0d0/NormDim) 9598 END SELECT 9599 9600 ELSE 9601 val = ParallelReduction(1.0_dp*n) 9602 totn = NINT( val ) 9603 IF (totn == 0) THEN 9604 CALL Warn('ComputeNorm','Requested norm of a variable with no Dofs') 9605 Norm = 0.0_dp 9606 ELSE 9607 nscale = 1.0_dp * totn 9608 9609 val = 0.0_dp 9610 SELECT CASE(NormDim) 9611 CASE(0) 9612 IF (n>0) val = MAXVAL(ABS(x(1:n))) 9613 Norm = ParallelReduction(val,2) 9614 CASE(1) 9615 IF (n>0) val = SUM(ABS(x(1:n))) 9616 Norm = ParallelReduction(val)/nscale 9617 CASE(2) 9618 IF (n>0) val = SUM(x(1:n)**2) 9619 Norm = SQRT(ParallelReduction(val)/nscale) 9620 CASE DEFAULT 9621 IF (n>0) val = SUM(x(1:n)**NormDim) 9622 Norm = (ParallelReduction(val)/nscale)**(1.0d0/NormDim) 9623 END SELECT 9624 END IF 9625 END IF 9626 9627! PRINT *,'ComputedNorm:',Norm, NormDIm 9628 9629 IF( ComponentsAllocated ) THEN 9630 DEALLOCATE( NormComponents ) 9631 END IF 9632!------------------------------------------------------------------------------ 9633 END FUNCTION ComputeNorm 9634!------------------------------------------------------------------------------ 9635 9636 9637 SUBROUTINE UpdateDependentObjects( Solver, SteadyState ) 9638 9639 TYPE(Solver_t), TARGET :: Solver 9640 LOGICAL :: SteadyState 9641 9642 TYPE(ValueList_t), POINTER :: SolverParams 9643 LOGICAL :: Found, DoIt 9644 REAL(KIND=dp) :: dt 9645 TYPE(Variable_t), POINTER :: dtVar, VeloVar 9646 CHARACTER(LEN=MAX_NAME_LEN) :: str 9647 INTEGER, POINTER :: UpdateComponents(:) 9648 CHARACTER(*), PARAMETER :: Caller = 'UpdateDependentObjects' 9649 9650 SolverParams => Solver % Values 9651 9652 IF( SteadyState ) THEN 9653 CALL Info(Caller,'Updating objects depending on primary field in steady state',Level=20) 9654 ELSE 9655 CALL Info(Caller,'Updating objects depending on primary field in nonlinear system',Level=20) 9656 END IF 9657 9658 9659 ! The update of exported variables on nonlinear or steady state level. 9660 ! In nonlinear level the nonlinear iteration may depend on the updated values. 9661 ! Steady-state level is often sufficient if the dependendence is on some other solver. 9662 !----------------------------------------------------------------------------------------- 9663 IF( SteadyState ) THEN 9664 DoIt = ListGetLogical( SolverParams,& 9665 'Update Exported Variables', Found ) 9666 ELSE 9667 DoIt = ListGetLogical( SolverParams,& 9668 'Nonlinear Update Exported Variables',Found ) 9669 END IF 9670 IF( DoIt ) THEN 9671 CALL Info(Caller,'Updating exported variables',Level=20) 9672 CALL UpdateExportedVariables( Solver ) 9673 END IF 9674 9675 ! Update components that depende on the solution of the solver. 9676 ! Nonlinear level allows some nonlinear couplings within the solver. 9677 !----------------------------------------------------------------------------------------- 9678 IF( SteadyState ) THEN 9679 UpdateComponents => ListGetIntegerArray( SolverParams, & 9680 'Update Components', DoIt ) 9681 ELSE 9682 UpdateComponents => ListGetIntegerArray( SolverParams, & 9683 'Nonlinear Update Components', DoIt ) 9684 END IF 9685 IF( DoIt ) THEN 9686 CALL Info(Caller,'Updating components',Level=20) 9687 CALL UpdateDependentComponents( UpdateComponents ) 9688 END IF 9689 9690 ! Compute derivative of solution with time i.e. velocity 9691 ! For 2nd order schemes there is direct pointer to the velocity component 9692 ! Thus only 1st order schemes need to be computed. 9693 !----------------------------------------------------------------------------------------- 9694 DoIt = .FALSE. 9695 IF( SteadyState ) THEN 9696 DoIt = ListGetLogical( SolverParams,'Calculate Velocity',Found ) 9697 ELSE 9698 DoIt = ListGetLogical( SolverParams,'Nonlinear Calculate Velocity',Found ) 9699 END IF 9700 9701 IF( DoIt ) THEN 9702 CALL Info(Caller,'Updating variable velocity') 9703 IF( .NOT. ASSOCIATED( Solver % Variable % PrevValues ) ) THEN 9704 CALL Warn(Caller,'Cannot calculate velocity without previous values!') 9705 ELSE IF( Solver % TimeOrder == 1) THEN 9706 dtVar => VariableGet( Solver % Mesh % Variables, 'timestep size' ) 9707 dt = dtVar % Values(1) 9708 str = TRIM( Solver % Variable % Name ) // ' Velocity' 9709 VeloVar => VariableGet( Solver % Mesh % Variables, str ) 9710 VeloVar % Values = (Solver % Variable % Values - Solver % Variable % PrevValues(:,1)) / dt 9711 END IF 9712 END IF 9713 9714 ! Finally compute potentially velocities related to exported variables. 9715 ! Do this on nonlinear level only when 'Nonlinear Calculate Velocity' is set true. 9716 !----------------------------------------------------------------------------------------- 9717 IF( SteadyState .OR. DoIt ) THEN 9718 CALL DerivateExportedVariables( Solver ) 9719 END IF 9720 9721 END SUBROUTINE UpdateDependentObjects 9722 9723 9724 9725!------------------------------------------------------------------------------ 9726!> When a new field has been computed compare it to the previous one. 9727!> Different convergence measures may be used. 9728!> Also performs relaxation if a non-unity relaxation factor is given. 9729!------------------------------------------------------------------------------ 9730 SUBROUTINE ComputeChange(Solver,SteadyState,nsize,values,values0,Matrix,RHS) 9731!------------------------------------------------------------------------------ 9732 TYPE(Solver_t), TARGET :: Solver 9733 LOGICAL :: SteadyState 9734 TYPE(Matrix_t), OPTIONAL, TARGET :: Matrix 9735 INTEGER, OPTIONAL :: nsize 9736 REAL(KIND=dp), OPTIONAL, TARGET :: values(:), values0(:), RHS(:) 9737!------------------------------------------------------------------------------ 9738 INTEGER :: i, n, nn, RelaxAfter, IterNo, MinIter, MaxIter, dofs 9739 TYPE(Matrix_t), POINTER :: A 9740 REAL(KIND=dp), POINTER :: b(:), x(:), r(:) 9741 REAL(KIND=dp), POINTER :: x0(:) 9742 REAL(KIND=dp) :: Norm, PrevNorm, rNorm, bNorm, Change, PrevChange, Relaxation, tmp(1),dt, & 9743 Tolerance, MaxNorm, eps, Ctarget, Poffset, nsum, dpsum 9744 CHARACTER(LEN=MAX_NAME_LEN) :: ConvergenceType 9745 INTEGER, TARGET :: Dnodes(1) 9746 INTEGER, POINTER :: Indexes(:) 9747 TYPE(Variable_t), POINTER :: iterVar, VeloVar, dtVar, WeightVar 9748 CHARACTER(LEN=MAX_NAME_LEN) :: SolverName, str 9749 LOGICAL :: Stat, ConvergenceAbsolute, Relax, RelaxBefore, DoIt, Skip, & 9750 SkipConstraints, ResidualMode, RelativeP 9751 TYPE(Matrix_t), POINTER :: MMatrix 9752 REAL(KIND=dp), POINTER CONTIG :: Mx(:), Mb(:), Mr(:) 9753 REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: TmpXVec, TmpRVec, TmpRHSVec 9754 INTEGER :: ipar(1) 9755 TYPE(ValueList_t), POINTER :: SolverParams 9756 CHARACTER(*), PARAMETER :: Caller = 'ComputeChange' 9757 9758 9759 SolverParams => Solver % Values 9760 RelativeP = .FALSE. 9761 9762 IF(SteadyState) THEN 9763 Skip = ListGetLogical( SolverParams,'Skip Compute Steady State Change',Stat) 9764 IF( Skip ) THEN 9765 CALL Info(Caller,'Skipping the computation of steady state change',Level=15) 9766 RETURN 9767 END IF 9768 9769 ! No residual mode for steady state analysis 9770 ResidualMode = .FALSE. 9771 9772 ConvergenceType = ListGetString(SolverParams,& 9773 'Steady State Convergence Measure',Stat) 9774 IF(.NOT. Stat) ConvergenceType = 'norm' 9775 9776 ConvergenceAbsolute = & 9777 ListGetLogical(SolverParams,'Steady State Convergence Absolute',Stat) 9778 IF(.NOT. Stat) ConvergenceAbsolute = & 9779 ListGetLogical(SolverParams,'Use Absolute Norm for Convergence',Stat) 9780 9781 Relaxation = ListGetCReal( SolverParams, & 9782 'Steady State Relaxation Factor', Relax ) 9783 Relax = Relax .AND. ABS(Relaxation-1.0_dp) > EPSILON(Relaxation) 9784 9785 iterVar => VariableGet( Solver % Mesh % Variables, 'coupled iter' ) 9786 IterNo = NINT( iterVar % Values(1) ) 9787 IF( Relax ) THEN 9788 RelaxAfter = ListGetInteger(SolverParams,'Steady State Relaxation After',Stat) 9789 IF( Stat .AND. RelaxAfter >= IterNo ) Relax = .FALSE. 9790 END IF 9791 9792 RelaxBefore = .TRUE. 9793 IF(Relax) THEN 9794 RelaxBefore = ListGetLogical( SolverParams, & 9795 'Steady State Relaxation Before', Stat ) 9796 IF (.NOT. Stat ) RelaxBefore = .TRUE. 9797 END IF 9798 9799 ! Steady state system has never any constraints 9800 SkipConstraints = .FALSE. 9801 9802 ELSE 9803 iterVar => VariableGet( Solver % Mesh % Variables, 'nonlin iter' ) 9804 IterNo = NINT( iterVar % Values(1) ) 9805 Solver % Variable % NonlinIter = IterNo 9806 9807 Skip = ListGetLogical( SolverParams,'Skip Advance Nonlinear iter',Stat) 9808 IF( .NOT. Skip ) iterVar % Values(1) = IterNo + 1 9809 9810 IF( .NOT. Solver % NewtonActive ) THEN 9811 i = ListGetInteger( SolverParams, 'Nonlinear System Newton After Iterations',Stat ) 9812 IF( Stat .AND. i <= IterNo ) Solver % NewtonActive = .TRUE. 9813 END IF 9814 9815 Skip = ListGetLogical( SolverParams,'Skip Compute Nonlinear Change',Stat) 9816 9817 IF(Skip) THEN 9818 CALL Info(Caller,'Skipping the computation of nonlinear change',Level=15) 9819 RETURN 9820 END IF 9821 9822 ResidualMode = ListGetLogical( SolverParams,'Linear System Residual Mode',Stat) 9823 9824 ConvergenceType = ListGetString(SolverParams,& 9825 'Nonlinear System Convergence Measure',Stat) 9826 IF(.NOT. stat) ConvergenceType = 'norm' 9827 9828 ConvergenceAbsolute = & 9829 ListGetLogical(SolverParams,'Nonlinear System Convergence Absolute',Stat) 9830 IF(.NOT. Stat) ConvergenceAbsolute = & 9831 ListGetLogical(SolverParams,'Use Absolute Norm for Convergence',Stat) 9832 9833 Relaxation = ListGetCReal( SolverParams, & 9834 'Nonlinear System Relaxation Factor', Relax ) 9835 Relax = Relax .AND. ( ABS( Relaxation - 1.0_dp) > EPSILON( Relaxation ) ) 9836 IF( Relax ) THEN 9837 RelaxAfter = ListGetInteger(SolverParams,'Nonlinear System Relaxation After',Stat) 9838 IF( Stat .AND. RelaxAfter >= Solver % Variable % NonlinIter ) Relax = .FALSE. 9839 9840 RelativeP = ListGetLogical( SolverParams,'Relative Pressure Relaxation',Stat) 9841 IF( RelativeP) CALL Info(Caller,'Using relative pressure relaxation',Level=10) 9842 END IF 9843 9844 SkipConstraints = ListGetLogical(SolverParams,& 9845 'Nonlinear System Convergence Without Constraints',Stat) 9846 9847 RelaxBefore = .TRUE. 9848 IF(Relax) THEN 9849 RelaxBefore = ListGetLogical( SolverParams, & 9850 'Nonlinear System Relaxation Before', Stat ) 9851 IF (.NOT. Stat ) RelaxBefore = .TRUE. 9852 END IF 9853 END IF 9854 9855 9856 IF(PRESENT(values)) THEN 9857 x => values 9858 ELSE 9859 x => Solver % Variable % Values 9860 END IF 9861 9862 IF ( .NOT. ASSOCIATED(x) ) THEN 9863 Solver % Variable % Norm = 0.0d0 9864 IF(SteadyState) THEN 9865 Solver % Variable % SteadyChange = 0.0d0 9866 ELSE 9867 Solver % Variable % NonlinChange = 0.0d0 9868 END IF 9869 RETURN 9870 END IF 9871 9872 9873 IF(PRESENT(nsize)) THEN 9874 n = nsize 9875 ELSE 9876 n = SIZE( x ) 9877 END IF 9878 9879 IF( SkipConstraints ) n = MIN( n, Solver % Matrix % NumberOfRows ) 9880 9881 Stat = .FALSE. 9882 x0 => NULL() 9883 IF(PRESENT(values0)) THEN 9884 x0 => values0 9885 Stat = .TRUE. 9886 ELSE IF(SteadyState) THEN 9887 IF( ASSOCIATED(Solver % Variable % SteadyValues) ) THEN 9888 x0 => Solver % Variable % SteadyValues 9889 Stat = .TRUE. 9890 END IF 9891 ELSE 9892 IF( ASSOCIATED(Solver % Variable % NonlinValues)) THEN 9893 x0 => Solver % Variable % NonlinValues 9894 Stat = .TRUE. 9895 ELSE 9896 x0 => Solver % Variable % Values 9897 Stat = .TRUE. 9898 END IF 9899 END IF 9900 9901 IF(Stat .AND. .NOT. SkipConstraints ) THEN 9902 IF (SIZE(x0) /= SIZE(x)) CALL Info(Caller,'WARNING: Possible mismatch in length of vectors!',Level=10) 9903 END IF 9904 9905 ! This ensures that the relaxation does not affect the mean of the pressure 9906 IF( RelativeP ) THEN 9907 dofs = Solver % Variable % Dofs 9908 9909 dpsum = SUM(x(dofs:n:dofs)) - SUM(x0(dofs:n:dofs)) 9910 nsum = 1.0_dp * n / dofs 9911 9912 dpsum = ParallelReduction( dpsum ) 9913 nsum = ParallelReduction( nsum ) 9914 9915 Poffset = (1-Relaxation) * dpsum / nsum 9916 END IF 9917 9918 9919 IF( ResidualMode ) THEN 9920 IF(Relax .AND. RelaxBefore) THEN 9921 x(1:n) = x0(1:n) + Relaxation*x(1:n) 9922 ELSE 9923 x(1:n) = x0(1:n) + x(1:n) 9924 END IF 9925 ELSE 9926 IF(Relax .AND. RelaxBefore) THEN 9927 x(1:n) = (1-Relaxation)*x0(1:n) + Relaxation*x(1:n) 9928 IF( RelativeP ) x(dofs:n:dofs) = x(dofs:n:dofs) + Poffset 9929 END IF 9930 END IF 9931 9932 IF(SteadyState) THEN 9933 PrevNorm = Solver % Variable % PrevNorm 9934 ELSE 9935 PrevNorm = Solver % Variable % Norm 9936 END IF 9937 9938 Norm = ComputeNorm(Solver, n, x) 9939 Solver % Variable % Norm = Norm 9940 9941 !-------------------------------------------------------------------------- 9942 ! The norm should be bounded in order to reach convergence 9943 !-------------------------------------------------------------------------- 9944 IF( Norm /= Norm ) THEN 9945 CALL NumericalError(Caller,'Norm of solution appears to be NaN') 9946 END IF 9947 9948 IF( SteadyState ) THEN 9949 MaxNorm = ListGetCReal( SolverParams, & 9950 'Steady State Max Norm', Stat ) 9951 ELSE 9952 MaxNorm = ListGetCReal( SolverParams, & 9953 'Nonlinear System Max Norm', Stat ) 9954 END IF 9955 9956 IF( Stat ) THEN 9957 CALL Info(Caller,Message) 9958 CALL NumericalError(Caller,'Norm of solution exceeded given bounds') 9959 END IF 9960 9961 SELECT CASE( ConvergenceType ) 9962 9963 CASE('residual') 9964 !-------------------------------------------------------------------------- 9965 ! x is solution of A(x0)x=b(x0) thus residual should really be r=b(x)-A(x)x 9966 ! Instead we use r=b(x0)-A(x0)x0 which unfortunately is one step behind. 9967 !-------------------------------------------------------------------------- 9968 IF(PRESENT(Matrix)) THEN 9969 A => Matrix 9970 ELSE 9971 A => Solver % Matrix 9972 END IF 9973 9974 IF(PRESENT(RHS)) THEN 9975 b => RHS 9976 ELSE 9977 b => Solver % Matrix % rhs 9978 END IF 9979 9980 ALLOCATE(r(n)) 9981 r=0._dp 9982 9983 IF (Parenv % Pes>1) THEN 9984 ALLOCATE( TmpRHSVec(n), TmpXVec(n) ) 9985 9986 nn = A % ParMatrix % SplittedMatrix % InsideMatrix % NumberOfRows 9987 9988 TmpRhsVec = b 9989 CALL ParallelInitSolve( A, tmpXVec, TmpRhsVec, r) 9990 9991 tmpXvec = x0(1:n) 9992 CALL ParallelVector(a,TmpXvec) 9993 CALL ParallelVector(A,tmpRhsvec) 9994 9995 CALL ParallelMatrixVector(A, TmpXvec, r) 9996 DO i=1,nn 9997 r(i) = r(i) - tmprhsvec(i) 9998 END DO 9999 10000 Change = ParallelNorm(nn,r) 10001 bNorm = ParallelNorm(nn,tmpRhsVec) 10002 ELSE 10003 CALL MatrixVectorMultiply( A, x0, r) 10004 DO i=1,n 10005 r(i) = r(i) - b(i) 10006 END DO 10007 Change = ComputeNorm(Solver, n, r) 10008 bNorm = ComputeNorm(Solver, n, b) 10009 END IF 10010 10011 10012 IF(.NOT. ConvergenceAbsolute) THEN 10013 IF(bNorm > 0.0) THEN 10014 Change = Change / bNorm 10015 END IF 10016 END IF 10017 DEALLOCATE(r) 10018 10019 CASE('linear system residual') 10020 !-------------------------------------------------------------------------- 10021 ! Here the true linear system residual r=b(x0)-A(x0)x is computed. 10022 ! This option is useful for certain special solvers. 10023 !-------------------------------------------------------------------------- 10024 A => Solver % Matrix 10025 b => Solver % Matrix % rhs 10026 10027 IF (ParEnv % Pes > 1) THEN 10028 10029 ALLOCATE( TmpRHSVec(n), TmpXVec(n), TmpRVec(n) ) 10030 TmpRHSVec(1:n) = b(1:n) 10031 TmpXVec(1:n) = x(1:n) 10032 TmpRVec(1:n) = 0.0d0 10033 10034 CALL ParallelVector(A, TmpRHSVec) 10035 CALL ParallelVector(A, TmpXVec) 10036 CALL SParMatrixVector( TmpXVec, TmpRVec, ipar ) 10037 10038 nn = A % ParMatrix % SplittedMatrix % InsideMatrix % NumberOfRows 10039 10040 DO i=1, nn 10041 TmpRVec(i) = TmpRHSVec(i) - TmpRVec(i) 10042 END DO 10043 10044 Change = ParallelNorm( nn, TmpRVec ) 10045 10046 IF(.NOT. ConvergenceAbsolute) THEN 10047 bNorm = ParallelNorm( nn, TmpRHSVec ) 10048 IF(bNorm > 0.0) THEN 10049 Change = Change / bNorm 10050 END IF 10051 END IF 10052 DEALLOCATE( TmpRHSVec, TmpXVec, TmpRVec ) 10053 ELSE 10054 ALLOCATE(r(n)) 10055 CALL MatrixVectorMultiply( A, x, r) 10056 DO i=1,n 10057 r(i) = r(i) - b(i) 10058 END DO 10059 Change = SQRT( DOT_PRODUCT( r(1:n), r(1:n) ) ) 10060 IF(.NOT. ConvergenceAbsolute) THEN 10061 bNorm = SQRT( DOT_PRODUCT( b(1:n), b(1:n) ) ) 10062 IF(bNorm > 0.0) THEN 10063 Change = Change / bNorm 10064 END IF 10065 END IF 10066 DEALLOCATE(r) 10067 END IF 10068 10069 CASE('solution') 10070 10071 ALLOCATE(r(n)) 10072 r = x(1:n)-x0(1:n) 10073 Change = ComputeNorm(Solver, n, r) 10074 IF( .NOT. ConvergenceAbsolute ) THEN 10075 IF( Norm + PrevNorm > 0.0) THEN 10076 Change = Change * 2.0_dp/ (Norm+PrevNorm) 10077 END IF 10078 END IF 10079 DEALLOCATE(r) 10080 10081 CASE('norm') 10082 10083 Change = ABS( Norm-PrevNorm ) 10084 IF( .NOT. ConvergenceAbsolute .AND. Norm + PrevNorm > 0.0) THEN 10085 Change = Change * 2.0_dp/ (Norm+PrevNorm) 10086 END IF 10087 10088 CASE DEFAULT 10089 CALL Warn(Caller,'Unknown convergence measure: '//TRIM(ConvergenceType)) 10090 10091 END SELECT 10092 10093 !-------------------------------------------------------------------------- 10094 ! Check for convergence: 0/1 10095 !-------------------------------------------------------------------------- 10096 IF(SteadyState) THEN 10097 PrevChange = Solver % Variable % SteadyChange 10098 Solver % Variable % SteadyChange = Change 10099 Tolerance = ListGetCReal( SolverParams,'Steady State Convergence Tolerance',Stat) 10100 IF( Stat ) THEN 10101 IF( Change <= Tolerance ) THEN 10102 Solver % Variable % SteadyConverged = 1 10103 ELSE 10104 Solver % Variable % SteadyConverged = 0 10105 END IF 10106 END IF 10107 10108 Tolerance = ListGetCReal( SolverParams,'Steady State Divergence Limit',Stat) 10109 IF( Stat .AND. Change > Tolerance ) THEN 10110 IF( IterNo > 1 .AND. Change > PrevChange ) THEN 10111 CALL Info(Caller,'Steady state iteration diverged over tolerance',Level=5) 10112 Solver % Variable % SteadyConverged = 2 10113 END IF 10114 END IF 10115 10116 Tolerance = ListGetCReal( SolverParams,'Steady State Exit Condition',Stat) 10117 IF( Stat .AND. Tolerance > 0.0 ) THEN 10118 CALL Info(Caller,'Nonlinear iteration condition enforced by exit condition',Level=6) 10119 Solver % Variable % SteadyConverged = 3 10120 END IF 10121 10122 ELSE 10123 PrevChange = Solver % Variable % NonlinChange 10124 Solver % Variable % NonlinChange = Change 10125 Solver % Variable % NonlinConverged = 0 10126 10127 MaxIter = ListGetInteger( SolverParams,'Nonlinear System Max Iterations',Stat) 10128 10129 Tolerance = ListGetCReal( SolverParams,'Nonlinear System Convergence Tolerance',Stat) 10130 IF( Stat ) THEN 10131 IF( Change <= Tolerance ) THEN 10132 Solver % Variable % NonlinConverged = 1 10133 ELSE IF( IterNo >= MaxIter ) THEN 10134 IF( ListGetLogical( SolverParams,'Nonlinear System Abort Not Converged',Stat ) ) THEN 10135 CALL Fatal(Caller,'Nonlinear iteration did not converge to tolerance') 10136 ELSE 10137 CALL Info(Caller,'Nonlinear iteration did not converge to tolerance',Level=6) 10138 ! Solver % Variable % NonlinConverged = 2 10139 END IF 10140 END IF 10141 END IF 10142 10143 Tolerance = ListGetCReal( SolverParams,'Nonlinear System Divergence Limit',Stat) 10144 IF( Stat .AND. Change > Tolerance ) THEN 10145 IF( ( IterNo > 1 .AND. Change > PrevChange ) .OR. ( IterNo >= MaxIter ) ) THEN 10146 IF( ListGetLogical( SolverParams,'Nonlinear System Abort Diverged',Stat ) ) THEN 10147 CALL Fatal(Caller,'Nonlinear iteration diverged over limit') 10148 ELSE 10149 CALL Info(Caller,'Nonlinear iteration diverged over limit',Level=6) 10150 Solver % Variable % NonlinConverged = 2 10151 END IF 10152 END IF 10153 END IF 10154 10155 Tolerance = ListGetCReal( SolverParams,'Nonlinear System Exit Condition',Stat) 10156 IF( Stat .AND. Tolerance > 0.0 ) THEN 10157 CALL Info(Caller,'Nonlinear iteration condition enforced by exit condition',Level=6) 10158 Solver % Variable % NonlinConverged = 3 10159 END IF 10160 10161 IF( Solver % Variable % NonlinConverged > 1 ) THEN 10162 MinIter = ListGetInteger( SolverParams,'Nonlinear System Min Iterations',Stat) 10163 IF( Stat .AND. IterNo < MinIter ) THEN 10164 CALL Info(Caller,'Enforcing continuation of iteration',Level=6) 10165 Solver % Variable % NonlinConverged = 0 10166 END IF 10167 END IF 10168 10169 IF( .NOT. Solver % NewtonActive ) THEN 10170 Tolerance = ListGetCReal( SolverParams, 'Nonlinear System Newton After Tolerance',Stat ) 10171 IF( Stat .AND. Change < Tolerance ) Solver % NewtonActive = .TRUE. 10172 END IF 10173 END IF 10174 10175 10176 IF(Relax .AND. .NOT. RelaxBefore) THEN 10177 x(1:n) = (1-Relaxation)*x0(1:n) + Relaxation*x(1:n) 10178 IF( RelativeP ) x(dofs:n:dofs) = x(dofs:n:dofs) + Poffset 10179 Solver % Variable % Norm = ComputeNorm(Solver,n,x) 10180 END IF 10181 10182 ! Steady state output is done in MainUtils 10183 SolverName = ListGetString( SolverParams, 'Equation',Stat) 10184 IF(.NOT. Stat) SolverName = Solver % Variable % Name 10185 10186 IF(SteadyState) THEN 10187 WRITE( Message, '(a,g15.8,g15.8,a)') & 10188 'SS (ITER='//TRIM(i2s(IterNo))//') (NRM,RELC): (',Norm, Change,& 10189 ' ) :: '// TRIM(SolverName) 10190 ELSE 10191 WRITE( Message, '(a,g15.8,g15.8,a)') & 10192 'NS (ITER='//TRIM(i2s(IterNo))//') (NRM,RELC): (',Norm, Change,& 10193 ' ) :: '// TRIM(SolverName) 10194 END IF 10195 CALL Info( Caller, Message, Level=3 ) 10196 10197 ! This provides a way to directly save the convergence data into an external 10198 ! file making it easier to follow the progress of Elmer simulation in other software. 10199 !------------------------------------------------------------------------------------ 10200 IF( ListGetLogical( CurrentModel % Simulation,'Convergence Monitor',Stat ) ) THEN 10201 CALL WriteConvergenceInfo() 10202 END IF 10203 10204 ! Optional a posteriori scaling for the computed fields 10205 ! May be useful for some floating systems where one want to impose some intergral 10206 ! constraints without actually using them. Then first use just one Dirichlet point 10207 ! and then fix the level a posteriori using this condition. 10208 !---------------------------------------------------------------------------------- 10209 DoIt = .FALSE. 10210 IF( SteadyState ) THEN 10211 DoIt = ListGetLogical( SolverParams,& 10212 'Nonlinear System Set Average Solution',Stat) 10213 ELSE 10214 DoIt = ListGetLogical( SolverParams,& 10215 'Linear System Set Average Solution',Stat) 10216 END IF 10217 IF( DoIt ) THEN 10218 IF( ParEnv % PEs > 1 ) THEN 10219 CALL Fatal(Caller,'Setting average value not implemented in parallel!') 10220 END IF 10221 Ctarget = ListGetCReal( SolverParams,'Average Solution Value',Stat) 10222 str = ListGetString( SolverParams,'Average Solution Weight Variable',Stat) 10223 IF( Stat ) THEN 10224 WeightVar => VariableGet( Solver % Mesh % Variables, str ) 10225 IF( .NOT. ASSOCIATED( WeightVar ) ) THEN 10226 CALL Fatal(Caller,'> Average Solution Weight < missing: '//TRIM(str)) 10227 END IF 10228 IF( SIZE(x) /= SIZE(WeightVar % Values ) ) THEN 10229 CALL Fatal(Caller,'Field and weight size mismatch: '//TRIM(str)) 10230 END IF 10231 Ctarget = Ctarget - SUM( WeightVar % Values * x ) / SUM( WeightVar % Values ) 10232 ELSE 10233 Ctarget = Ctarget - SUM(x) / SIZE(x) 10234 END IF 10235 x = x + Ctarget 10236 END IF 10237 10238 10239 ! Calculate derivative a.k.a. sensitivity 10240 DoIt = .FALSE. 10241 IF( SteadyState ) THEN 10242 DoIt = ListGetLogical( SolverParams,'Calculate Derivative',Stat ) 10243 ELSE 10244 DoIt = ListGetLogical( SolverParams,'Nonlinear Calculate Derivative',Stat ) 10245 END IF 10246 10247 IF( DoIt ) THEN 10248 IF( SteadyState ) THEN 10249 iterVar => VariableGet( Solver % Mesh % Variables, 'coupled iter' ) 10250 IterNo = NINT( iterVar % Values(1) ) 10251 ELSE 10252 iterVar => VariableGet( Solver % Mesh % Variables, 'nonlin iter' ) 10253 IterNo = NINT( iterVar % Values(1) ) 10254 END IF 10255 10256 Eps = 1.0_dp 10257 IF( IterNo > 1 ) THEN 10258 dtVar => VariableGet( Solver % Mesh % Variables, 'derivative eps' ) 10259 IF( ASSOCIATED( dtVar ) ) THEN 10260 eps = dtVar % Values(1) 10261 Stat = .TRUE. 10262 ELSE 10263 eps = ListGetCReal( SolverParams,'derivative eps',Stat) 10264 END IF 10265 IF(.NOT. Stat) THEN 10266 Eps = 1.0_dp 10267 CALL Info(Caller,'Derivative Eps not given, using one',Level=7) 10268 END IF 10269 END IF 10270 10271 str = GetVarname(Solver % Variable) // ' Derivative' 10272 VeloVar => VariableGet( Solver % Mesh % Variables, str ) 10273 IF( ASSOCIATED( VeloVar ) ) THEN 10274 CALL Info(Caller,'Computing variable:'//TRIM(str),Level=7) 10275 VeloVar % Values = (x - x0) / eps 10276 ELSE 10277 CALL Warn(Caller,'Derivative variable not present') 10278 END IF 10279 10280 END IF 10281 10282 IF(.NOT. SteadyState ) THEN 10283 CALL UpdateDependentObjects( Solver, .FALSE. ) 10284 END IF 10285 10286 10287 CONTAINS 10288 10289 SUBROUTINE WriteConvergenceInfo() 10290 10291 INTEGER :: ConvInds(5),ConvUnit 10292 CHARACTER(LEN=MAX_NAME_LEN) :: ConvFile 10293 LOGICAL, SAVE :: ConvVisited = .FALSE. 10294 10295 IF( ParEnv % MyPe /= 0 ) RETURN 10296 10297 ConvFile = ListGetString(CurrentModel % Simulation,& 10298 'Convergence Monitor File',Stat) 10299 IF(.NOT. Stat) ConvFile = 'convergence.dat' 10300 10301 IF( ConvVisited ) THEN 10302 OPEN(NEWUNIT=ConvUnit, FILE=ConvFile,STATUS='old',POSITION='append') 10303 ELSE 10304 OPEN(NEWUNIT=ConvUnit, File=ConvFile) 10305 WRITE(ConvUnit,'(A)') '! solver ss/ns timestep coupled nonlin norm change' 10306 ConvVisited = .TRUE. 10307 END IF 10308 10309 ConvInds = 0 10310 ConvInds(1) = Solver % SolverId 10311 10312 IF( SteadyState ) ConvInds(2) = 1 10313 10314 iterVar => VariableGet( Solver % Mesh % Variables, 'timestep' ) 10315 ConvInds(3) = NINT( iterVar % Values(1) ) 10316 10317 iterVar => VariableGet( Solver % Mesh % Variables, 'coupled iter' ) 10318 ConvInds(4) = NINT( iterVar % Values(1) ) 10319 10320 iterVar => VariableGet( Solver % Mesh % Variables, 'nonlin iter' ) 10321 ConvInds(5) = NINT( iterVar % Values(1) ) 10322 10323 WRITE(ConvUnit,'(5I8,2G16.8)') ConvInds,Norm,Change 10324 CLOSE(ConvUnit) 10325 10326 END SUBROUTINE WriteConvergenceInfo 10327 10328!------------------------------------------------------------------------------ 10329 END SUBROUTINE ComputeChange 10330!------------------------------------------------------------------------------ 10331 10332 10333 10334 10335!------------------------------------------------------------------------------ 10336!> Adaptive version for getting gaussian integration points. 10337!> Also saves some time in initializations. 10338!> Note: the routine uses the pointer to Solver to check whether definitions 10339!> need to be remade. 10340!---------------------------------------------------------------------------------------------- 10341 10342 FUNCTION GaussPointsAdapt( Element, Solver, PReferenceElement ) RESULT(IntegStuff) 10343 10344 IMPLICIT NONE 10345 TYPE(Element_t) :: Element 10346 TYPE(Solver_t), OPTIONAL, TARGET :: Solver 10347 LOGICAL, OPTIONAL :: PReferenceElement !< For switching to the p-version reference element 10348 TYPE( GaussIntegrationPoints_t ) :: IntegStuff !< Structure holding the integration points 10349 10350 CHARACTER(LEN=MAX_NAME_LEN) :: VarName, GaussDef 10351 TYPE(Solver_t), POINTER :: pSolver, prevSolver => NULL() 10352 TYPE(Variable_t), POINTER :: IntegVar 10353 INTEGER :: AdaptOrder, AdaptNp, Np, RelOrder 10354 REAL(KIND=dp) :: MinLim, MaxLim, MinV, MaxV, V 10355 LOGICAL :: UseAdapt, Found,ElementalRule 10356 INTEGER :: i,n,ElementalNp(8),prevVisited = -1 10357 LOGICAL :: Debug, InitDone 10358 10359 SAVE prevSolver, UseAdapt, MinLim, MaxLim, IntegVar, AdaptOrder, AdaptNp, RelOrder, Np, & 10360 ElementalRule, ElementalNp, prevVisited 10361 10362 IF( PRESENT( Solver ) ) THEN 10363 pSolver => Solver 10364 ELSE 10365 pSolver => CurrentModel % Solver 10366 END IF 10367 10368 !Debug = ( Element % ElementIndex == 1) 10369 10370 InitDone = ASSOCIATED( pSolver, prevSolver ) .AND. ( prevVisited == pSolver % TimesVisited ) 10371 10372 IF( .NOT. InitDone ) THEN 10373 RelOrder = ListGetInteger( pSolver % Values,'Relative Integration Order',Found ) 10374 AdaptNp = 0 10375 Np = ListGetInteger( pSolver % Values,'Number of Integration Points',Found ) 10376 10377 GaussDef = ListGetString( pSolver % Values,'Element Integration Points',ElementalRule ) 10378 IF( ElementalRule ) THEN 10379 CALL ElementalGaussRules( GaussDef ) 10380 END IF 10381 10382 VarName = ListGetString( pSolver % Values,'Adaptive Integration Variable',UseAdapt ) 10383 IF( UseAdapt ) THEN 10384 CALL Info('GaussPointsAdapt','Using adaptive gaussian integration rules',Level=7) 10385 IntegVar => VariableGet( pSolver % Mesh % Variables, VarName ) 10386 IF( .NOT. ASSOCIATED( IntegVar ) ) THEN 10387 CALL Fatal('GaussPointsAdapt','> Adaptive Integration Variable < does not exist') 10388 END IF 10389 IF( IntegVar % TYPE /= Variable_on_nodes ) THEN 10390 CALL Fatal('GaussPointsAdapt','Wrong type of integration variable!') 10391 END IF 10392 MinLim = ListGetCReal( pSolver % Values,'Adaptive Integration Lower Limit' ) 10393 MaxLim = ListGetCReal( pSolver % Values,'Adaptive Integration Upper Limit' ) 10394 AdaptNp = ListGetInteger( pSolver % Values,'Adaptive Integration Points',Found ) 10395 IF(.NOT. Found ) THEN 10396 AdaptOrder = ListGetInteger( pSolver % Values,'Adaptive Integration Order',Found ) 10397 END IF 10398 IF(.NOT. Found ) AdaptOrder = 1 10399 !PRINT *,'Adaptive Integration Strategy:',MinV,MaxV,AdaptOrder,AdaptNp 10400 END IF 10401 10402 prevSolver => pSolver 10403 prevVisited = pSolver % TimesVisited 10404 END IF 10405 10406 IF( UseAdapt ) THEN 10407 RelOrder = 0 10408 Np = 0 10409 10410 n = Element % TYPE % NumberOfNodes 10411 MinV = MINVAL( IntegVar % Values( IntegVar % Perm( Element % NodeIndexes(1:n) ) ) ) 10412 MaxV = MAXVAL( IntegVar % Values( IntegVar % Perm( Element % NodeIndexes(1:n) ) ) ) 10413 10414 IF( .NOT. ( MaxV < MinLim .OR. MinV > MaxLim ) ) THEN 10415 RelOrder = AdaptOrder 10416 Np = AdaptNp 10417 END IF 10418 END IF 10419 10420 !IF( Debug ) PRINT *,'Adapt',UseAdapt,Element % ElementIndex, n,MaxV,MinV,MaxLim,MinLim,Np,RelOrder 10421 10422 IF( ElementalRule ) THEN 10423 Np = ElementalNp( Element % TYPE % ElementCode / 100 ) 10424 END IF 10425 10426 IF( Np > 0 ) THEN 10427 IntegStuff = GaussPoints( Element, Np = Np, PReferenceElement = PReferenceElement ) 10428 ELSE IF( RelOrder /= 0 ) THEN 10429 IntegStuff = GaussPoints( Element, RelOrder = RelOrder, PReferenceElement = PReferenceElement ) 10430 ELSE 10431 IntegStuff = GaussPoints( Element, PReferenceElement = PReferenceElement ) 10432 END IF 10433 10434 !IF( Debug ) PRINT *,'Adapt real nodes',IntegStuff % n 10435 10436 10437 CONTAINS 10438 10439!------------------------------------------------------------------------------ 10440 SUBROUTINE ElementalGaussRules(GaussDef) 10441!------------------------------------------------------------------------------ 10442 CHARACTER(LEN=*) :: GaussDef 10443!------------------------------------------------------------------------------ 10444 INTEGER :: i,j,k,n,m 10445 10446 10447 n = LEN_TRIM(GaussDef) 10448 ElementalNp = 0 10449 10450 ! PRINT *,'gauss def:',GaussDef(1:n) 10451 10452 DO i=2,8 10453 j = 0 10454 SELECT CASE( i ) 10455 CASE( 2 ) 10456 j = INDEX( GaussDef(1:n), '-line' ) ! position of string "-line" 10457 m = 5 ! length of string "-line" 10458 CASE( 3 ) 10459 j = INDEX( GaussDef(1:n), '-tri' ) 10460 m = 4 10461 CASE( 4 ) 10462 j = INDEX( GaussDef(1:n), '-quad' ) 10463 m = 5 10464 CASE( 5 ) 10465 j = INDEX( GaussDef(1:n), '-tetra' ) 10466 m = 6 10467 CASE( 6 ) 10468 j = INDEX( GaussDef(1:n), '-pyramid' ) 10469 m = 8 10470 CASE( 7 ) 10471 j = INDEX( GaussDef(1:n), '-prism' ) 10472 m = 6 10473 CASE( 8 ) 10474 j = INDEX( GaussDef(1:n), '-brick' ) 10475 m = 6 10476 END SELECT 10477 10478 IF( j > 0 ) THEN 10479 READ( GaussDef(j+m:n), * ) k 10480 ElementalNp(i) = k 10481 END IF 10482 END DO 10483 10484 ! PRINT *,'Elemental Gauss Rules:',ElementalNp 10485 10486!------------------------------------------------------------------------------ 10487 END SUBROUTINE ElementalGaussRules 10488!------------------------------------------------------------------------------ 10489 10490 10491 END FUNCTION GaussPointsAdapt 10492!------------------------------------------------------------------------------ 10493 10494 10495!------------------------------------------------------------------------------ 10496!> Checks stepsize of a linear system so that the error has decreased. 10497!> Various indicatators and search algorithms have been implemented, 10498!------------------------------------------------------------------------------ 10499 FUNCTION CheckStepSize(Solver,FirstIter,& 10500 nsize,values,values0) RESULT ( ReduceStep ) 10501!------------------------------------------------------------------------------ 10502 TYPE(Solver_t) :: Solver 10503 LOGICAL :: FirstIter 10504 INTEGER, OPTIONAL :: nsize 10505 REAL(KIND=dp), OPTIONAL, TARGET :: values(:), values0(:) 10506 LOGICAL :: ReduceStep 10507!------------------------------------------------------------------------------ 10508 INTEGER :: MaxTests=0,tests,MaxNonlinIter,NonlinIter, Dofs 10509 REAL(KIND=dp) :: Residual0, Residual1, Residual 10510 INTEGER :: i,n,m,ForceDof, SearchMode, CostMode, iter = 0 10511 TYPE(Matrix_t), POINTER :: A, MP 10512 TYPE(Variable_t), POINTER :: IterVar, Var 10513 REAL(KIND=dp), POINTER :: b(:), x(:), x0(:), r(:), x1(:), x2(:), mr(:), mx(:), mb(:) 10514 REAL(KIND=dp) :: Norm, PrevNorm, rNorm, bNorm, Relaxation, Alpha, Myy, & 10515 NonlinTol, LineTol, Cost0(4), Cost1(4), Cost(4), OrthoCoeff, x0norm, x1norm, Change, & 10516 LinTol 10517 REAL(KIND=dp), ALLOCATABLE :: TempRHS(:) 10518 INTEGER, POINTER :: Indexes(:) 10519 LOGICAL :: Stat, Init, Newton, Ortho, Debug, SaveToFile 10520 CHARACTER(LEN=MAX_NAME_LEN) :: SolverName, ConvergenceType, FileName 10521 TYPE(ValueList_t), POINTER :: SolverParams 10522 10523 10524 SAVE SolverParams, Alpha, Myy, Relaxation, MaxTests, tests, & 10525 Residual, NonlinTol, LinTol, x1, x0, LineTol, CostMode, SearchMode, & 10526 Cost0, Residual0, Cost1, n, Dofs, ForceDof, Ortho, Newton, & 10527 ConvergenceType, Norm, PrevNorm, iter, FileName, SaveToFile 10528 10529 Debug = .FALSE. 10530 10531 SolverParams => Solver % Values 10532 Var => Solver % Variable 10533 Dofs = Var % Dofs 10534 10535 IF(PRESENT(values)) THEN 10536 x => values 10537 ELSE 10538 x => Var % Values 10539 END IF 10540 10541 10542 ! Assembly the vectors, if needed, and 10543 ! also at first time get the line search parameters. 10544 !---------------------------------------------------- 10545 IF( FirstIter ) THEN 10546 CALL Info('CheckStepSize','Initializing step-size search',Level=6) 10547 10548 IF(PRESENT(nsize)) THEN 10549 n = nsize 10550 ELSE 10551 n = SIZE(x) 10552 END IF 10553 10554 IF( ASSOCIATED( x0 ) ) THEN 10555 IF( SIZE(x0) /= n ) DEALLOCATE( x0 ) 10556 END IF 10557 10558 IF( PRESENT( values0 ) ) THEN 10559 x0 => values0 10560 ELSE 10561 IF( .NOT. ASSOCIATED( x0 ) ) THEN 10562 ALLOCATE( x0(n) ) 10563 END IF 10564 END IF 10565 10566 IF( ASSOCIATED( x1 ) ) THEN 10567 IF( SIZE(x1) /= n ) DEALLOCATE( x1 ) 10568 END IF 10569 IF( .NOT. ASSOCIATED( x1 ) ) THEN 10570 ALLOCATE( x1(n) ) 10571 END IF 10572 10573 Norm = 0.0_dp 10574 Var % NonlinConverged = 0 10575 Var % NonlinChange = 1.0_dp 10576 10577 ! 1 - Residual norm : |Ax-b| 10578 ! 2 - Quadratic functional : x^T(Ax-2b)/2 10579 ! 3 - Weighted residual : x^T(Ax-b) 10580 ! 4 - Lumped force : SUM(r_i) 10581 !------------------------------------------------------------ 10582 CostMode = ListGetInteger( SolverParams,'Nonlinear System Linesearch Cost Mode',Stat) 10583 IF(.NOT. Stat) CostMode = 1 10584 10585 ! 1 - Armijo-Goldstein criterion & successive relaxation 10586 ! 2 - Minimize cost by bisection 10587 ! 3 - Find the zero cost by bisection 10588 !------------------------------------------------------------ 10589 SearchMode = ListGetInteger( SolverParams,'Nonlinear System Linesearch Search Mode',Stat) 10590 IF(.NOT. Stat) SearchMode = 1 10591 10592 ! Should the search direction be orthogonalized 10593 !----------------------------------------------------------- 10594 Ortho = ListGetLogical( SolverParams,'Nonlinear System Linesearch Orthogonal',Stat) 10595 10596 ! Is the outer ieration performed by Newton i.e. the search 10597 ! should always be differential. 10598 !----------------------------------------------------------- 10599 Newton = ListGetLogical( SolverParams,'Nonlinear System Linesearch Newton',Stat) 10600 10601 NonlinTol = ListGetConstReal( SolverParams, & 10602 'Nonlinear System Convergence Tolerance', Stat ) 10603 LinTol = ListGetConstReal( SolverParams, & 10604 'Linear System Convergence Tolerance', Stat ) 10605 10606 MaxNonlinIter = ListGetInteger( SolverParams,& 10607 'Nonlinear System Max Iterations',Stat) 10608 IF( MaxNonlinIter <= 2 ) THEN 10609 CALL Warn('CheckStepSize','For linesearch to work the nonlin iterations should be larger: '& 10610 //I2S(MaxNonlinIter)) 10611 END IF 10612 10613 ConvergenceType = ListGetString(SolverParams,& 10614 'Nonlinear System Convergence Measure',Stat) 10615 IF(.NOT. Stat) ConvergenceType = 'norm' 10616 10617 ! Parameters related to line search algorithms 10618 !------------------------------------------------ 10619 MaxTests = ListGetInteger( SolverParams,& 10620 'Nonlinear System Linesearch Iterations',Stat) 10621 IF( .NOT. Stat ) MaxTests = 10 10622 10623 Myy = ListGetConstReal( SolverParams, & 10624 'Nonlinear System Linesearch Limit', Stat ) 10625 IF(.NOT. Stat) Myy = 0.5_dp 10626 10627 Relaxation = ListGetConstReal( SolverParams, & 10628 'Nonlinear System Linesearch Factor', Stat ) 10629 IF(.NOT. Stat) Relaxation = 0.5_dp 10630 10631 LineTol = ListGetConstReal( SolverParams, & 10632 'Nonlinear System Linesearch Tolerance', Stat ) 10633 10634 ForceDof = ListGetInteger( SolverParams, & 10635 'Nonlinear System Linesearch Force Index', Stat ) 10636 IF(.NOT. Stat) ForceDof = Dofs 10637 10638 FileName = ListGetString( SolverParams, & 10639 'Nonlinear System Linesearch Filename', SaveToFile ) 10640 10641 ! Computation of nonlinear change is now done with this routine 10642 ! so skip computing the change in the standard slot. 10643 !--------------------------------------------------------------- 10644 CALL ListAddLogical(SolverParams,& 10645 'Skip Compute Nonlinear Change',.TRUE.) 10646 END IF 10647 10648 !-------------------------------------------------------------------------- 10649 ! This is the real residual: r=b-Ax 10650 ! We hope to roughly minimize L2 norm of r, or some related quantity 10651 !-------------------------------------------------------------------------- 10652 A => Solver % Matrix 10653 b => Solver % Matrix % rhs 10654 10655 ALLOCATE(r(n)) 10656 IF (Parenv % Pes>1) THEN 10657 ALLOCATE(TempRHS(n)) 10658 r = 0._dp 10659 TempRHS(1:n) = b(1:n) 10660 CALL ParallelInitSolve( A, x, TempRHS, r ) 10661 10662 MP => ParallelMatrix(A,mx,mb,mr) 10663 m = MP % NumberOfRows 10664 10665 CALL ParallelMatrixVector( A, mx, r) 10666 r(1:m) = r(1:m) - TempRHS(1:m) 10667 Residual= ParallelNorm(n,r) 10668 ELSE 10669 CALL MatrixVectorMultiply( A, x, r) 10670 r(1:n) = r(1:n) - b(1:n) 10671 Residual = ComputeNorm(Solver, n, r) 10672 END IF 10673 10674 ! Currently we compute all the costs to make it easier to study the 10675 ! behavior of different measures when doing linesearch. 10676 IF( .TRUE. ) THEN 10677 Cost(1) = Residual 10678 Cost(2) = SUM( 0.5_dp * x(1:n) * ( r(1:n) - b(1:n) ) ) 10679 Cost(3) = SUM( x(1:n) * r(1:n) ) 10680 Cost(4) = SUM( r(ForceDof::Dofs) ) 10681 ELSE 10682 IF( CostMode == 1 ) THEN 10683 Cost(1) = Residual 10684 ELSE IF( CostMode == 2 ) THEN 10685 Cost(2) = SUM( 0.5_dp * x(1:n) * ( r(1:n) - b(1:n) ) ) 10686 ELSE IF( CostMode == 3 ) THEN 10687 Cost(3) = SUM( x(1:n) * r(1:n) ) 10688 ELSE IF( CostMode == 4 ) THEN 10689 Cost(4) = SUM( r(ForceDof::Dofs) ) 10690 ELSE 10691 CALL Fatal('CheckStepSize','Unknown CostMode: '//TRIM(I2S(SearchMode))) 10692 END IF 10693 DEALLOCATE(r) 10694 END IF 10695 10696 WRITE( Message,'(A,4ES15.7)') 'Cost: ',Cost 10697 CALL Info('CheckStepSize',Message,Level=8) 10698 10699 ! At first iteration we cannot really do anything but go further 10700 ! and save the reference residual for comparison. 10701 !----------------------------------------------------------------------------- 10702 IF( FirstIter ) THEN 10703 Tests = 0 10704 ReduceStep = .FALSE. 10705 x0(1:n) = x(1:n) 10706 Cost0 = Cost 10707 Residual0 = Residual 10708 10709 IF( Debug ) THEN 10710 PRINT *,'x0 range: ',MINVAL(x0),MAXVAL(x0) 10711 PRINT *,'b0 range: ',MINVAL(b),MAXVAL(b) 10712 PRINT *,'Cost0: ',Cost0 10713 END IF 10714 10715 IF( SaveToFile ) THEN 10716 CALL Info('CheckStepSize','Saving step information into file: '& 10717 //TRIM(FileName),Level=10) 10718 OPEN( 10, FILE = FileName, STATUS='UNKNOWN' ) 10719 i = 0 10720 WRITE (10,'(2I6,5ES15.7)') Tests,i,Alpha,Cost 10721 CLOSE( 10 ) 10722 END IF 10723 10724 10725 RETURN 10726 END IF 10727 10728 Tests = Tests + 1 10729 10730 IF( Tests == 1 ) THEN 10731 ! Started with no relaxation 10732 !--------------------------- 10733 x1 = x 10734 Alpha = 1.0_dp 10735 Cost1 = Cost 10736 10737 ! This is just debugging code waiting to be reused 10738 IF( .FALSE. ) THEN 10739 iter = iter + 1 10740 10741 PRINT *,'Iter: ',iter 10742 NULLIFY( x2 ) 10743 ALLOCATE( x2(n/2) ) 10744 x2 = x(1::2) 10745 CALL VariableAdd( Solver % Mesh % Variables, Solver % Mesh, Solver, & 10746 'xiter '//TRIM(I2S(iter)),1,x2,Solver % Variable % Perm ) 10747 PRINT *,'Xiter range:',MINVAL(x2),MAXVAL(x2) 10748 NULLIFY(x2) 10749 10750! NULLIFY( x2 ) 10751! ALLOCATE( x2(n/2) ) 10752! x2 = x(2::2) 10753! CALL VariableAdd( Solver % Mesh % Variables, Solver % Mesh, Solver, & 10754! 'yiter '//TRIM(I2S(iter)),1,x2,Solver % Variable % Perm ) 10755! NULLIFY(x2) 10756 END IF 10757 10758 IF( Debug ) THEN 10759 PRINT *,'b1 range: ',MINVAL(b),MAXVAL(b) 10760 PRINT *,'x1 range: ',MINVAL(x1),MAXVAL(x1) 10761 PRINT *,'Cost1: ',Cost1 10762 END IF 10763 10764 ! Orthonormalization: 10765 ! The direction 'x0' has already been exhausted so remove that from 'x1' 10766 !----------------------------------------------------------------------- 10767 x0norm = ComputeNorm( Solver, n, x0 ) 10768 IF( Ortho ) THEN 10769 IF( x0norm > EPSILON( x0norm ) ) THEN 10770 OrthoCoeff = SUM(x1*x0) / ( x0norm**2 ) 10771 x1 = x1 - OrthoCoeff * x0 10772 END IF 10773 ELSE 10774 ! This basically checks whether the new and old solution is so 10775 ! close that there is no point of finding better solution. 10776 x1 = x1 - x0 10777 x1norm = ComputeNorm(Solver, n, x1) 10778 IF( x1norm < LinTol * x0norm ) THEN 10779 ReduceStep = .FALSE. 10780 GOTO 100 10781 END IF 10782 END IF 10783 10784 IF( Debug ) THEN 10785 PRINT *,'x1 range orto: ',MINVAL(x1),MAXVAL(x1) 10786 END IF 10787 END IF 10788 10789 ! Armijo-GoldStein Criterion for accepting stepsize 10790 !----------------------------------------------------------------- 10791 IF( SearchMode == 1 ) THEN 10792 ReduceStep = ArmijoGoldsteinSearch(Tests, Alpha ) 10793 ELSE IF( SearchMode == 2 ) THEN 10794 ReduceStep = BisectMinimumSearch(Tests, Alpha) 10795 ELSE IF( SearchMode == 3 ) THEN 10796 ReduceStep = BisectZeroSearch(Tests, Alpha) 10797 ELSE 10798 CALL Fatal('CheckStepSize','Unknown SearchMode: '//TRIM(I2S(SearchMode))) 10799 END IF 10800 10801 10802 IF( SaveToFile ) THEN 10803 CALL Info('CheckStepSize','Saving step information into file: '& 10804 //TRIM(FileName),Level=10) 10805 OPEN( 10, FILE = FileName, POSITION='APPEND',STATUS='OLD' ) 10806 IF( ReduceStep ) THEN 10807 i = 0 10808 ELSE 10809 i = 1 10810 END IF 10811 10812 WRITE (10,'(2I6,5ES13.6)') Tests,i,Alpha,Cost 10813 CLOSE( 10 ) 10814 END IF 10815 10816 10817 10818100 IF( ReduceStep ) THEN 10819 IF( Tests >= MaxTests .AND. ReduceStep ) THEN 10820 CALL Fatal('CheckStepSize','Maximum number of linesearch steps taken without success!') 10821 ReduceStep = .FALSE. 10822 END IF 10823 10824 ! New candidate 10825 x(1:n) = x0(1:n) + Alpha * x1(1:n) 10826 10827 WRITE(Message,'(A,I0,A,g15.6)') 'Step ',Tests,' rejected, trying new extent: ',Alpha 10828 CALL Info( 'CheckStepSize',Message,Level=6 ) 10829 ELSE ! accept step 10830 WRITE(Message,'(A,I0,A,g15.6)') 'Step ',Tests,' accepted with extent: ',Alpha 10831 CALL Info( 'CheckStepSize',Message,Level=6 ) 10832 10833 ! Chosen candidate 10834 x(1:n) = x0(1:n) + Alpha * x1(1:n) 10835 10836 PrevNorm = Norm 10837 Norm = ComputeNorm(Solver, n, x) 10838 10839 IF( ConvergenceType == 'residual') THEN 10840 bNorm = ComputeNorm(Solver, n, b) 10841 IF( bNorm > 0.0_dp ) Change = Residual / bNorm 10842 ELSE 10843 Change = ABS( Norm-PrevNorm ) 10844 IF( Norm + PrevNorm > 0.0) THEN 10845 Change = Change * 2.0_dp / ( Norm + PrevNorm ) 10846 END IF 10847 END IF 10848 10849 Solver % Variable % NonlinChange = Change 10850 Solver % Variable % Norm = Norm 10851 10852 IF( Solver % Variable % NonlinChange < NonlinTol ) THEN 10853 Solver % Variable % NonlinConverged = 1 10854 END IF 10855 10856 SolverName = ListGetString( SolverParams, 'Equation',Stat) 10857 IF(.NOT. Stat) SolverName = Solver % Variable % Name 10858 10859 IterVar => VariableGet( Solver % Mesh % Variables, 'nonlin iter') 10860 m = NINT(IterVar % Values(1)) 10861 10862 ! This replaces the standard error output usually written by the ComputeChange 10863 WRITE( Message, '(a,g15.8,g15.8,a)') & 10864 'NS (ITER='//TRIM(i2s(m))//') (NRM,RELC): (',Norm, Change, & 10865 ' ) :: '// TRIM(SolverName) 10866 CALL Info( 'CheckStepSize', Message, Level=3 ) 10867 10868 WRITE(Message,'(A,I0,A,g15.6)') 'Step accepted after ',tests,' trials: ',Alpha 10869 CALL Info( 'CheckStepSize',Message,Level=5 ) 10870 WRITE(Message,'(A,g15.6)') 'Previous cost:',Cost0(CostMode) 10871 CALL Info( 'CheckStepSize',Message,Level=6 ) 10872 WRITE(Message,'(A,g15.6)') 'Initial cost: ',Cost1(CostMode) 10873 CALL Info( 'CheckStepSize',Message,Level=6 ) 10874 WRITE(Message,'(A,g15.6)') 'Final cost: ',Cost(CostMode) 10875 CALL Info( 'CheckStepSize',Message,Level=6 ) 10876 10877 Tests = 0 10878 x0 = x 10879 10880 IF( Debug ) THEN 10881 PRINT *,'x0 range: ',MINVAL(x0),MAXVAL(x0) 10882 PRINT *,'Cost0: ',Cost0 10883 PRINT *,'Residual0: ',Residual0 10884 END IF 10885 10886 IF( Newton ) FirstIter = .TRUE. 10887 10888 END IF 10889 10890 10891 10892 CONTAINS 10893 10894!----------------------------------------------------------------- 10895!> Armijo-GoldStein Criterion for accepting stepsize 10896!----------------------------------------------------------------- 10897 FUNCTION ArmijoGoldsteinSearch(Tests,Alpha) RESULT ( ReduceStep ) 10898 10899 INTEGER :: Tests 10900 REAL(KIND=dp) :: Alpha 10901 LOGICAL :: ReduceStep 10902 10903 ReduceStep = ( Cost(CostMode) > ( 1.0_dp - Myy * Alpha ) * Cost0(CostMode) ) 10904 IF( ReduceStep ) THEN 10905 Alpha = Alpha * Relaxation 10906 ELSE 10907 Cost0 = Cost 10908 Residual0 = Residual 10909 END IF 10910 10911 END FUNCTION ArmijoGoldsteinSearch 10912 10913 10914!------------------------------------------------------------------------------- 10915!> Choose next parameter set from 1D bisection search 10916!------------------------------------------------------------------------------- 10917 10918 FUNCTION BisectMinimumSearch(Tests, Alpha) RESULT ( ReduceStep ) 10919 10920 INTEGER :: Tests 10921 REAL(KIND=dp) :: Alpha 10922 LOGICAL :: ReduceStep 10923 10924 INTEGER :: i,j,k 10925 REAL(KIND=dp) :: step, p(3),c(3),r(3),raid,beta 10926 10927 SAVE step, p, c, r 10928 10929 ReduceStep = .TRUE. 10930 10931 IF(Tests == 1) THEN 10932 p(1) = 0.0_dp 10933 c(1) = Cost0(CostMode) 10934 r(1) = Residual0 10935 10936 p(2) = 1.0_dp 10937 c(2) = Cost(CostMode) 10938 r(2) = Residual 10939 10940 step = 0.25_dp 10941 Alpha = 0.5_dp 10942 RETURN 10943 ELSE 10944 p(3) = Alpha 10945 c(3) = Cost(CostMode) 10946 r(3) = Residual 10947 END IF 10948 10949 10950 ! Order the previous points so that p1 < p2 < p3 10951 DO k=1,2 10952 DO i=k+1,3 10953 IF(p(i) < p(k)) THEN 10954 raid = p(k) 10955 p(k) = p(i) 10956 p(i) = raid 10957 10958 raid = c(k) 10959 c(k) = c(i) 10960 c(i) = raid 10961 10962 raid = r(k) 10963 r(k) = r(i) 10964 r(i) = raid 10965 END IF 10966 END DO 10967 END DO 10968 10969 IF( Debug ) THEN 10970 PRINT *,'Bisect p:',p 10971 PRINT *,'Bisect c:',c 10972 PRINT *,'Bisect r:',r 10973 END IF 10974 10975 ! The value of alpha already known accurately 10976 IF( MAXVAL(p)-MINVAL(p) < LineTol ) THEN 10977 ! PRINT *,'cond1' 10978 ReduceStep = .FALSE. 10979 END IF 10980 10981 ! The value of cost function small compared to absolute value of it 10982 IF( MAXVAL(c)-MINVAL(c) < LineTol * MINVAL( ABS(c) ) ) THEN 10983 ! PRINT *,'cond2' 10984 ReduceStep = .FALSE. 10985 END IF 10986 10987 ! We can also use the residual as criterion for stopping 10988 IF( Residual < LineTol * Residual0 ) THEN 10989 ! PRINT *,'cond3' 10990 ReduceStep = .FALSE. 10991 END IF 10992 10993 ! Of these choose the one with smallest cost 10994 IF( .NOT. ReduceStep ) THEN 10995 i = 1 10996 DO k=2,3 10997 IF( c(k) < c(i) ) i = k 10998 END DO 10999 11000 Alpha = p(i) 11001 Residual0 = r(i) 11002 Cost0(CostMode) = c(i) 11003 ! PRINT *,'Choosing i',i,Alpha,Residual0,Cost0 11004 11005 RETURN 11006 END IF 11007 11008 11009 ! Monotonic line segment 11010 IF( (c(2)-c(1))*(c(3)-c(2)) > 0.0) THEN 11011 IF(c(3) < c(1)) THEN 11012 Alpha = p(3) + SIGN(step,p(3)-p(1)) 11013 c(1) = c(3) 11014 p(1) = p(3) 11015 r(1) = r(3) 11016 ELSE 11017 Alpha = p(1) + SIGN(step,p(1)-p(3)) 11018 END IF 11019 ELSE IF(c(2) < c(1) .OR. c(2) < c(3)) THEN 11020 IF(c(3) < c(1)) THEN 11021 c(1) = c(3) 11022 p(1) = p(3) 11023 r(1) = r(3) 11024 END IF 11025 step = (p(2)-p(1))/2.0d0 11026 Alpha = p(1) + SIGN(step,p(2)-p(1)) 11027 ELSE 11028 IF( Debug ) THEN 11029 PRINT *,'p:',p 11030 PRINT *,'c:',c,Cost0 11031 PRINT *,'r:',r,Residual0 11032 PRINT *,'dc',c(2)-c(1),c(3)-c(2) 11033 END IF 11034 11035 IF( MINVAL ( c ) < Cost0(CostMode) ) THEN 11036 i = 1 11037 DO k=2,3 11038 IF( c(k) < c(i) ) i = k 11039 END DO 11040 Alpha = p(i) 11041 Cost0(CostMode) = c(i) 11042 Residual0 = r(i) 11043 11044 CALL Warn('BisectSearch','Bisection method improved but faced local maximium') 11045 ReduceStep = .FALSE. 11046 ELSE 11047 IF( MINVAL ( r ) < Residual0 ) THEN 11048 CALL Warn('BisectSearch','Bisection method improved but faced local maximium') 11049 ELSE 11050 CALL Warn('BisectSearch','Bisection method cannot handle local maxima') 11051 END IF 11052 11053 i = 1 11054 DO k=2,3 11055 IF( r(k) < r(i) ) i = k 11056 END DO 11057 Alpha = p(i) 11058 Cost0(CostMode) = c(i) 11059 Residual0 = r(i) 11060 END IF 11061 11062 ReduceStep = .FALSE. 11063 END IF 11064 11065 ! Because alpha should be in limit [0,1] make the corrections 11066 ! If the orthogonalization is used then we don't have the luxury 11067 ! of setting the extent as nicely. 11068 !------------------------------------------------------------ 11069 IF( .NOT. Ortho ) THEN 11070 beta = alpha 11071 k = 0 11072 IF( Alpha < -EPSILON( Alpha ) ) THEN 11073 IF( p(1) < EPSILON( Alpha ) ) THEN 11074 step = (p(2)-p(1))/2.0_dp 11075 Alpha = p(1) + step 11076 k = 1 11077 ELSE 11078 Alpha = 0.0_dp 11079 k = 1 11080 END IF 11081 ELSE IF( Alpha > 1.0_dp + EPSILON( Alpha ) ) THEN 11082 IF( p(3) > 1.0_dp - EPSILON( Alpha ) ) THEN 11083 step = (p(3)-p(2))/2.0_dp 11084 Alpha = p(2) + step 11085 k = 2 11086 ELSE 11087 Alpha = 1.0_dp 11088 k = 3 11089 END IF 11090 END IF 11091 11092! IF( ABS( beta-alpha) > TINY(alpha)) PRINT *,'Extent change',Beta,Alpha 11093 END IF 11094 11095 END FUNCTION BisectMinimumSearch 11096 11097 11098!------------------------------------------------------------------------------- 11099!> Choose next parameter set from 1D bisection search 11100!------------------------------------------------------------------------------- 11101 FUNCTION BisectZeroSearch(Tests, Alpha) RESULT ( ReduceStep ) 11102 11103 INTEGER :: Tests 11104 REAL(KIND=dp) :: Alpha 11105 LOGICAL :: ReduceStep 11106 11107 INTEGER :: i,j,k 11108 REAL(KIND=dp) :: step, p(3),c(3),paid,caid,beta 11109 11110 SAVE step, p, c 11111 11112 ReduceStep = .TRUE. 11113 11114 IF(Tests == 1) THEN 11115 p(1) = 0.0_dp 11116 c(1) = Cost0(CostMode) 11117 11118 p(2) = 1.0_dp 11119 c(2) = Cost1(CostMode) 11120 11121 IF( Cost0(CostMode) * Cost1(CostMode) > 0.0_dp ) THEN 11122 CALL Warn('CostSearch','Lumped forces should have different sign!') 11123 END IF 11124 11125 Alpha = 0.5_dp 11126 RETURN 11127 ELSE 11128 p(3) = Alpha 11129 c(3) = Cost(CostMode) 11130 END IF 11131 11132 ! Order the previous points so that p1 < p2 < p3 11133 DO k=1,2 11134 DO i=k+1,3 11135 IF(p(i) < p(k)) THEN 11136 paid = p(k) 11137 p(k) = p(i) 11138 p(i) = paid 11139 caid = c(k) 11140 c(k) = c(i) 11141 c(i) = caid 11142 END IF 11143 END DO 11144 END DO 11145 11146 IF( Debug ) THEN 11147 PRINT *,'Cost p:',p 11148 PRINT *,'Cost c:',c 11149 END IF 11150 11151 IF( p(3)-p(1) < LineTol ) THEN 11152 ReduceStep = .FALSE. 11153 RETURN 11154 END IF 11155 11156 ! Zero value is between 1st interval 11157 IF( c(1)*c(2) < 0.0_dp ) THEN 11158 Alpha = (p(1)+p(2))/2.0_dp 11159 ELSE IF ( c(2)*c(3) < 0.0_dp ) THEN 11160 Alpha = (p(2)+p(3))/2.0_dp 11161 11162 ! We don't need 1st values, but we do need 3rd 11163 p(1) = p(3) 11164 c(1) = c(3) 11165 ELSE 11166 CALL Fatal('ForceSearch','Lumped forces should have different sign!') 11167 END IF 11168 11169 END FUNCTION BisectZeroSearch 11170 11171!------------------------------------------------------------------------------ 11172 END FUNCTION CheckStepSize 11173!------------------------------------------------------------------------------ 11174 11175 11176!------------------------------------------------------------------------------ 11177!> Apply Anderson acceleration to the solution of nonlinear system. 11178!> Also may apply acceleration to the linear system. 11179!------------------------------------------------------------------------------ 11180 SUBROUTINE NonlinearAcceleration(A,x,b,Solver,PreSolve,NoSolve) 11181 TYPE(Matrix_t), POINTER :: A 11182 REAL(KIND=dp) CONTIG :: b(:),x(:) 11183 TYPE(Solver_t) :: Solver 11184 LOGICAL :: PreSolve 11185 LOGICAL, OPTIONAL :: NoSolve 11186 !------------------------------------------------------------------------------ 11187 ! We have a special stucture for the iterates and residuals so that we can 11188 ! cycle over the pointers instead of the values. 11189 TYPE AndersonVect_t 11190 LOGICAL :: Additive 11191 REAL(KIND=dp), POINTER :: Iterate(:), Residual(:), Ax(:) 11192 INTEGER :: tag 11193 END TYPE AndersonVect_t 11194 TYPE(AndersonVect_t), ALLOCATABLE :: AndersonBasis(:), AndersonTmp 11195 INTEGER :: AndersonInterval, ItersCnt, AndersonVecs, VecsCnt, iter, n,i,j,k 11196 TYPE(Variable_t), POINTER :: iterV, Svar 11197 REAL(KIND=dp), ALLOCATABLE :: Alphas(:),AxTable(:,:),TmpVec(:) 11198 REAL(KIND=dp) :: Nrm, AndersonRelax 11199 LOGICAL :: Found, DoRelax, KeepBasis, Visited = .FALSE., Parallel 11200 INTEGER :: LinInterval 11201 INTEGER :: PrevSolverId = -1 11202 11203 SAVE AndersonBasis, TmpVec, Alphas, ItersCnt, AndersonInterval, VecsCnt, AndersonVecs, & 11204 PrevSolverId, AxTable, AndersonRelax, DoRelax, Visited, KeepBasis, LinInterval 11205 11206 IF( PreSolve ) THEN 11207 CALL Info('NonlinearAcceleration','Performing pre-solution steps',Level=8) 11208 ELSE 11209 CALL Info('NonlinearAcceleration','Performing post-solution steps',Level=8) 11210 END IF 11211 11212 Parallel = ( ParEnv % PEs > 1 ) 11213 11214 iterV => VariableGet( Solver % Mesh % Variables, 'nonlin iter' ) 11215 iter = NINT(iterV % Values(1)) 11216 11217 IF(PRESENT(NoSolve)) NoSolve = .FALSE. 11218 11219 n = A % NumberOfRows 11220 11221 IF(.NOT. Visited ) THEN 11222 PrevSolverId = Solver % SolverId 11223 CALL Info('NonlinearAcceleration','Allocating structures for solution history',Level=8) 11224 11225 AndersonInterval = ListGetInteger( Solver % Values,& 11226 'Nonlinear System Acceleration Interval',Found) 11227 LinInterval = ListGetInteger( Solver % Values,& 11228 'Linear System Acceleration Interval',Found) 11229 11230 AndersonVecs = MAX( AndersonInterval, LinInterval ) 11231 IF( AndersonVecs == 0 ) THEN 11232 CALL Fatal('NonlinearAcceleration','Both acceleration intervals are zero!') 11233 END IF 11234 11235 AndersonRelax = ListGetCReal( Solver % Values,& 11236 'Nonlinear System Acceleration Relaxation',DoRelax) 11237 KeepBasis = ListGetLogical( Solver % Values,& 11238 'Nonlinear System Acceleration Keep Vectors',Found) 11239 11240 ItersCnt = 0 ! relates to "AndersonInterval" 11241 VecsCnt = 0 ! relates to "AndersonVecs" 11242 11243 IF(.NOT. ALLOCATED( AndersonBasis ) ) THEN 11244 ALLOCATE( AndersonBasis(AndersonVecs) ) 11245 DO i=1,AndersonVecs 11246 ALLOCATE( AndersonBasis(i) % Residual(n), & 11247 AndersonBasis(i) % Iterate(n) ) 11248 AndersonBasis(i) % Residual = 0.0_dp 11249 AndersonBasis(i) % Iterate = 0.0_dp 11250 END DO 11251 ALLOCATE( TmpVec(n), Alphas(AndersonVecs) ) 11252 END IF 11253 Visited = .TRUE. 11254 END IF 11255 11256 IF( PrevSolverId /= Solver % SolverId ) THEN 11257 CALL Fatal('NonlinearAcceleration','Current implementation only supports one solver!') 11258 END IF 11259 11260 11261 IF( PreSolve ) THEN 11262 IF( iter == 1 ) THEN 11263 ItersCnt = 0 11264 IF( .NOT. KeepBasis ) VecsCnt = 0 11265 END IF 11266 11267 ItersCnt = ItersCnt + 1 11268 VecsCnt = VecsCnt + 1 11269 11270 ! Calculate the residual of the matrix equation 11271 ! Here 'x' comes before being modified hence A(x) is consistent. 11272 CALL MatrixVectorMultiply( A, x, TmpVec ) 11273 TmpVec = TmpVec - b 11274 11275 ! Add the iterate and residual to the basis vectors. 11276 ! This is fast as we operate with pointers mainly. 11277 AndersonTmp = AndersonBasis(AndersonVecs) 11278 DO i=AndersonVecs,2,-1 11279 AndersonBasis(i) = AndersonBasis(i-1) 11280 END DO 11281 AndersonBasis(1) = AndersonTmp 11282 AndersonBasis(1) % Residual = TmpVec 11283 AndersonBasis(1) % Iterate = x 11284 11285 ! Pure Anderson sweep is done every AndersonInterval iterations if we have full basis. 11286 IF(.NOT. DoRelax .AND. AndersonInterval > 0 ) THEN 11287 IF( VecsCnt >= AndersonVecs .AND. ItersCnt >= AndersonInterval ) THEN 11288 CALL AndersonMinimize( ) 11289 ItersCnt = 0 11290 IF(PRESENT(NoSolve)) NoSolve = .TRUE. 11291 RETURN 11292 END IF 11293 END IF 11294 11295 IF( LinInterval > 0 ) THEN 11296 CALL AndersonGuess() 11297 END IF 11298 ELSE 11299 ! Relaxation strategy is done after each linear solve. 11300 IF( DoRelax ) THEN 11301 CALL Info('NonlinearAcceleration','Minimizing residual using history data',Level=6) 11302 CALL AndersonMinimize( ) 11303 END IF 11304 END IF 11305 11306 CONTAINS 11307 11308 11309 !------------------------------------------------------------------------------ 11310 FUNCTION Mydot( n, x, y ) RESULT(s) 11311 !------------------------------------------------------------------------------ 11312 INTEGER :: n 11313 REAL(KIND=dp) :: s 11314 REAL(KIND=dp) CONTIG :: x(:) 11315 REAL(KIND=dp) CONTIG, OPTIONAL :: y(:) 11316 !------------------------------------------------------------------------------ 11317 IF ( .NOT. Parallel ) THEN 11318 IF( PRESENT( y ) ) THEN 11319 s = DOT_PRODUCT( x(1:n), y(1:n) ) 11320 ELSE 11321 s = DOT_PRODUCT( x(1:n), x(1:n) ) 11322 END IF 11323 ELSE 11324 IF( PRESENT( y ) ) THEN 11325 s = ParallelDot( n, x, y ) 11326 ELSE 11327 s = ParallelDot( n, x, x ) 11328 END IF 11329 END IF 11330 !------------------------------------------------------------------------------ 11331 END FUNCTION Mydot 11332 !------------------------------------------------------------------------------ 11333 11334 11335 !------------------------------------------------------------------------------ 11336 SUBROUTINE Mymv( A, x, b, Update ) 11337 !------------------------------------------------------------------------------ 11338 REAL(KIND=dp) CONTIG :: x(:), b(:) 11339 TYPE(Matrix_t), POINTER :: A 11340 LOGICAL, OPTIONAL :: Update 11341 !------------------------------------------------------------------------------ 11342 IF ( .NOT. Parallel ) THEN 11343 CALL CRS_MatrixVectorMultiply( A, x, b ) 11344 ELSE 11345 IF ( PRESENT( Update ) ) THEN 11346 CALL ParallelMatrixVector( A,x,b,Update,ZeroNotOwned=.TRUE. ) 11347 ELSE 11348 CALL ParallelMatrixVector( A,x,b,ZeroNotOwned=.TRUE. ) 11349 END IF 11350 END IF 11351 !------------------------------------------------------------------------------ 11352 END SUBROUTINE Mymv 11353 !------------------------------------------------------------------------------ 11354 11355 11356 ! Given set of basis vectors and residuals find a new suggestion for solution. 11357 ! Either use as such or combine it to solution when relaxation is used. 11358 ! This is applied to boost nonlinear iteration. 11359 !------------------------------------------------------------------------------ 11360 SUBROUTINE AndersonMinimize() 11361 INTEGER ::m, n, AndersonMinn 11362 REAL(KIND=dp) :: rr, rb 11363 11364 m = MIN( ItersCnt, AndersonInterval ) 11365 11366 AndersonMinN = ListGetInteger( Solver % Values,& 11367 'Nonlinear System Acceleration First Iteration',Found ) 11368 IF(.NOT. (Found .OR. DoRelax)) AndersonMinN = AndersonInterval 11369 11370 ! Nothing to do 11371 IF( m < AndersonMinN ) RETURN 11372 11373 ! If size of our basis is just one, there is not much to do... 11374 ! We can only perform classical relaxation. 11375 IF( m == 1 ) THEN 11376 x = AndersonRelax * x + (1-AndersonRelax) * AndersonBasis(1) % Iterate 11377 RETURN 11378 END IF 11379 11380 ! If we are converged then the solution should already be the 1st component. 11381 ! Hence use that as the basis. 11382 Alphas(1) = 1.0_dp 11383 TmpVec = AndersonBasis(1) % Residual 11384 11385 ! Minimize the residual 11386 n = SIZE( AndersonBasis(1) % Residual ) 11387 DO k=2,m 11388 rr = MyDot( n, AndersonBasis(k) % Residual ) 11389 rb = MyDot( n, AndersonBasis(k) % Residual, TmpVec ) 11390 Alphas(k) = -rb / rr 11391 TmpVec = TmpVec + Alphas(k) * AndersonBasis(k) % Residual 11392 END DO 11393 11394 ! Normalize the coefficients such that the sum equals unity 11395 ! This way for example, Dirichlet BCs will be honored. 11396 Alphas = Alphas / SUM( Alphas(1:m) ) 11397 11398 IF( InfoActive(10) ) THEN 11399 DO i=1,m 11400 WRITE(Message,'(A,I0,A,ES12.3)') 'Alpha(',i,') = ',Alphas(i) 11401 CALL Info('NonlinearAcceleration',Message) 11402 END DO 11403 END IF 11404 11405 ! Create the new suggestion for the solution vector 11406 ! We take part of the suggested new solution vector 'x' and 11407 ! part of minimized residual that was used in anderson acceleration. 11408 IF( DoRelax ) THEN 11409 Alphas = Alphas * (1-AndersonRelax) 11410 x = AndersonRelax * x 11411 DO k=1,m 11412 x = x + Alphas(k) * AndersonBasis(k) % Iterate 11413 END DO 11414 ELSE 11415 x = Alphas(1) * AndersonBasis(1) % Iterate 11416 DO k=2,m 11417 x = x + Alphas(k) * AndersonBasis(k) % Iterate 11418 END DO 11419 END IF 11420 11421 END SUBROUTINE AndersonMinimize 11422 11423 11424 ! Given set of basis vectors and a linear system 11425 ! find a combincation of the vectors that minimizes the norm of the linear 11426 ! system. This may be used to provide a better initial guess for a linear system. 11427 !-------------------------------------------------------------------------------- 11428 SUBROUTINE AndersonGuess() 11429 INTEGER :: AndersonMinN 11430 11431 REAL(KIND=dp), POINTER, SAVE ::Betas(:), Ymat(:,:) 11432 LOGICAL, SAVE :: AllocationsDone = .FALSE. 11433 INTEGER :: i,j,m 11434 11435 IF(.NOT. AllocationsDone ) THEN 11436 m = LinInterval 11437 DO i=1,LinInterval 11438 ALLOCATE( AndersonBasis(i) % Ax(n) ) 11439 AndersonBasis(i) % Ax = 0.0_dp 11440 END DO 11441 ALLOCATE(Betas(m),Ymat(m,m)) 11442 AllocationsDone = .TRUE. 11443 END IF 11444 11445 m = MIN( VecsCnt, LinInterval ) 11446 11447 ! Calculate the residual of the matrix equation 11448 DO i=1,m 11449 CALL Mymv( A, AndersonBasis(i) % Iterate, AndersonBasis(i) % Ax ) 11450 END DO 11451 11452 DO i=1,m 11453 DO j=i,m 11454 Ymat(i,j) = SUM( AxTable(:,i) * AxTable(:,j) ) 11455 Ymat(j,i) = Ymat(i,j) 11456 END DO 11457 Betas(i) = SUM( AxTable(:,i) * b ) 11458 END DO 11459 11460 CALL LUSolve(m, YMat(1:m,1:m), Betas(1:m) ) 11461 11462 IF( InfoActive(10) ) THEN 11463 DO i=1,m 11464 WRITE(Message,'(A,I0,A,ES12.3)') 'Beta(',i,') = ',Betas(i) 11465 CALL Info('NonLinearAcceleration',Message) 11466 END DO 11467 END IF 11468 11469 x = Betas(m) * AndersonBasis(m) % Iterate 11470 DO i=1,m-1 11471 x = x + Betas(i) * AndersonBasis(i) % Iterate 11472 END DO 11473 11474 END SUBROUTINE AndersonGuess 11475 11476 END SUBROUTINE NonlinearAcceleration 11477!------------------------------------------------------------------------------ 11478 11479 11480 11481!------------------------------------------------------------------------------ 11482!> Computing nodal weight may be good when one needs to transform nodal 11483!> information back to continuous fields by dividing with the nodal weight. 11484!> Active either for the permutation defined by the primary variable of the 11485!> solver, or for a permutation vector defined by an optional flag that 11486!> is used as a mask to define the set of active nodes. 11487!------------------------------------------------------------------------------ 11488 SUBROUTINE CalculateNodalWeights(Solver,WeightAtBoundary,& 11489 Perm,VarName,Var) 11490!------------------------------------------------------------------------------ 11491 IMPLICIT NONE 11492 TYPE(Solver_t) :: Solver 11493 LOGICAL :: WeightAtBoundary 11494 INTEGER, POINTER, OPTIONAL :: Perm(:) 11495 CHARACTER(*), OPTIONAL :: VarName 11496 TYPE(Variable_t), POINTER, OPTIONAL :: Var 11497!------------------------------------------------------------------------------ 11498 CHARACTER(LEN=MAX_NAME_LEN) :: IntVarName 11499 TYPE(Mesh_t), POINTER :: Mesh 11500 TYPE(Variable_t), POINTER :: WeightsVar 11501 TYPE(ValueList_t), POINTER :: ElemParams 11502 REAL(KIND=dp), POINTER :: Weights(:), Solution(:) 11503 TYPE(Nodes_t) :: ElementNodes 11504 TYPE(Element_t), POINTER :: Element 11505 TYPE(GaussIntegrationPoints_t), TARGET :: IntegStuff 11506 INTEGER ::k, e, t, n, ElemStart, ElemFin, Coordsys 11507 INTEGER, POINTER :: IntPerm(:), Indexes(:),LocalIndexes(:) 11508 REAL(KIND=dp) :: u,v,w,s,detJ 11509 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 11510 LOGICAL :: GotIt, stat, VariableOutput, UseMask, RequireLogical, Hit 11511 REAL(KIND=dp) :: x,y,z,Metric(3,3),SqrtMetric,Symb(3,3,3),dSymb(3,3,3,3) 11512 11513 11514 Mesh => Solver % Mesh 11515 CoordSys = CurrentCoordinateSystem() 11516 11517 NULLIFY( WeightsVar ) 11518 IF( PRESENT( VarName ) ) THEN 11519 IntVarName = VarName 11520 ELSE IF ( WeightAtBoundary ) THEN 11521 IntVarName = GetVarName(Solver % Variable) // ' Boundary Weights' 11522 ELSE 11523 IntVarName = GetVarName(Solver % Variable) // ' Weights' 11524 END IF 11525 WeightsVar => VariableGet( Mesh % Variables, IntVarName ) 11526 11527 IF( WeightAtBoundary ) THEN 11528 ElemStart = Mesh % NumberOfBulkElements + 1 11529 ElemFin = Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 11530 UseMask = ListCheckPresentAnyBC( CurrentModel, IntVarName ) 11531 ELSE 11532 ElemStart = 1 11533 ElemFin = Mesh % NumberOfBulkElements 11534 UseMask = ListCheckPresentAnyBodyForce( CurrentModel, IntVarName ) 11535 END IF 11536 11537 RequireLogical = .FALSE. 11538 NULLIFY( IntPerm ) 11539 IF ( .NOT. ASSOCIATED(WeightsVar) ) THEN 11540 IF( PRESENT( Perm ) ) THEN 11541 IntPerm => Perm 11542 ELSE 11543 IntPerm => Solver % Variable % Perm 11544 END IF 11545 IF( ASSOCIATED( IntPerm ) ) THEN 11546 NULLIFY( Solution ) 11547 n = MAXVAL( IntPerm ) 11548 ALLOCATE( Solution(n)) 11549 Solution = 0.0d0 11550 CALL VariableAdd( Mesh % Variables, Mesh, Solver,& 11551 IntVarName, 1, Solution, IntPerm ) 11552 NULLIFY( Solution ) 11553 ELSE 11554 CALL Warn('CalculateNodalWeights','Permutation vector not present?') 11555 RETURN 11556 END IF 11557 WeightsVar => VariableGet( Mesh % Variables, IntVarName ) 11558 END IF 11559 11560 IF( .NOT. ASSOCIATED( WeightsVar ) ) THEN 11561 CALL Fatal('CalculateNodalWeights','Solution variable not present?') 11562 END IF 11563 Weights => WeightsVar % Values 11564 IntPerm => WeightsVar % Perm 11565 IF ( .NOT. ASSOCIATED(Weights) ) THEN 11566 CALL Warn('CalculateNodalWeights','Solution vector not present?') 11567 RETURN 11568 ELSE 11569 IF( PRESENT( Var) ) Var => WeightsVar 11570 END IF 11571 11572 CALL Info('ComputeNodalWeights',& 11573 'Computing weights for solver to variable: '//TRIM(IntVarName),Level=6) 11574 n = Mesh % MaxElementNodes 11575 11576 ALLOCATE(Basis(n), ElementNodes % x(n), ElementNodes % y(n), & 11577 ElementNodes % z(n), LocalIndexes(n) ) 11578 Weights = 0.0_dp 11579 11580 DO e=ElemStart,ElemFin 11581 11582 Element => Mesh % Elements( e ) 11583 Indexes => Element % NodeIndexes 11584 11585 n = Element % TYPE % NumberOfNodes 11586 LocalIndexes(1:n) = IntPerm( Indexes ) 11587 IF( ANY( LocalIndexes(1:n) == 0 ) ) CYCLE 11588 11589 IF( UseMask ) THEN 11590 Hit = .FALSE. 11591 IF( WeightAtBoundary ) THEN 11592 DO k=1,CurrentModel % NumberOfBCs 11593 IF ( Element % BoundaryInfo % Constraint == CurrentModel % BCs(k) % Tag ) THEN 11594 Hit = .TRUE. 11595 EXIT 11596 END IF 11597 END DO 11598 IF( .NOT. Hit ) CYCLE 11599 ElemParams => CurrentModel % BCs(k) % Values 11600 ELSE 11601 ElemParams => CurrentModel % Bodies(Element % BodyId) % Values 11602 END IF 11603 IF( RequireLogical ) THEN 11604 IF( .NOT. ListGetLogical( ElemParams, IntVarName, Stat ) ) CYCLE 11605 ELSE 11606 IF( .NOT. ListCheckPresent( ElemParams, IntVarName ) ) CYCLE 11607 END IF 11608 END IF 11609 11610 n = Element % TYPE % NumberOfNodes 11611 ElementNodes % x(1:n) = Mesh % Nodes % x(Indexes) 11612 ElementNodes % y(1:n) = Mesh % Nodes % y(Indexes) 11613 ElementNodes % z(1:n) = Mesh % Nodes % z(Indexes) 11614 11615 IntegStuff = GaussPoints( Element ) 11616 11617 DO t=1,IntegStuff % n 11618 U = IntegStuff % u(t) 11619 V = IntegStuff % v(t) 11620 W = IntegStuff % w(t) 11621 S = IntegStuff % s(t) 11622 11623 stat = ElementInfo( Element, ElementNodes, U, V, W, detJ, Basis ) 11624 11625 IF ( CoordSys /= Cartesian ) THEN 11626 X = SUM( ElementNodes % X(1:n) * Basis(1:n) ) 11627 Y = SUM( ElementNodes % Y(1:n) * Basis(1:n) ) 11628 Z = SUM( ElementNodes % Z(1:n) * Basis(1:n) ) 11629 CALL CoordinateSystemInfo( Metric,SqrtMetric,Symb,dSymb,X,Y,Z ) 11630 s = s * SqrtMetric 11631 END IF 11632 11633 Weights( LocalIndexes(1:n) ) = & 11634 Weights( LocalIndexes(1:n) ) + s * detJ * Basis(1:n) 11635 END DO 11636 11637 END DO 11638 11639 DEALLOCATE(Basis, ElementNodes % x, ElementNodes % y, & 11640 ElementNodes % z, LocalIndexes ) 11641 11642 CALL Info('ComputeNodalWeights','All done',Level=8) 11643 11644 END SUBROUTINE CalculateNodalWeights 11645!------------------------------------------------------------------------------ 11646 11647 11648 11649 11650 !> Calculate the number of separature pieces in a serial mesh. 11651 !> This could be used to detect problems in mesh when suspecting 11652 !> floating parts not fixed by any BC, for example. 11653 !--------------------------------------------------------------------------------- 11654 SUBROUTINE CalculateMeshPieces( Mesh ) 11655 11656 TYPE(Mesh_t), POINTER :: Mesh 11657 11658 LOGICAL :: Ready 11659 INTEGER :: i,j,k,n,t,MinIndex,MaxIndex,Loop,NoPieces 11660 INTEGER, ALLOCATABLE :: MeshPiece(:),PiecePerm(:) 11661 TYPE(Element_t), POINTER :: Element 11662 INTEGER, POINTER :: Indexes(:) 11663 TYPE(Variable_t), POINTER :: Var 11664 11665 IF( ParEnv % PEs > 1 ) THEN 11666 CALL Warn('CalculateMeshPieces','Implemented only for serial meshes, doing nothing!') 11667 RETURN 11668 END IF 11669 11670 n = Mesh % NumberOfNodes 11671 ALLOCATE( MeshPiece( n ) ) 11672 MeshPiece = 0 11673 11674 ! Only set the piece for the nodes that are used by some element 11675 ! For others the marker will remain zero. 11676 DO t = 1, Mesh % NumberOfBulkElements 11677 Element => Mesh % Elements(t) 11678 Indexes => Element % NodeIndexes 11679 MeshPiece( Indexes ) = 1 11680 END DO 11681 j = 0 11682 DO i = 1, n 11683 IF( MeshPiece(i) > 0 ) THEN 11684 j = j + 1 11685 MeshPiece(i) = j 11686 END IF 11687 END DO 11688 11689 CALL Info('CalculateMeshPieces',& 11690 'Number of non-body nodes in mesh is '//TRIM(I2S(n-j)),Level=5) 11691 11692 ! We go through the elements and set all the piece indexes to minimimum index 11693 ! until the mesh is unchanged. Thereafter the whole piece will have the minimum index 11694 ! of the piece. 11695 Ready = .FALSE. 11696 Loop = 0 11697 DO WHILE(.NOT. Ready) 11698 Ready = .TRUE. 11699 DO t = 1, Mesh % NumberOfBulkElements 11700 Element => Mesh % Elements(t) 11701 Indexes => Element % NodeIndexes 11702 11703 MinIndex = MINVAL( MeshPiece( Indexes ) ) 11704 MaxIndex = MAXVAL( MeshPiece( Indexes ) ) 11705 IF( MaxIndex > MinIndex ) THEN 11706 MeshPiece( Indexes ) = MinIndex 11707 Ready = .FALSE. 11708 END IF 11709 END DO 11710 Loop = Loop + 1 11711 END DO 11712 CALL Info('CalculateMeshPieces','Mesh coloring loops: '//TRIM(I2S(Loop)),Level=6) 11713 11714 ! If the maximum index is one then for sure there is only one body 11715 IF( MaxIndex == 1 ) THEN 11716 CALL Info('CalculateMeshPieces','Mesh consists of single body!',Level=5) 11717 RETURN 11718 END IF 11719 11720 ! Compute the true number of different pieces 11721 ALLOCATE( PiecePerm( MaxIndex ) ) 11722 PiecePerm = 0 11723 NoPieces = 0 11724 DO i = 1, n 11725 j = MeshPiece(i) 11726 IF( j == 0 ) CYCLE 11727 IF( PiecePerm(j) == 0 ) THEN 11728 NoPieces = NoPieces + 1 11729 PiecePerm(j) = NoPieces 11730 END IF 11731 END DO 11732 CALL Info('CalculateMeshPieces',& 11733 'Number of separate pieces in mesh is '//TRIM(I2S(NoPieces)),Level=5) 11734 11735 11736 ! Save the mesh piece field to > mesh piece < 11737 Var => VariableGet( Mesh % Variables,'Mesh Piece' ) 11738 IF(.NOT. ASSOCIATED( Var ) ) THEN 11739 CALL VariableAddVector ( Mesh % Variables,Mesh, CurrentModel % Solver,'Mesh Piece' ) 11740 Var => VariableGet( Mesh % Variables,'Mesh Piece' ) 11741 END IF 11742 11743 IF( .NOT. ASSOCIATED( Var ) ) THEN 11744 CALL Fatal('CalculateMeshPieces','Could not get handle to variable > Mesh Piece <') 11745 END IF 11746 11747 DO i = 1, n 11748 j = Var % Perm( i ) 11749 IF( j == 0 ) CYCLE 11750 IF( MeshPiece(i) > 0 ) THEN 11751 Var % Values( j ) = 1.0_dp * PiecePerm( MeshPiece( i ) ) 11752 ELSE 11753 Var % Values( j ) = 0.0_dp 11754 END IF 11755 END DO 11756 CALL Info('CalculateMeshPieces','Saving mesh piece field to: mesh piece',Level=5) 11757 11758 END SUBROUTINE CalculateMeshPieces 11759 11760 11761 11762!------------------------------------------------------------------------------ 11763!> Compute weights of entities i.e. their area and volume in the mesh. 11764!------------------------------------------------------------------------------ 11765 SUBROUTINE CalculateEntityWeights(Model, Mesh) 11766!------------------------------------------------------------------------------ 11767 IMPLICIT NONE 11768 TYPE(Model_t) :: Model 11769 TYPE(Mesh_t), POINTER :: Mesh 11770!------------------------------------------------------------------------------ 11771 TYPE(Nodes_t) :: ElementNodes 11772 TYPE(Element_t), POINTER :: Element, Left, Right 11773 TYPE(GaussIntegrationPoints_t), TARGET :: IntegStuff 11774 INTEGER ::i,j,k, e,t, n, Coordsys, TrueOwner, bc_id, bf_id, mat_id, body_id, & 11775 maxsize, ierr, PotOwner 11776 INTEGER :: NoBC, NoBodies, NoBF, NoMat 11777 INTEGER, POINTER :: Indexes(:) 11778 REAL(KIND=dp) :: u,v,w,s,detJ 11779 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 11780 REAL(KIND=dp), POINTER :: bc_weights(:),body_weights(:),& 11781 mat_weights(:),bf_weights(:),tmp_weights(:) 11782 REAL(KIND=dp) :: x,y,z,Metric(3,3),SqrtMetric,Symb(3,3,3),dSymb(3,3,3,3), & 11783 Coeff 11784 LOGICAL :: Found, Stat, BodyElem 11785 11786 11787 CoordSys = CurrentCoordinateSystem() 11788 11789 IF(.NOT. ASSOCIATED( Mesh ) ) THEN 11790 CALL Warn('CalculateEntityWeights','Mesh not associated!') 11791 RETURN 11792 END IF 11793 11794 CALL Info('CalculateEntityWeights','Computing weights for the mesh entities',Level=6) 11795 n = Mesh % MaxElementNodes 11796 11797 NoBC = Model % NumberOfBCs 11798 NoBodies = Model % NumberOfBodies 11799 NoMat = Model % NumberOfMaterials 11800 NoBF = Model % NumberOfBodyForces 11801 11802 11803 ALLOCATE(Basis(n), & 11804 ElementNodes % x(n), ElementNodes % y(n), ElementNodes % z(n) ) 11805 11806 IF( .NOT. Mesh % EntityWeightsComputed ) THEN 11807 IF( NoBC > 0 ) ALLOCATE( Mesh % BCWeight(NoBC) ) 11808 IF( NoBodies > 0 ) ALLOCATE( Mesh % BodyWeight(NoBodies ) ) 11809 IF( NoMat > 0 ) ALLOCATE( Mesh % MaterialWeight(NoMat) ) 11810 IF( NoBF > 0 ) ALLOCATE( Mesh % BodyForceWeight(NoBF ) ) 11811 END IF 11812 11813 IF( NoBC > 0 ) THEN 11814 bc_weights => Mesh % BCWeight 11815 bc_weights(1:NoBC ) = 0.0_dp 11816 END IF 11817 11818 IF( NoBodies > 0 ) THEN 11819 body_weights => Mesh % BodyWeight 11820 body_weights(1:NoBodies ) = 0.0_dp 11821 END IF 11822 11823 IF( NoMat > 0 ) THEN 11824 mat_weights => Mesh % MaterialWeight 11825 mat_weights(1:NoMat ) = 0.0_dp 11826 END IF 11827 11828 IF( NoBF > 0 ) THEN 11829 bf_weights => Mesh % BodyForceWeight 11830 bf_weights(1:NoBF ) = 0.0_dp 11831 END IF 11832 11833 DO e=1, Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 11834 11835 bf_id = 0 11836 mat_id = 0 11837 body_id = 0 11838 bc_id = 0 11839 Coeff = 1.0_dp 11840 11841 BodyElem = ( e <= Mesh % NumberOfBulkElements ) 11842 Element => Mesh % Elements( e ) 11843 11844 IF( BodyElem ) THEN 11845 body_id = Element % BodyId 11846 bf_id = ListGetInteger( Model % Bodies(body_id) % Values,& 11847 'Body Force',Found) 11848 mat_id = ListGetInteger( Model % Bodies(body_id) % Values,& 11849 'Material',Found) 11850 ELSE 11851 Found = .FALSE. 11852 DO bc_id = 1,Model % NumberOfBCs 11853 Found = ( Element % BoundaryInfo % Constraint == Model % BCs(bc_id) % Tag ) 11854 IF( Found ) EXIT 11855 END DO 11856 IF(.NOT. Found) CYCLE 11857 END IF 11858 11859 Coeff = 1.0_dp 11860 11861 ! In parallel compute the weight only at their true owners. 11862 ! Therefore cycle the halo elements. For shared BCs 11863 ! take only half of the weight. 11864 IF( ParEnv % PEs > 1 ) THEN 11865 IF( BodyElem ) THEN 11866 IF( Element % PartIndex /= ParEnv % MyPe ) CYCLE 11867 ELSE 11868 TrueOwner = 0 11869 PotOwner = 0 11870 Left => Element % BoundaryInfo % Left 11871 IF( ASSOCIATED( Left ) ) THEN 11872 PotOwner = PotOwner + 1 11873 IF( Left % PartIndex == ParEnv % MyPe ) TrueOwner = TrueOwner + 1 11874 END IF 11875 Right => Element % BoundaryInfo % Right 11876 IF( ASSOCIATED( Right ) ) THEN 11877 PotOwner = PotOwner + 1 11878 IF( Right % PartIndex == ParEnv % MyPe ) TrueOwner = TrueOwner + 1 11879 END IF 11880 IF( PotOwner > 0 ) THEN 11881 IF( TrueOwner == 0 ) CYCLE 11882 Coeff = 1.0_dp * TrueOwner / PotOwner 11883 END IF 11884 END IF 11885 END IF 11886 11887 Indexes => Element % NodeIndexes 11888 11889 n = Element % TYPE % NumberOfNodes 11890 ElementNodes % x(1:n) = Mesh % Nodes % x(Indexes) 11891 ElementNodes % y(1:n) = Mesh % Nodes % y(Indexes) 11892 ElementNodes % z(1:n) = Mesh % Nodes % z(Indexes) 11893 11894 IntegStuff = GaussPoints( Element ) 11895 11896 DO t=1,IntegStuff % n 11897 U = IntegStuff % u(t) 11898 V = IntegStuff % v(t) 11899 W = IntegStuff % w(t) 11900 11901 stat = ElementInfo( Element, ElementNodes, U, V, W, detJ, Basis ) 11902 S = Coeff * DetJ * IntegStuff % s(t) 11903 11904 IF ( CoordSys /= Cartesian ) THEN 11905 X = SUM( ElementNodes % X(1:n) * Basis(1:n) ) 11906 Y = SUM( ElementNodes % Y(1:n) * Basis(1:n) ) 11907 Z = SUM( ElementNodes % Z(1:n) * Basis(1:n) ) 11908 CALL CoordinateSystemInfo( Metric,SqrtMetric,Symb,dSymb,X,Y,Z ) 11909 s = s * 2 * PI * SqrtMetric 11910 END IF 11911 11912 IF( bc_id > 0 .AND. bc_id <= NoBC) & 11913 bc_weights( bc_id ) = bc_weights( bc_id ) + s 11914 IF( body_id > 0 .AND. body_id <= NoBodies ) & 11915 body_weights( body_id ) = body_weights( body_id ) + s 11916 IF( mat_id > 0 .AND. mat_id <= NoMat ) & 11917 mat_weights( mat_id ) = mat_weights( mat_id ) + s 11918 IF( bf_id > 0 .AND. bf_id <= NoBF ) & 11919 bf_weights( bf_id ) = bf_weights( bf_id ) + s 11920 END DO 11921 11922 END DO 11923 11924 11925 IF( ParEnv % PEs > 1 ) THEN 11926 maxsize = MAX( Model % NumberOfBCs, Model % NumberOfBodies ) 11927 ALLOCATE( tmp_weights( maxsize ) ) 11928 tmp_weights = 0.0_dp 11929 11930 IF( NoBC > 0 ) THEN 11931 tmp_weights(1:NoBC ) = bc_weights 11932 CALL MPI_ALLREDUCE( tmp_weights, bc_weights, NoBC, & 11933 MPI_DOUBLE_PRECISION, MPI_SUM, ELMER_COMM_WORLD, ierr ) 11934 END IF 11935 IF( NoBF > 0 ) THEN 11936 tmp_weights(1:NoBF ) = bf_weights 11937 CALL MPI_ALLREDUCE( tmp_weights, bf_weights, NoBF, & 11938 MPI_DOUBLE_PRECISION, MPI_SUM, ELMER_COMM_WORLD, ierr ) 11939 END IF 11940 IF( NoBodies > 0 ) THEN 11941 tmp_weights(1:NoBodies ) = body_weights 11942 CALL MPI_ALLREDUCE( tmp_weights, body_weights, NoBodies, & 11943 MPI_DOUBLE_PRECISION, MPI_SUM, ELMER_COMM_WORLD, ierr ) 11944 END IF 11945 IF( NoMat > 0 ) THEN 11946 tmp_weights(1:NoMat ) = mat_weights 11947 CALL MPI_ALLREDUCE( tmp_weights, mat_weights, NoMat, & 11948 MPI_DOUBLE_PRECISION, MPI_SUM, ELMER_COMM_WORLD, ierr ) 11949 END IF 11950 DEALLOCATE( tmp_weights ) 11951 END IF 11952 11953 IF( ParEnv % MyPe == 0 ) THEN 11954 DO i = 1, NoBC 11955 PRINT *,'BC weight:',i,bc_weights(i) 11956 END DO 11957 DO i = 1, NoBF 11958 PRINT *,'BF weight:',i,bf_weights(i) 11959 END DO 11960 DO i = 1, NoBodies 11961 PRINT *,'Body weight:',i,body_weights(i) 11962 END DO 11963 DO i = 1, NoMat 11964 PRINT *,'Mat weight:',i,mat_weights(i) 11965 END DO 11966 END IF 11967 11968 DEALLOCATE(Basis, & 11969 ElementNodes % x, ElementNodes % y, ElementNodes % z ) 11970 11971 Mesh % EntityWeightsComputed = .TRUE. 11972 11973 CALL Info('CalculateEntityWeights','All done',Level=10) 11974 11975 END SUBROUTINE CalculateEntityWeights 11976!------------------------------------------------------------------------------ 11977 11978 11979 11980!------------------------------------------------------------------------------ 11981!> Scale system Ax = b as: 11982!> (DAD)y = Db, where D = 1/SQRT(Diag(A)), and y = D^-1 x 11983!------------------------------------------------------------------------------ 11984 SUBROUTINE ScaleLinearSystem(Solver,A,b,x,DiagScaling, & 11985 ApplyScaling,RhsScaling,ConstraintScaling) 11986 11987 TYPE(Solver_t) :: Solver 11988 TYPE(Matrix_t) :: A 11989 REAL(KIND=dp), OPTIONAL :: b(:),x(:) 11990 REAL(KIND=dp), OPTIONAL, TARGET :: DiagScaling(:) 11991 LOGICAL, OPTIONAL :: ApplyScaling, RhsScaling,ConstraintScaling 11992 INTEGER :: n,i,j 11993 REAL(KIND=dp) :: bnorm,s 11994 COMPLEX(KIND=dp) :: DiagC 11995 LOGICAL :: ComplexMatrix, DoRHS, DoCM, Found 11996 REAL(KIND=dp), POINTER :: Diag(:) 11997 11998 TYPE(Matrix_t), POINTER :: CM 11999 12000 n = A % NumberOfRows 12001 12002 CALL Info('ScaleLinearSystem','Scaling diagonal entries to unity',Level=10) 12003 12004 IF( PRESENT( DiagScaling ) ) THEN 12005 CALL Info('ScaleLinearSystem','Reusing existing > DiagScaling < vector',Level=12) 12006 Diag => DiagScaling 12007 ELSE 12008 CALL Info('ScaleLinearSystem','Computing > DiagScaling < vector',Level=12) 12009 IF(.NOT. ASSOCIATED(A % DiagScaling)) THEN 12010 ALLOCATE( A % DiagScaling(n) ) 12011 END IF 12012 Diag => A % DiagScaling 12013 Diag = 0._dp 12014 12015 ComplexMatrix = Solver % Matrix % COMPLEX 12016 12017 IF( ListGetLogical( Solver % Values,'Linear System Pseudo Complex',Found ) ) THEN 12018 ComplexMatrix = .TRUE. 12019 END IF 12020 12021 IF ( ComplexMatrix ) THEN 12022 CALL Info('ScaleLinearSystem','Assuming complex matrix while scaling',Level=20) 12023 12024 !$OMP PARALLEL DO & 12025 !$OMP SHARED(Diag, A, N) & 12026 !$OMP PRIVATE(i, j) & 12027 !$OMP DEFAULT(NONE) 12028 DO i=1,n,2 12029 j = A % Diag(i) 12030 IF(j>0) THEN 12031 Diag(i) = A % Values(j) 12032 Diag(i+1) = A % Values(j+1) 12033 ELSE 12034 Diag(i) = 0._dp 12035 Diag(i+1) = 0._dp 12036 END IF 12037 END DO 12038 !$OMP END PARALLEL DO 12039 ELSE 12040 CALL Info('ScaleLinearSystem','Assuming real valued matrix while scaling',Level=25) 12041 12042 !$OMP PARALLEL DO & 12043 !$OMP SHARED(Diag, A, N) & 12044 !$OMP PRIVATE(i, j) & 12045 !$OMP DEFAULT(NONE) 12046 DO i=1,n 12047 j = A % Diag(i) 12048 IF (j>0) Diag(i) = A % Values(j) 12049 END DO 12050 !$OMP END PARALLEL DO 12051 END IF 12052 12053 IF ( ParEnv % PEs > 1 ) CALL ParallelSumVector(A, Diag) 12054 12055 IF ( ComplexMatrix ) THEN 12056 !$OMP PARALLEL DO & 12057 !$OMP SHARED(Diag, A, N) & 12058 !$OMP PRIVATE(i, j, DiagC, s) & 12059 !$OMP DEFAULT(NONE) 12060 DO i=1,n,2 12061 DiagC = CMPLX(Diag(i),-Diag(i+1),KIND=dp) 12062 12063 s = SQRT( ABS( DiagC ) ) 12064 IF( s > TINY(s) ) THEN 12065 Diag(i) = 1.0_dp / s 12066 Diag(i+1) = 1.0_dp / s 12067 ELSE 12068 Diag(i) = 1.0_dp 12069 Diag(i+1) = 1.0_dp 12070 END IF 12071 END DO 12072 !$OMP END PARALLEL DO 12073 ELSE 12074 s = 0.0_dp 12075 ! TODO: Add threading 12076 IF (ANY(ABS(Diag) <= TINY(bnorm))) s=1 12077 s = ParallelReduction(s,2) 12078 12079 IF(s > TINY(s) ) THEN 12080 DO i=1,n 12081 IF ( ABS(Diag(i)) <= TINY(bnorm) ) THEN 12082 Diag(i) = SUM( ABS(A % Values(A % Rows(i):A % Rows(i+1)-1)) ) 12083 ELSE 12084 j = A % Diag(i) 12085 IF (j>0) Diag(i) = A % Values(j) 12086 END IF 12087 END DO 12088 IF ( ParEnv % PEs > 1 ) CALL ParallelSumVector(A, Diag) 12089 END IF 12090 12091 !$OMP PARALLEL DO & 12092 !$OMP SHARED(Diag, N, bnorm) & 12093 !$OMP PRIVATE(i) & 12094 !$OMP DEFAULT(NONE) 12095 DO i=1,n 12096 IF ( ABS(Diag(i)) > TINY(bnorm) ) THEN 12097 Diag(i) = 1.0_dp / SQRT(ABS(Diag(i))) 12098 ELSE 12099 Diag(i) = 1.0_dp 12100 END IF 12101 END DO 12102 !$OMP END PARALLEL DO 12103 END IF 12104 END IF 12105 12106 12107 ! Optionally we may just create the diag and leave the scaling undone 12108 !-------------------------------------------------------------------- 12109 IF( PRESENT( ApplyScaling ) ) THEN 12110 IF(.NOT. ApplyScaling ) RETURN 12111 END IF 12112 12113 CALL Info('ScaleLinearSystem','Scaling matrix values',Level=20) 12114 12115 !$OMP PARALLEL & 12116 !$OMP SHARED(Diag, A, N) & 12117 !$OMP PRIVATE(i,j) & 12118 !$OMP DEFAULT(NONE) 12119 12120 !$OMP DO 12121 DO i=1,n 12122 DO j = A % Rows(i), A % Rows(i+1)-1 12123 A % Values(j) = A % Values(j) * & 12124 ( Diag(i) * Diag(A % Cols(j)) ) 12125 END DO 12126 END DO 12127 !$OMP END DO NOWAIT 12128 12129 ! Dont know why this was temporarily commented off.... 12130#if 1 12131 IF ( ASSOCIATED( A % PrecValues ) ) THEN 12132 IF (SIZE(A % Values) == SIZE(A % PrecValues)) THEN 12133 CALL Info('ScaleLinearSystem','Scaling PrecValues',Level=20) 12134 !$OMP DO 12135 DO i=1,n 12136 DO j=A % Rows(i), A % Rows(i+1)-1 12137 A % PrecValues(j) = A % PrecValues(j) * & 12138 ( Diag(i) * Diag(A % Cols(j)) ) 12139 END DO 12140 END DO 12141 !$OMP END DO NOWAIT 12142 END IF 12143 END IF 12144#endif 12145 12146 IF ( ASSOCIATED( A % MassValues ) ) THEN 12147 IF (SIZE(A % Values) == SIZE(A % MassValues)) THEN 12148 CALL Info('ScaleLinearSystem','Scaling MassValues',Level=20) 12149 !$OMP DO 12150 DO i=1,n 12151 DO j=A % Rows(i), A % Rows(i+1)-1 12152 A % MassValues(j) = A % MassValues(j) * & 12153 ( Diag(i) * Diag(A % Cols(j)) ) 12154 END DO 12155 END DO 12156 !$OMP END DO NOWAIT 12157 END IF 12158 END IF 12159 12160 IF ( ASSOCIATED( A % DampValues ) ) THEN 12161 IF (SIZE(A % Values) == SIZE(A % DampValues)) THEN 12162 CALL Info('ScaleLinearSystem','Scaling DampValues',Level=20) 12163 !$OMP DO 12164 DO i=1,n 12165 DO j=A % Rows(i), A % Rows(i+1)-1 12166 A % DampValues(j) = A % DampValues(j) * & 12167 ( Diag(i) * Diag(A % Cols(j)) ) 12168 END DO 12169 END DO 12170 !$OMP END DO NOWAIT 12171 END IF 12172 END IF 12173 12174 !$OMP END PARALLEL 12175 12176 DoCM = .FALSE. 12177 IF(PRESENT(ConstraintScaling)) DoCm=ConstraintScaling 12178 12179 IF(doCM) THEN 12180 CM => A % ConstraintMatrix 12181 IF (ASSOCIATED(CM)) THEN 12182 CALL Info('ScaleLinearSystem','Scaling Constraints',Level=20) 12183 !$OMP PARALLEL DO & 12184 !$OMP SHARED(Diag, CM) & 12185 !$OMP PRIVATE(i,j) & 12186 !$OMP DEFAULT(NONE) 12187 DO i=1,CM % NumberOFRows 12188 DO j=CM % Rows(i), CM % Rows(i+1)-1 12189 CM % Values(j) = CM % Values(j) * Diag(CM % Cols(j)) 12190 END DO 12191 END DO 12192 !$OMP END PARALLEL DO 12193 END IF 12194 END IF 12195 12196 ! Scale r.h.s. and initial guess 12197 !-------------------------------- 12198 A % RhsScaling=1._dp 12199 ! TODO: Add threading 12200 IF( PRESENT( b ) ) THEN 12201 CALL Info('ScaleLinearSystem','Scaling Rhs vector',Level=20) 12202 12203 b(1:n) = b(1:n) * Diag(1:n) 12204 DoRHS = .TRUE. 12205 IF (PRESENT(RhsScaling)) DoRHS = RhsScaling 12206 IF (DoRHS) THEN 12207 bnorm = SQRT(ParallelReduction(SUM(b(1:n)**2))) 12208 12209 IF( bnorm < SQRT( TINY( bnorm ) ) ) THEN 12210 CALL Info('ScaleLinearSystem','Rhs vector is almost zero, skipping rhs scaling!',Level=20) 12211 DoRhs = .FALSE. 12212 bnorm = 1.0_dp 12213 END IF 12214 ELSE 12215 bnorm = 1.0_dp 12216 END IF 12217 12218 A % RhsScaling = bnorm 12219 12220 IF( DoRhs ) THEN 12221 Diag(1:n) = Diag(1:n) * bnorm 12222 b(1:n) = b(1:n) / bnorm 12223 END IF 12224 12225 IF( PRESENT( x) ) THEN 12226 x(1:n) = x(1:n) / Diag(1:n) 12227 END IF 12228 END IF 12229 12230 12231 !----------------------------------------------------------------------------- 12232 END SUBROUTINE ScaleLinearSystem 12233!----------------------------------------------------------------------------- 12234 12235 12236!----------------------------------------------------------------------------- 12237!> Equilibrate the rows of the coefficient matrix A to 12238!> minimize the condition number. The associated rhs vector f is also scaled. 12239!------------------------------------------------------------------------------ 12240 SUBROUTINE RowEquilibration( A, f, Parallel ) 12241!------------------------------------------------------------------------------ 12242 TYPE(Matrix_t) :: A 12243 REAL(KIND=dp) :: f(:) 12244 LOGICAL :: Parallel 12245!----------------------------------------------------------------------------- 12246 LOGICAL :: ComplexMatrix 12247 INTEGER :: i, j, n 12248 REAL(kind=dp) :: norm, tmp 12249 INTEGER, POINTER :: Cols(:), Rows(:) 12250 REAL(KIND=dp), POINTER :: Values(:), Diag(:) 12251!------------------------------------------------------------------------- 12252 12253 CALL Info('RowEquilibration','Scaling system such that abs rowsum is unity',Level=15) 12254 12255 12256 n = A % NumberOfRows 12257 ComplexMatrix = A % COMPLEX 12258 12259 Rows => A % Rows 12260 Cols => A % Cols 12261 Values => A % Values 12262 12263 IF( .NOT. ASSOCIATED(A % DiagScaling) ) THEN 12264 ALLOCATE( A % DiagScaling(n) ) 12265 END IF 12266 Diag => A % DiagScaling 12267 12268 Diag = 0.0d0 12269 norm = 0.0d0 12270 12271 !--------------------------------------------- 12272 ! Compute 1-norm of each row 12273 !--------------------------------------------- 12274 IF (ComplexMatrix) THEN 12275 DO i=1,n,2 12276 tmp = 0.0d0 12277 DO j=Rows(i),Rows(i+1)-1,2 12278 tmp = tmp + ABS( CMPLX( Values(j), -Values(j+1), kind=dp ) ) 12279 END DO 12280 Diag(i) = tmp 12281 Diag(i+1) = tmp 12282 END DO 12283 ELSE 12284 DO i=1,n 12285 tmp = 0.0d0 12286 DO j=Rows(i),Rows(i+1)-1 12287 tmp = tmp + ABS(Values(j)) 12288 END DO 12289 Diag(i) = tmp 12290 END DO 12291 END IF 12292 12293 IF (Parallel) THEN 12294 CALL ParallelSumVector(A, Diag) 12295 END IF 12296 norm = MAXVAL(Diag(1:n)) 12297 IF( Parallel ) THEN 12298 norm = ParallelReduction(norm,2) 12299 END IF 12300 12301 !-------------------------------------------------- 12302 ! Now, define the scaling matrix by inversion and 12303 ! perform the actual scaling of the linear system 12304 !-------------------------------------------------- 12305 IF (ComplexMatrix) THEN 12306 DO i=1,n,2 12307 IF (Diag(i) > TINY(norm) ) THEN 12308 Diag(i) = 1.0_dp / Diag(i) 12309 ELSE 12310 Diag(i) = 1.0_dp 12311 END IF 12312 Diag(i+1) = Diag(i) 12313 END DO 12314 ELSE 12315 DO i=1,n 12316 IF (Diag(i) > TINY(norm)) THEN 12317 Diag(i) = 1.0_dp / Diag(i) 12318 ELSE 12319 Diag(i) = 1.0_dp 12320 END IF 12321 END DO 12322 END IF 12323 12324 DO i=1,n 12325 DO j=Rows(i),Rows(i+1)-1 12326 Values(j) = Values(j) * Diag(i) 12327 END DO 12328 f(i) = Diag(i) * f(i) 12329 END DO 12330 12331 12332 IF ( ASSOCIATED( A % PrecValues ) ) THEN 12333 IF (SIZE(A % Values) == SIZE(A % PrecValues)) THEN 12334 DO i=1,n 12335 DO j=A % Rows(i), A % Rows(i+1)-1 12336 A % PrecValues(j) = A % PrecValues(j) * Diag(i) 12337 END DO 12338 END DO 12339 END IF 12340 END IF 12341 12342 12343 WRITE( Message, * ) 'Unscaled matrix norm: ', norm 12344 CALL Info( 'RowEquilibration', Message, Level=5 ) 12345 12346!------------------------------------------------------------------------------ 12347 END SUBROUTINE RowEquilibration 12348!------------------------------------------------------------------------------ 12349 12350 12351 12352!-------------------------------------------------------------- 12353!> Scale the system back to original. 12354!-------------------------------------------------------------- 12355 SUBROUTINE BackScaleLinearSystem( Solver,A,b,x,DiagScaling,& 12356 ConstraintScaling, EigenScaling ) 12357 12358 TYPE(Solver_t) :: Solver 12359 TYPE(Matrix_t) :: A 12360 REAL(KIND=dp), OPTIONAL :: b(:),x(:) 12361 LOGICAL, OPTIONAL :: ConstraintScaling, EigenScaling 12362 REAL(KIND=dp), OPTIONAL, TARGET :: DiagScaling(:) 12363 12364 REAL(KIND=dp), POINTER :: Diag(:) 12365 REAL(KIND=dp) :: bnorm 12366 INTEGER :: n,i,j 12367 LOGICAL :: doCM 12368 12369 TYPE(Matrix_t), POINTER :: CM 12370 12371 CALL Info('BackScaleLinearSystem','Scaling back to original scale',Level=14) 12372 12373 12374 n = A % NumberOfRows 12375 12376 IF( PRESENT( DiagScaling ) ) THEN 12377 Diag => DiagScaling 12378 ELSE 12379 Diag => A % DiagScaling 12380 END IF 12381 12382 IF(.NOT. ASSOCIATED( Diag ) ) THEN 12383 CALL Warn('BackScaleLinearSystem','Diag not associated!') 12384 RETURN 12385 END IF 12386 IF( SIZE( Diag ) /= n ) THEN 12387 CALL Fatal('BackScaleLinearSystem','Diag of wrong size!') 12388 END IF 12389 12390 IF( PRESENT( b ) ) THEN 12391 ! TODO: Add threading 12392! 12393! Solve x: INV(D)x = y, scale b back to orig 12394! ------------------------------------------- 12395 IF( PRESENT( x ) ) THEN 12396 x(1:n) = x(1:n) * Diag(1:n) 12397 END IF 12398 bnorm = A % RhsScaling 12399 Diag(1:n) = Diag(1:n) / bnorm 12400 b(1:n) = b(1:n) / Diag(1:n) * bnorm 12401 END IF 12402 12403 IF( PRESENT( EigenScaling ) ) THEN 12404 IF( EigenScaling ) THEN 12405 ! TODO: Add threading 12406 DO i=1,Solver % NOFEigenValues 12407 ! 12408 ! Solve x: INV(D)x = y 12409 ! -------------------------- 12410 IF ( Solver % Matrix % COMPLEX ) THEN 12411 Solver % Variable % EigenVectors(i,1:n/2) = & 12412 Solver % Variable % EigenVectors(i,1:n/2) * Diag(1:n:2) 12413 ELSE 12414 Solver % Variable % EigenVectors(i,1:n) = & 12415 Solver % Variable % EigenVectors(i,1:n) * Diag(1:n) 12416 END IF 12417 END DO 12418 END IF 12419 END IF 12420 12421 !$OMP PARALLEL & 12422 !$OMP SHARED(Diag, A, N) & 12423 !$OMP PRIVATE(i, j) & 12424 !$OMP DEFAULT(NONE) 12425 12426 !$OMP DO 12427 DO i=1,n 12428 DO j=A % Rows(i), A % Rows(i+1)-1 12429 A % Values(j) = A % Values(j) / (Diag(i) * Diag(A % Cols(j))) 12430 END DO 12431 END DO 12432 !$OMP END DO NOWAIT 12433 12434#if 0 12435 IF ( ASSOCIATED( A % PrecValues ) ) THEN 12436 IF (SIZE(A % Values) == SIZE(A % PrecValues)) THEN 12437 !$OMP DO 12438 DO i=1,n 12439 DO j=A % Rows(i), A % Rows(i+1)-1 12440 A % PrecValues(j) = A % PrecValues(j) / & 12441 ( Diag(i) * Diag(A % Cols(j)) ) 12442 END DO 12443 END DO 12444 !$OMP END DO NOWAIT 12445 END IF 12446 END IF 12447#endif 12448 IF ( ASSOCIATED( A % MassValues ) ) THEN 12449 IF (SIZE(A % Values) == SIZE(A % MassValues)) THEN 12450 !$OMP DO 12451 DO i=1,n 12452 DO j=A % Rows(i), A % Rows(i+1)-1 12453 A % MassValues(j) = A % MassValues(j) / & 12454 ( Diag(i) * Diag(A % Cols(j)) ) 12455 END DO 12456 END DO 12457 !$OMP END DO NOWAIT 12458 END IF 12459 END IF 12460 12461 IF ( ASSOCIATED( A % DampValues ) ) THEN 12462 IF (SIZE(A % Values) == SIZE(A % DampValues)) THEN 12463 !$OMP DO 12464 DO i=1,n 12465 DO j=A % Rows(i), A % Rows(i+1)-1 12466 A % DampValues(j) = A % DampValues(j) / & 12467 ( Diag(i) * Diag(A % Cols(j)) ) 12468 END DO 12469 END DO 12470 !$OMP END DO NOWAIT 12471 END IF 12472 END IF 12473 12474 !$OMP END PARALLEL 12475 12476 ! TODO: Add threading 12477 doCM=.FALSE. 12478 IF(PRESENT(ConstraintScaling)) doCM=ConstraintScaling 12479 IF(doCM) THEN 12480 CM => A % ConstraintMatrix 12481 IF (ASSOCIATED(CM)) THEN 12482 DO i=1,CM % NumberOFRows 12483 DO j=CM % Rows(i), CM % Rows(i+1)-1 12484 CM % Values(j) = CM % Values(j) / ( Diag(CM % Cols(j)) ) 12485 END DO 12486 END DO 12487 END IF 12488 END IF 12489 12490 A % RhsScaling=1._dp 12491 DEALLOCATE(A % DiagScaling); A % DiagScaling=>NULL() 12492 12493 END SUBROUTINE BackScaleLinearSystem 12494 12495 12496!------------------------------------------------------------------------------ 12497!> Scale the linear system back to original when the linear 12498!> system scaling has been done by row equilibration. 12499!------------------------------------------------------------------------------ 12500 SUBROUTINE ReverseRowEquilibration( A, f ) 12501!------------------------------------------------------------------------------ 12502 TYPE(Matrix_t) :: A 12503 REAL(KIND=dp) :: f(:) 12504!----------------------------------------------------------------------------- 12505 INTEGER :: i, j, n 12506 INTEGER, POINTER :: Rows(:) 12507 REAL(KIND=dp), POINTER :: Values(:), Diag(:) 12508!----------------------------------------------------------------------------- 12509 n = A % NumberOfRows 12510 Diag => A % DiagScaling 12511 Values => A % Values 12512 Rows => A % Rows 12513 12514 IF(.NOT. ASSOCIATED( Diag ) ) THEN 12515 CALL Fatal('ReverseRowEquilibration','Diag not associated!') 12516 END IF 12517 IF( SIZE( Diag ) /= n ) THEN 12518 CALL Fatal('ReverseRowEquilibration','Diag of wrong size!') 12519 END IF 12520 12521 f(1:n) = f(1:n) / Diag(1:n) 12522 DO i=1,n 12523 DO j = Rows(i), Rows(i+1)-1 12524 Values(j) = Values(j) / Diag(i) 12525 END DO 12526 END DO 12527 12528 IF ( ASSOCIATED( A % PrecValues ) ) THEN 12529 IF (SIZE(A % Values) == SIZE(A % PrecValues)) THEN 12530 DO i=1,n 12531 DO j=A % Rows(i), A % Rows(i+1)-1 12532 A % PrecValues(j) = A % PrecValues(j) / Diag(i) 12533 END DO 12534 END DO 12535 END IF 12536 END IF 12537 12538 12539 DEALLOCATE(A % DiagScaling) 12540 A % DiagScaling => NULL() 12541 12542!------------------------------------------------------------------------------ 12543 END SUBROUTINE ReverseRowEquilibration 12544!------------------------------------------------------------------------------ 12545 12546 12547 SUBROUTINE CalculateLoads( Solver, Aaid, x, DOFs, UseBulkValues, NodalLoads, NodalValues ) 12548 12549 TYPE(Solver_t) :: Solver 12550 TYPE(Matrix_t), POINTER :: Aaid 12551 REAL(KIND=dp) CONTIG :: x(:) 12552 INTEGER :: DOFs 12553 LOGICAL :: UseBulkValues 12554 TYPE(Variable_t), POINTER, OPTIONAL :: NodalLoads 12555 REAL(KIND=dp), POINTER, OPTIONAL :: NodalValues(:) 12556 12557 INTEGER :: i,j,k,l,m,ii,This,DOF 12558 REAL(KIND=dp), POINTER :: TempRHS(:), TempVector(:), Rhs(:), TempX(:) 12559 REAL(KIND=dp), POINTER CONTIG :: SaveValues(:) 12560 REAL(KIND=dp) :: Energy, Energy_im 12561 TYPE(Matrix_t), POINTER :: Projector 12562 LOGICAL :: Found, Rotated 12563 REAL(KIND=dp), ALLOCATABLE :: BoundarySum(:), BufReal(:) 12564 INTEGER, ALLOCATABLE :: BoundaryShared(:),BoundaryActive(:),DofSummed(:),BufInteg(:) 12565 TYPE(Element_t), POINTER :: Element 12566 INTEGER :: bc, ind, NoBoundaryActive, NoBCs, ierr 12567 LOGICAL :: OnlyGivenBCs 12568 LOGICAL :: UseVar 12569 12570 UseVar = .FALSE. 12571 IF(PRESENT( NodalLoads ) ) THEN 12572 UseVar = ASSOCIATED( NodalLoads ) 12573 IF(.NOT. UseVar ) THEN 12574 CALL Warn('CalculateLoads','Load variable not associated!') 12575 RETURN 12576 END IF 12577 ELSE IF( PRESENT( NodalValues ) ) THEN 12578 IF(.NOT. ASSOCIATED( NodalValues ) ) THEN 12579 CALL Warn('CalculateLoads','Load values not associated!') 12580 RETURN 12581 END IF 12582 ELSE 12583 CALL Fatal('CalculateLoads','Give either loads variable or values as parameter!') 12584 END IF 12585 12586 ALLOCATE( TempVector(Aaid % NumberOfRows) ) 12587 12588 IF( UseBulkValues ) THEN 12589 SaveValues => Aaid % Values 12590 Aaid % Values => Aaid % BulkValues 12591 Rhs => Aaid % BulkRHS 12592 ELSE 12593 Rhs => Aaid % Rhs 12594 END IF 12595 12596 12597 IF ( ParEnv % PEs > 1 ) THEN 12598 ALLOCATE(TempRHS(SIZE(Rhs))) 12599 TempRHS = Rhs 12600 CALL ParallelInitSolve( Aaid, x, TempRHS, Tempvector ) 12601 CALL ParallelMatrixVector( Aaid, x, TempVector, .TRUE. ) 12602 ELSE 12603 CALL MatrixVectorMultiply( Aaid, x, TempVector ) 12604 END IF 12605 12606 IF( ListGetLogical(Solver % Values, 'Calculate Energy Norm', Found) ) THEN 12607 Energy = 0._dp 12608 IF( ListGetLogical(Solver % Values, 'Linear System Complex', Found) ) THEN 12609 Energy_im = 0._dp 12610 DO i = 1, (Aaid % NumberOfRows / 2) 12611 IF ( ParEnv % Pes>1 ) THEN 12612 IF ( Aaid% ParMatrix % ParallelInfo % & 12613 NeighbourList(2*(i-1)+1) % Neighbours(1) /= ParEnv % MyPE ) CYCLE 12614 END IF 12615 Energy = Energy + x(2*(i-1)+1) * TempVector(2*(i-1)+1) - x(2*(i-1)+2) * TempVector(2*(i-1)+2) 12616 Energy_im = Energy_im + x(2*(i-1)+1) * TempVector(2*(i-1)+2) + x(2*(i-1)+2) * TempVector(2*(i-1)+1) 12617 END DO 12618 Energy = ParallelReduction(Energy) 12619 Energy_im = ParallelReduction(Energy_im) 12620 12621 CALL ListAddConstReal( Solver % Values, 'Energy norm', Energy) 12622 CALL ListAddConstReal( Solver % Values, 'Energy norm im', Energy_im) 12623 12624 WRITE( Message,'(A,A,A)') 'res: ',GetVarname(Solver % Variable),' Energy Norm' 12625 CALL ListAddConstReal( CurrentModel % Simulation, Message, Energy ) 12626 12627 WRITE( Message,'(A,A,A)') 'res: ',GetVarname(Solver % Variable),' Energy Norm im' 12628 CALL ListAddConstReal( CurrentModel % Simulation, Message, Energy_im ) 12629 12630 WRITE( Message, * ) 'Energy Norm: ', Energy, Energy_im 12631 CALL Info( 'CalculateLoads', Message, Level=5) 12632 ELSE 12633 DO i=1,Aaid % NumberOfRows 12634 IF ( ParEnv % Pes>1 ) THEN 12635 IF ( Aaid % ParMatrix % ParallelInfo % & 12636 NeighbourList(i) % Neighbours(1) /= Parenv % MyPE ) CYCLE 12637 END IF 12638 Energy = Energy + x(i)*TempVector(i) 12639 END DO 12640 Energy = ParallelReduction(Energy) 12641 CALL ListAddConstReal( Solver % Values, 'Energy norm', Energy ) 12642 12643 WRITE( Message,'(A,A,A)') 'res: ',GetVarname(Solver % Variable),' Energy Norm' 12644 CALL ListAddConstReal( CurrentModel % Simulation, Message, Energy ) 12645 12646 WRITE( Message, * ) 'Energy Norm: ', Energy 12647 CALL Info( 'CalculateLoads', Message, Level=5) 12648 END IF 12649 END IF 12650 12651 IF ( ParEnv % PEs>1 ) THEN 12652 DO i=1,Aaid % NumberOfRows 12653 IF ( AAid % ParallelInfo % NeighbourList(i) % Neighbours(1) == ParEnv % Mype ) THEN 12654 TempVector(i) = TempVector(i) - TempRHS(i) 12655 ELSE 12656 TempVector(i) = 0 12657 END IF 12658 END DO 12659 CALL ParallelSumVector( AAid, Tempvector ) 12660 DEALLOCATE( TempRhs ) 12661 ELSE 12662 TempVector = TempVector - RHS 12663 END IF 12664 12665 12666 NoBCs = CurrentModel % NumberOfBCs 12667 DO This=1,NoBCs 12668 Projector => CurrentModel % BCs(This) % PMatrix 12669 IF (ASSOCIATED(Projector))THEN 12670 DO DOF=1,DOFs 12671 DO i=1,Projector % NumberOfRows 12672 ii = Projector % InvPerm(i) 12673 IF( ii == 0 ) CYCLE 12674 k = Solver % Variable % Perm(ii) 12675 IF(k<=0) CYCLE 12676 k = DOFs * (k-1) + DOF 12677 TempVector(k)=0 12678 12679 DO l = Projector % Rows(i), Projector % Rows(i+1)-1 12680 IF ( Projector % Cols(l) <= 0 ) CYCLE 12681 m = Solver % Variable % Perm( Projector % Cols(l) ) 12682 IF ( m > 0 ) THEN 12683 m = DOFs * (m-1) + DOF 12684 TempVector(k) = TempVector(k) + Projector % Values(l)*TempVector(m) 12685 END IF 12686 END DO 12687 END DO 12688 END DO 12689 END IF 12690 END DO 12691 12692 IF( UseVar ) THEN 12693 DO i=1,SIZE( NodalLoads % Perm ) 12694 IF ( NodalLoads % Perm(i)>0 .AND. Solver % Variable % Perm(i)>0 ) THEN 12695 DO j=1,DOFs 12696 NodalLoads % Values(DOFs*(NodalLoads % Perm(i)-1)+j) = & 12697 TempVector(DOFs*(Solver % Variable % Perm(i)-1)+j) 12698 END DO 12699 END IF 12700 END DO 12701 ELSE 12702 NodalValues = TempVector 12703 END IF 12704 12705 DEALLOCATE( TempVector ) 12706 12707 12708 IF( ListGetLogical( Solver % Values,'Calculate Boundary Fluxes',Found ) ) THEN 12709 CALL Info('CalculateLoads','Computing boundary fluxes from nodal loads',Level=6) 12710 12711 IF( Solver % Mesh % MaxEdgeDofs > 1 .OR. Solver % Mesh % MaxFaceDOFs > 1 ) THEN 12712 CALL Warn('CalculateLoads','Boundary flux computation implemented only for nodes for now!') 12713 END IF 12714 12715 IF(.NOT. UseVar ) THEN 12716 CALL Fatal('CalculateLoads','Boundary flux computation needs the variable parameter!') 12717 END IF 12718 12719 ALLOCATE( BoundarySum( NoBCs * DOFs ), & 12720 BoundaryActive( NoBCs ), & 12721 BoundaryShared( NoBCs ), & 12722 DofSummed( MAXVAL( NodalLoads % Perm ) ) ) 12723 BoundarySum = 0.0_dp 12724 BoundaryActive = 0 12725 BoundaryShared = 0 12726 DofSummed = 0 12727 12728 OnlyGivenBCs = ListCheckPresentAnyBC( CurrentModel,'Calculate Boundary Flux') 12729 12730 k = Solver % Mesh % NumberOfBulkElements 12731 DO i = k+1,k + Solver % Mesh % NumberOfBoundaryElements 12732 Element => Solver % Mesh % Elements(i) 12733 bc = Element % BoundaryInfo % Constraint 12734 12735 IF( bc == 0 ) CYCLE 12736 12737 IF( OnlyGivenBCs ) THEN 12738 IF (.NOT. ListGetLogical( CurrentModel % BCs(bc) % Values,& 12739 'Calculate Boundary Flux',Found) ) CYCLE 12740 END IF 12741 12742 DO j=1,Element % TYPE % NumberOfNodes 12743 ind = NodalLoads % Perm( Element % NodeIndexes(j) ) 12744 IF( ind == 0 ) CYCLE 12745 12746 ! In this partition sum up only the true owners 12747 IF ( ParEnv % PEs>1 ) THEN 12748 IF ( AAid % ParallelInfo % NeighbourList(ind) % Neighbours(1) & 12749 /= ParEnv % Mype ) CYCLE 12750 END IF 12751 12752 ! Only sum each entry once. If there is a conflict we cannot 12753 ! really resolve it with the chosen method so just warn. 12754 IF( DofSummed(ind) == 0 ) THEN 12755 BoundarySum( DOFs*(bc-1)+1 :DOFs*bc ) = BoundarySum( DOFs*(bc-1)+ 1:DOFs*bc ) + & 12756 NodalLoads % Values( DOFs*(ind-1) + 1: DOFs * ind ) 12757 DofSummed( ind ) = bc 12758 BoundaryActive( bc ) = 1 12759 ELSE IF( bc /= DofSummed(ind) ) THEN 12760 BoundaryShared(bc) = 1 12761 BoundaryShared(DofSummed(ind)) = 1 12762 END IF 12763 END DO 12764 END DO 12765 12766 12767 NoBoundaryActive = 0 12768 IF( ParEnv % PEs > 1 ) THEN 12769 ALLOCATE( BufInteg( NoBCs ), BufReal( NoBCs * DOFs ) ) 12770 12771 BufInteg = BoundaryActive 12772 CALL MPI_ALLREDUCE( BufInteg, BoundaryActive, NoBCs, MPI_INTEGER, & 12773 MPI_SUM, ParEnv % ActiveComm, ierr ) 12774 12775 BufInteg = BoundaryShared 12776 CALL MPI_ALLREDUCE( BufInteg, BoundaryShared, NoBCs, MPI_INTEGER, & 12777 MPI_SUM, ParEnv % ActiveComm, ierr ) 12778 12779 BufReal = BoundarySum 12780 CALL MPI_ALLREDUCE( BufReal, BoundarySum, DOFs * NoBCs, MPI_DOUBLE_PRECISION, & 12781 MPI_SUM, ParEnv % ActiveComm, ierr ) 12782 12783 DEALLOCATE( BufInteg, BufReal ) 12784 END IF 12785 12786 12787 DO i=1,CurrentModel % NumberOfBCs 12788 IF( BoundaryActive(i) == 0 ) CYCLE 12789 IF( BoundaryShared(i) > 0) THEN 12790 CALL Warn('CalculateLoads','Boundary '//TRIM(I2S(i))//' includes inseparable dofs!') 12791 END IF 12792 NoBoundaryActive = NoBoundaryActive + 1 12793 12794 DO j=1,DOFs 12795 IF( Dofs == 1 ) THEN 12796 WRITE( Message,'(A)') GetVarname(Solver % Variable)//& 12797 ' Flux over BC '//TRIM(I2S(i)) 12798 ELSE 12799 WRITE( Message,'(A)') GetVarname(Solver % Variable)//& 12800 ' '//TRIM(I2S(j))//' Flux over BC '//TRIM(I2S(i)) 12801 END IF 12802 CALL ListAddConstReal( CurrentModel % Simulation, 'res: '//TRIM(Message), & 12803 BoundarySum(DOFs*(i-1)+j) ) 12804 WRITE( Message,'(A,ES12.5)') TRIM(Message)//': ',BoundarySum(DOFs*(i-1)+j) 12805 CALL Info('CalculateLoads',Message,Level=6) 12806 END DO 12807 END DO 12808 12809 IF( NoBoundaryActive > 1 ) THEN 12810 DO j=1,DOFs 12811 IF( Dofs == 1 ) THEN 12812 WRITE( Message,'(A)') GetVarname(Solver % Variable)//& 12813 ' Flux over all BCs' 12814 ELSE 12815 WRITE( Message,'(A)') GetVarname(Solver % Variable)//& 12816 ' '//TRIM(I2S(j))//' Flux over all BCs' 12817 END IF 12818 WRITE( Message,'(A,ES12.5)') TRIM(Message)//': ',SUM(BoundarySum(j::DOFs)) 12819 CALL Info('CalculateLoads',Message,Level=6) 12820 END DO 12821 END IF 12822 12823 DEALLOCATE( DofSummed, BoundaryShared, BoundaryActive, BoundarySum ) 12824 END IF 12825 12826 12827 IF( UseBulkValues ) THEN 12828 Aaid % Values => SaveValues 12829 END IF 12830 12831 END SUBROUTINE CalculateLoads 12832 12833 12834 12835 12836 12837 ! Create a boundary matrix and at calculate step compute the boundary loads 12838 ! for one given body. This is not called by default but the user needs to 12839 ! include it in the code, both at assembly and after solution. 12840 !----------------------------------------------------------------------------- 12841 SUBROUTINE BCLoadsAssembly( Solver, Element, LocalMatrix, LocalRhs ) 12842 12843 TYPE(Solver_t) :: Solver 12844 TYPE(Element_t), POINTER :: Element 12845 REAL(KIND=dp) :: LocalMatrix(:,:) 12846 REAL(KIND=dp) :: LocalRhs(:) 12847 12848 LOGICAL :: FirstStep 12849 INTEGER :: i,j,k,l,n,Row,Col,Dofs,ElemNo,TargetBody=-1 12850 TYPE(Matrix_t), POINTER :: BCMat 12851 REAL(KIND=dp) :: Val 12852 LOGICAL :: Found 12853 INTEGER, POINTER :: Perm(:), BCPerm(:) 12854 CHARACTER(MAX_NAME_LEN) :: Name 12855 TYPE(Variable_t), POINTER :: BCVar 12856 12857 12858 SAVE :: BCMat, TargetBody, BCPerm, Perm, Dofs 12859 12860 12861 FirstStep = ( Solver % ActiveElements(1) == Element % ElementIndex ) 12862 12863 IF( FirstStep ) THEN 12864 CALL Info('BCLoadsAssembly','Visiting first element',Level=6) 12865 12866 BCMat => Solver % Matrix % EMatrix 12867 IF(.NOT. ASSOCIATED( BCMat ) ) THEN 12868 TargetBody = ListGetInteger( Solver % Values,'Boundary Loads Target Body',Found ) 12869 IF( Found ) THEN 12870 CALL Info('BCLoadsAssembly','Target body set to: '//TRIM(I2S(TargetBody)),Level=6) 12871 ELSE 12872 TargetBody = -1 12873 RETURN 12874 END IF 12875 12876 CALL Info('BCLoadsAssembly','Allocating structures for load computation',Level=8) 12877 IF ( ParEnv % PEs > 1 ) THEN 12878 CALL Warn('BCLoadsAssembly','Not implemented in parallel') 12879 END IF 12880 12881 ! Mark the active nodes 12882 ALLOCATE( BCPerm( Solver % Mesh % NumberOfNodes ) ) 12883 BCPerm = 0 12884 12885 ElemNo = 0 12886 k = Solver % Mesh % NumberOfBulkElements 12887 DO i = k+1,k + Solver % Mesh % NumberOfBoundaryElements 12888 Element => Solver % Mesh % Elements(i) 12889 Found = .FALSE. 12890 IF( ASSOCIATED( Element % BoundaryInfo % Left ) ) THEN 12891 Found = ( Element % BoundaryInfo % Left % BodyId == TargetBody ) 12892 END IF 12893 IF(.NOT. Found ) THEN 12894 IF( ASSOCIATED( Element % BoundaryInfo % Right ) ) THEN 12895 Found = ( Element % BoundaryInfo % Right % BodyId == TargetBody ) 12896 END IF 12897 END IF 12898 IF( Found ) THEN 12899 ElemNo = ElemNo + 1 12900 BCPerm( Element % NodeIndexes ) = 1 12901 END IF 12902 END DO 12903 12904 CALL Info('BCLoadsAssembly','Number of related boundary elements: '//TRIM(I2S(ElemNo)),Level=8) 12905 12906 n = 0 12907 DO i=1,Solver % Mesh % NumberOfNodes 12908 IF( BCPerm(i) > 0 ) THEN 12909 n = n + 1 12910 BCPerm(i) = n 12911 END IF 12912 END DO 12913 CALL Info('BCLoadsAssembly','Number of active nodes: '//TRIM(I2S(n)),Level=8) 12914 12915 ! Create the list matrix 12916 BCMat => AllocateMatrix() 12917 BCMat % Format = MATRIX_LIST 12918 CALL AddToMatrixElement( BCMat, n, n, 0.0_dp ) 12919 Solver % Matrix % EMatrix => BCMat 12920 12921 ALLOCATE( BCMat % Rhs(n) ) 12922 BCMat % Rhs = 0.0_dp 12923 END IF 12924 12925 ! When visiting the routine after the 1st iteration the matrix for is already CRS 12926 IF( BCMat % Format == MATRIX_CRS ) THEN 12927 BCMat % Values = 0.0_dp 12928 BCMat % Rhs = 0.0_dp 12929 END IF 12930 12931 Dofs = Solver % Variable % Dofs 12932 Perm => Solver % Variable % Perm 12933 12934 Name = TRIM(Solver % Variable % Name)//' BCLoads' 12935 BCVar => VariableGet( Solver % Mesh % Variables, TRIM( Name ) ) 12936 IF(.NOT. ASSOCIATED( BCVar ) ) THEN 12937 CALL Info('CalculateBCLoads','Creating variable: '//TRIM(Name),Level=7) 12938 CALL VariableAddVector( Solver % Mesh % Variables,& 12939 Solver % Mesh, Solver, Name, DOFs, Perm = BCPerm ) 12940 END IF 12941 12942 END IF 12943 12944 IF( Element % BodyId == TargetBody ) THEN 12945 n = Element % TYPE % NumberOfNodes 12946 DO i=1,n 12947 IF ( BCPerm( Element % NodeIndexes(i) ) == 0 ) CYCLE 12948 DO k=0,Dofs-1 12949 Row = Dofs * BCPerm( Element % NodeIndexes(i) ) - k 12950 BCMat % rhs(Row) = BCMat % rhs(Row) + LocalRhs(Dofs*i-k) 12951 DO j=1,n 12952 DO l=0,Dofs-1 12953 Col = Dofs * Perm( Element % NodeIndexes(j) ) - l 12954 Val = LocalMatrix(Dofs*i-k,Dofs*j-l) 12955 CALL AddToMatrixElement(BCMat,Row,Col,Val) 12956 END DO 12957 END DO 12958 END DO 12959 END DO 12960 END IF 12961 12962 12963 END SUBROUTINE BCLoadsAssembly 12964 12965 12966 ! Calculate the boundary loads resulting from the action of boundary matrix. 12967 !----------------------------------------------------------------------------- 12968 SUBROUTINE BCLoadsComputation( Solver ) 12969 12970 TYPE(Solver_t) :: Solver 12971 12972 TYPE(Matrix_t), POINTER :: BCMat 12973 CHARACTER(MAX_NAME_LEN) :: Name 12974 TYPE(Variable_t), POINTER :: BCVar 12975 12976 12977 BCMat => Solver % Matrix % EMatrix 12978 IF(.NOT. ASSOCIATED( BCMat ) ) THEN 12979 CALL Fatal('BCLoadsComputation','We should have the boundary matrix!') 12980 END IF 12981 12982 CALL Info('BCLoadsComputation','Computing boundary loads',Level=6) 12983 IF( BCMat % FORMAT == MATRIX_LIST ) THEN 12984 CALL List_ToCRSMatrix( BCMat ) 12985 CALL Info('BCLoadsComputation','Matrix format changed to CRS',Level=8) 12986 END IF 12987 12988 Name = TRIM(Solver % Variable % Name)//' BCLoads' 12989 BCVar => VariableGet( Solver % Mesh % Variables, TRIM( Name ) ) 12990 IF(.NOT. ASSOCIATED( BCVar ) ) THEN 12991 CALL Fatal('BCLoadsComputation','Variable not present: '//TRIM(Name)) 12992 END IF 12993 12994 CALL MatrixVectorMultiply( BCMat, Solver % Variable % Values, BCVar % Values ) 12995 BCVar % Values = BCVar % Values - BCMat % rhs 12996 12997 CALL Info('BCLoadsComputation','All done',Level=12) 12998 12999 END SUBROUTINE BCLoadsComputation 13000 13001 13002 13003!------------------------------------------------------------------------------ 13004!> Prints the values of the CRS matrix to standard output. 13005!------------------------------------------------------------------------------ 13006 SUBROUTINE PrintMatrix( A, Parallel, CNumbering,SaveMass, SaveDamp, SaveStiff) 13007!------------------------------------------------------------------------------ 13008 TYPE(Matrix_t) :: A !< Structure holding matrix 13009 LOGICAL :: Parallel !< are we in parallel mode? 13010 LOGICAL :: CNumbering !< Continuous numbering ? 13011 LOGICAL, OPTIONAL :: SaveMass !< Should we save the mass matrix 13012 LOGICAL, OPTIONAL :: SaveDamp !< Should we save the damping matrix 13013 LOGICAL, OPTIONAL :: SaveStiff !< Should we save the stiffness matrix 13014!------------------------------------------------------------------------------ 13015 INTEGER :: i,j,k,n,IndMass,IndDamp,IndStiff,IndMax,row,col 13016 LOGICAL :: DoMass, DoDamp, DoStiff, Found 13017 REAL(KIND=dp) :: Vals(3) 13018 INTEGER, ALLOCATABLE :: Owner(:) 13019 13020 DoMass = .FALSE. 13021 IF( PRESENT( SaveMass ) ) DoMass = SaveMass 13022 IF( DoMass .AND. .NOT. ASSOCIATED( A % MassValues ) ) THEN 13023 CALL Warn('CRS_PrintMatrix','Cannot save nonexisting mass matrix') 13024 DoMass = .FALSE. 13025 END IF 13026 13027 DoDamp = .FALSE. 13028 IF( PRESENT( SaveDamp ) ) DoDamp = SaveDamp 13029 IF( DoDamp .AND. .NOT. ASSOCIATED( A % DampValues ) ) THEN 13030 CALL Warn('CRS_PrintMatrix','Cannot save nonexisting damp matrix') 13031 DoDamp = .FALSE. 13032 END IF 13033 13034 DoStiff = .TRUE. 13035 IF( PRESENT( SaveStiff ) ) DoStiff = SaveStiff 13036 IF( DoStiff .AND. .NOT. ASSOCIATED( A % Values ) ) THEN 13037 CALL Warn('CRS_PrintMatrix','Cannot save nonexisting stiff matrix') 13038 DoStiff = .FALSE. 13039 END IF 13040 13041 IF(.NOT. (DoStiff .OR. DoDamp .OR. DoMass ) ) THEN 13042 CALL Warn('CRS_PrintMatrix','Saving just the topology!') 13043 END IF 13044 13045 IndStiff = 0 13046 IndDamp = 0 13047 IndMass = 0 13048 13049 IF( DoStiff ) IndStiff = 1 13050 IF( DoDamp ) IndDamp = IndStiff + 1 13051 IF( DoMass ) IndMass = MAX( IndStiff, IndDamp ) + 1 13052 IndMax = MAX( IndStiff, IndDamp, IndMass ) 13053 13054 IF (Parallel.AND.Cnumbering) THEN 13055 n = SIZE(A % ParallelInfo % GlobalDOFs) 13056 13057 ALLOCATE( A % Gorder(n), Owner(n) ) 13058 CALL ContinuousNumbering( A % ParallelInfo, & 13059 A % Perm, A % Gorder, Owner ) 13060 END IF 13061 13062 DO i=1,A % NumberOfRows 13063 row = i 13064 IF(Parallel) THEN 13065 IF(Cnumbering) THEN 13066 row = A % Gorder(i) 13067 ELSE 13068 row = A % ParallelInfo % GlobalDOFs(i) 13069 END IF 13070 END IF 13071 DO j = A % Rows(i),A % Rows(i+1)-1 13072 13073 col = A % Cols(j) 13074 IF(Parallel) THEN 13075 IF(Cnumbering) THEN 13076 col = A % Gorder(col) 13077 ELSE 13078 col = A % ParallelInfo % GlobalDOFs(col) 13079 END IF 13080 END IF 13081 13082 WRITE(1,'(I0,A,I0,A)',ADVANCE='NO') row,' ',col,' ' 13083 13084 IF( DoStiff ) THEN 13085 Vals(IndStiff) = A % Values(j) 13086 END IF 13087 IF( DoDamp ) THEN 13088 Vals(IndDamp) = A % DampValues(j) 13089 END IF 13090 IF( DoMass ) THEN 13091 Vals(IndMass) = A % MassValues(j) 13092 END IF 13093 13094 IF( IndMax > 0 ) THEN 13095 WRITE(1,*) Vals(1:IndMax) 13096 ELSE 13097 WRITE(1,'(A)') ' ' 13098 END IF 13099 END DO 13100 END DO 13101 13102!------------------------------------------------------------------------------ 13103 END SUBROUTINE PrintMatrix 13104!------------------------------------------------------------------------------ 13105 13106 13107!------------------------------------------------------------------------------ 13108!> Prints the values of the right-hand-side vector to standard output. 13109!------------------------------------------------------------------------------ 13110 SUBROUTINE PrintRHS( A, Parallel, CNumbering ) 13111!------------------------------------------------------------------------------ 13112 TYPE(Matrix_t) :: A !< Structure holding matrix 13113 LOGICAL :: Parallel, CNumbering 13114!------------------------------------------------------------------------------ 13115 INTEGER :: i, row 13116 REAL(KIND=dp) :: Val 13117 13118 DO i=1,A % NumberOfRows 13119 row = i 13120 IF(Parallel) THEN 13121 IF(Cnumbering) THEN 13122 row = A % Gorder(i) 13123 ELSE 13124 row = A % ParallelInfo % GlobalDOFs(i) 13125 END IF 13126 END IF 13127 13128 Val = A % Rhs(i) 13129 WRITE(1,'(I0,A)',ADVANCE='NO') row,' ' 13130 IF( ABS( Val ) <= TINY( Val ) ) THEN 13131 WRITE(1,'(A)') '0.0' 13132 ELSE 13133 WRITE(1,*) Val 13134 END IF 13135 END DO 13136 13137 END SUBROUTINE PrintRHS 13138!------------------------------------------------------------------------------ 13139 13140 13141 13142 13143!------------------------------------------------------------------------------ 13144!> Solves a linear system and also calls the necessary preconditioning routines. 13145!------------------------------------------------------------------------------ 13146 RECURSIVE SUBROUTINE SolveLinearSystem( A, b, & 13147 x, Norm, DOFs, Solver, BulkMatrix ) 13148!------------------------------------------------------------------------------ 13149 USE EigenSolve 13150 13151 REAL(KIND=dp) CONTIG :: b(:), x(:) 13152 REAL(KIND=dp) :: Norm 13153 TYPE(Matrix_t), POINTER :: A 13154 INTEGER :: DOFs 13155 TYPE(Solver_t), TARGET :: Solver 13156 TYPE(Matrix_t), OPTIONAL, POINTER :: BulkMatrix 13157!------------------------------------------------------------------------------ 13158 TYPE(Variable_t), POINTER :: Var, NodalLoads 13159 TYPE(Mesh_t), POINTER :: Mesh 13160 LOGICAL :: Relax,GotIt,Stat,ScaleSystem, EigenAnalysis, HarmonicAnalysis,& 13161 BackRotation, ApplyRowEquilibration, ApplyLimiter, Parallel, & 13162 SkipZeroRhs, ComplexSystem, ComputeChangeScaled, ConstraintModesAnalysis, & 13163 RecursiveAnalysis, CalcLoads 13164 INTEGER :: n,i,j,k,l,ii,m,DOF,istat,this,mn 13165 CHARACTER(LEN=MAX_NAME_LEN) :: Method, Prec, ProcName, SaveSlot 13166 INTEGER(KIND=AddrInt) :: Proc 13167 REAL(KIND=dp), ALLOCATABLE, TARGET :: Px(:), & 13168 TempVector(:), TempRHS(:), NonlinVals(:) 13169 REAL(KIND=dp), POINTER :: Diag(:) 13170 REAL(KIND=dp) :: s,Relaxation,Beta,Gamma,bnorm,Energy,xn,bn 13171 TYPE(ValueList_t), POINTER :: Params 13172 TYPE(Matrix_t), POINTER :: Aaid, Projector, MP 13173 REAL(KIND=dp), POINTER :: mx(:), mb(:), mr(:) 13174 TYPE(Variable_t), POINTER :: IterV 13175 LOGICAL :: NormalizeToUnity, AndersonAcc, AndersonScaled, NoSolve 13176 13177 INTERFACE 13178 SUBROUTINE VankaCreate(A,Solver) 13179 USE Types 13180 TYPE(Matrix_t) :: A 13181 TYPE(Solver_t) :: Solver 13182 END SUBROUTINE VankaCreate 13183 13184 SUBROUTINE CircuitPrecCreate(A,Solver) 13185 USE Types 13186 TYPE(Matrix_t), TARGET :: A 13187 TYPE(Solver_t) :: Solver 13188 END SUBROUTINE CircuitPrecCreate 13189 13190 SUBROUTINE FetiSolver(A,x,b,Solver) 13191 USE Types 13192 TYPE(Matrix_t), POINTER :: A 13193 TYPE(Solver_t) :: Solver 13194 REAL(KIND=dp) :: x(:), b(:) 13195 END SUBROUTINE FetiSolver 13196 13197 SUBROUTINE BlockSolveExt(A,x,b,Solver) 13198 USE Types 13199 TYPE(Matrix_t), POINTER :: A 13200 TYPE(Solver_t) :: Solver 13201 REAL(KIND=dp) :: x(:), b(:) 13202 END SUBROUTINE BlockSolveExt 13203 END INTERFACE 13204!------------------------------------------------------------------------------ 13205 13206 Params => Solver % Values 13207 13208 ComplexSystem = ListGetLogical( Params, 'Linear System Complex', GotIt ) 13209 IF ( GotIt ) A % COMPLEX = ComplexSystem 13210 13211 ScaleSystem = ListGetLogical( Params, 'Linear System Scaling', GotIt ) 13212 IF ( .NOT. GotIt ) ScaleSystem = .TRUE. 13213 13214 IF( ListGetLogical( Params,'Linear System Skip Complex',GotIt ) ) THEN 13215 CALL Info('SolveLinearSystem','This time skipping complex treatment',Level=20) 13216 A % COMPLEX = .FALSE. 13217 ComplexSystem = .FALSE. 13218 END IF 13219 13220 IF( ListGetLogical( Params,'Linear System Skip Scaling',GotIt ) ) THEN 13221 CALL Info('SolveLinearSystem','This time skipping scaling',Level=20) 13222 ScaleSystem = .FALSE. 13223 END IF 13224 13225 IF( A % COMPLEX ) THEN 13226 CALL Info('SolveLinearSystem','Assuming complex valued linear system',Level=6) 13227 ELSE 13228 CALL Info('SolveLinearSystem','Assuming real valued linear system',Level=8) 13229 END IF 13230 13231!------------------------------------------------------------------------------ 13232! If parallel execution, check for parallel matrix initializations 13233!------------------------------------------------------------------------------ 13234 IF ( ParEnv % Pes>1.AND..NOT. ASSOCIATED(A % ParMatrix) ) THEN 13235 CALL ParallelInitMatrix( Solver, A ) 13236 END IF 13237 13238 IF ( ListGetLogical( Solver % Values, 'Linear System Save',GotIt )) THEN 13239 saveslot = ListGetString( Solver % Values,'Linear System Save Slot', GotIt ) 13240 IF(SaveSlot == 'linear solve') CALL SaveLinearSystem( Solver, A ) 13241 END IF 13242 13243!------------------------------------------------------------------------------ 13244 13245 n = A % NumberOfRows 13246 13247 BackRotation = ListGetLogical(Params,'Back Rotate N-T Solution',GotIt) 13248 IF (.NOT.GotIt) BackRotation=.TRUE. 13249 BackRotation = BackRotation .AND. ASSOCIATED(Solver % Variable % Perm) 13250 13251 IF ( Solver % Matrix % Lumped .AND. Solver % TimeOrder == 1 ) THEN 13252 Method = ListGetString( Params, 'Timestepping Method', GotIt) 13253 IF ( Method == 'runge-kutta' .OR. Method == 'explicit euler' ) THEN 13254 ALLOCATE(Diag(n), TempRHS(n)) 13255 13256 TempRHS= b(1:n) 13257 Diag = A % Values(A % Diag) 13258 13259 IF(ParEnv % Pes>1) THEN 13260 CALL ParallelSumVector(A,Diag) 13261 CALL ParallelSumVector(A,TempRHS) 13262 END IF 13263 13264 DO i=1,n 13265 IF ( ABS(Diag(i)) /= 0._dp ) x(i) = TempRHS(i) / Diag(i) 13266 END DO 13267 13268 DEALLOCATE(Diag, TempRHS) 13269 13270 IF (BackRotation) CALL BackRotateNTSystem( x, Solver % Variable % Perm, DOFs ) 13271 Norm = ComputeNorm(Solver, n, x) 13272 RETURN 13273 END IF 13274 END IF 13275 13276!------------------------------------------------------------------------------ 13277! These definitions are needed if chanching the iterative solver on-the-fly 13278 13279 Solver % MultiGridSolver = ( ListGetString( Params, & 13280 'Linear System Solver', GotIt ) == 'multigrid' ) 13281 Solver % MultiGridTotal = MAX( Solver % MultiGridTotal, & 13282 ListGetInteger( Params,'MG Levels', GotIt, minv=1 ) ) 13283 Solver % MultiGridTotal = MAX( Solver % MultiGridTotal, & 13284 ListGetInteger( Params,'Multigrid Levels', GotIt, minv=1 ) ) 13285 Solver % MultiGridLevel = Solver % MultigridTotal 13286!------------------------------------------------------------------------------ 13287 13288 EigenAnalysis = Solver % NOFEigenValues > 0 .AND. & 13289 ListGetLogical( Params, 'Eigen Analysis',GotIt ) 13290 13291 ConstraintModesAnalysis = ListGetLogical( Params, & 13292 'Constraint Modes Analysis',GotIt ) 13293 13294 HarmonicAnalysis = ( Solver % NOFEigenValues > 0 ) .AND. & 13295 ListGetLogical( Params, 'Harmonic Analysis',GotIt ) 13296 13297 ! These analyses types may require recursive strategies and may also have zero rhs 13298 RecursiveAnalysis = HarmonicAnalysis .OR. EigenAnalysis .OR. ConstraintModesAnalysis 13299 13300 13301 ApplyLimiter = ListGetLogical( Params,'Apply Limiter',GotIt ) 13302 SkipZeroRhs = ListGetLogical( Params,'Skip Zero Rhs Test',GotIt ) 13303#ifdef HAVE_FETI4I 13304 IF ( C_ASSOCIATED(A % PermonMatrix) ) THEN 13305 ScaleSystem = .FALSE. 13306 SkipZeroRhs = .TRUE. 13307 END IF 13308#endif 13309 13310 IF ( .NOT. ( RecursiveAnalysis .OR. ApplyLimiter .OR. SkipZeroRhs ) ) THEN 13311 bnorm = SQRT(ParallelReduction(SUM(b(1:n)**2))) 13312 IF ( bnorm <= TINY( bnorm) ) THEN 13313 CALL Info('SolveLinearSystem','Solution trivially zero!',Level=5) 13314 x = 0.0d0 13315 13316 ! Increase the nonlinear counter since otherwise some stuff may stagnate 13317 ! Normally this is done within ComputeChange 13318 iterV => VariableGet( Solver % Mesh % Variables, 'nonlin iter' ) 13319 Solver % Variable % NonlinIter = iterV % Values(1) 13320 iterV % Values(1) = iterV % Values(1) + 1 13321 Solver % Variable % Norm = 0.0_dp 13322 Solver % Variable % NonlinConverged = 1 13323 13324 RETURN 13325 END IF 13326 END IF 13327 13328 IF ( Solver % MultiGridLevel == -1 ) RETURN 13329 13330 ! Set the flags to false to allow recursive strategies for these analysis types, little dirty... 13331 IF( RecursiveAnalysis ) THEN 13332 IF( HarmonicAnalysis ) CALL ListAddLogical( Solver % Values,'Harmonic Analysis',.FALSE.) 13333 IF( EigenAnalysis ) CALL ListAddLogical( Solver % Values,'Eigen Analysis',.FALSE.) 13334 IF( ConstraintModesAnalysis ) CALL ListAddLogical( Solver % Values,'Constraint Modes Analysis',.FALSE.) 13335 END IF 13336 13337 13338!------------------------------------------------------------------------------ 13339! If solving harmonic analysis go there: 13340! -------------------------------------- 13341 IF ( HarmonicAnalysis ) THEN 13342 CALL SolveHarmonicSystem( A, Solver ) 13343 END IF 13344 13345 13346! If solving eigensystem go there: 13347! -------------------------------- 13348 IF ( EigenAnalysis ) THEN 13349 IF ( ScaleSystem ) CALL ScaleLinearSystem(Solver, A ) 13350 13351 CALL SolveEigenSystem( & 13352 A, Solver % NOFEigenValues, & 13353 Solver % Variable % EigenValues, & 13354 Solver % Variable % EigenVectors, Solver ) 13355 13356 IF ( ScaleSystem ) CALL BackScaleLinearSystem( Solver, A, EigenScaling = .TRUE. ) 13357 IF ( BackRotation ) CALL BackRotateNTSystem( x, Solver % Variable % Perm, DOFs ) 13358 13359 Norm = ComputeNorm(Solver,n,x) 13360 Solver % Variable % Norm = Norm 13361 13362 NormalizeToUnity = ListGetLogical( Solver % Values, & 13363 'Eigen System Normalize To Unity',Stat) 13364 13365 IF(NormalizeToUnity .OR. ListGetLogical( Solver % Values, & 13366 'Eigen System Mass Normalize', Stat ) ) THEN 13367 13368 CALL ScaleEigenVectors( A, Solver % Variable % EigenVectors, & 13369 SIZE(Solver % Variable % EigenValues), NormalizeToUnity ) 13370 END IF 13371 13372 CALL InvalidateVariable( CurrentModel % Meshes, Solver % Mesh, & 13373 Solver % Variable % Name ) 13374 END IF 13375 13376 13377! If solving constraint modes analysis go there: 13378! ---------------------------------------------- 13379 IF ( ConstraintModesAnalysis ) THEN 13380 CALL SolveConstraintModesSystem( A, x, b , Solver ) 13381 13382 IF ( BackRotation ) CALL BackRotateNTSystem( x, Solver % Variable % Perm, DOFs ) 13383 13384 Norm = ComputeNorm(Solver,n,x) 13385 Solver % Variable % Norm = Norm 13386 13387 CALL InvalidateVariable( CurrentModel % Meshes, Solver % Mesh, & 13388 Solver % Variable % Name ) 13389 END IF 13390 13391 13392 ! We have solved {harmonic,eigen,constraint} system and no need to continue further 13393 IF( RecursiveAnalysis ) THEN 13394 IF( HarmonicAnalysis ) CALL ListAddLogical( Solver % Values,'Harmonic Analysis',.TRUE.) 13395 IF( EigenAnalysis ) CALL ListAddLogical( Solver % Values,'Eigen Analysis',.TRUE.) 13396 IF( ConstraintModesAnalysis ) CALL ListAddLogical( Solver % Values,'Constraint Modes Analysis',.TRUE.) 13397 RETURN 13398 END IF 13399 13400 13401! Check whether b=0 since then equation Ax=b has only the trivial solution, x=0. 13402! In case of a limiter one still may need to check the limiter for contact. 13403!----------------------------------------------------------------------------- 13404 bnorm = SQRT(ParallelReduction(SUM(b(1:n)**2))) 13405 IF ( bnorm <= TINY( bnorm) .AND..NOT.SkipZeroRhs) THEN 13406 CALL Info('SolveLinearSystem','Solution trivially zero!',Level=5) 13407 x = 0.0d0 13408 13409 ! Increase the nonlinear counter since otherwise some stuff may stagnate 13410 ! Normally this is done within ComputeChange 13411 iterV => VariableGet( Solver % Mesh % Variables, 'nonlin iter' ) 13412 Solver % Variable % NonlinIter = iterV % Values(1) 13413 iterV % Values(1) = iterV % Values(1) + 1 13414 Solver % Variable % Norm = 0.0_dp 13415 Solver % Variable % NonlinConverged = 1 13416 13417 RETURN 13418 END IF 13419 13420 AndersonAcc = ListGetLogical( Params,'Nonlinear System Acceleration',GotIt ) 13421 AndersonScaled = ListgetLogical( Params,'Nonlinear System Acceleration Scaled',GotIt ) 13422 13423 IF( AndersonAcc .AND. .NOT. AndersonScaled ) THEN 13424 CALL NonlinearAcceleration( A, x, b, Solver, .TRUE., NoSolve ) 13425 IF(NoSolve) GOTO 120 13426 END IF 13427 13428! Convert rhs & initial value to the scaled system: 13429! ------------------------------------------------- 13430 IF ( ScaleSystem ) THEN 13431 ApplyRowEquilibration = ListGetLogical(Params,'Linear System Row Equilibration',GotIt) 13432 IF ( ApplyRowEquilibration ) THEN 13433 Parallel = ParEnv % PEs > 1 13434 CALL RowEquilibration(A, b, Parallel) 13435 ELSE 13436 CALL ScaleLinearSystem(Solver, A, b, x, & 13437 RhsScaling = (bnorm/=0._dp), ConstraintScaling=.TRUE. ) 13438 END IF 13439 END IF 13440 13441 ComputeChangeScaled = ListGetLogical(Params,& 13442 'Nonlinear System Compute Change in Scaled System',GotIt) 13443 IF(.NOT.GotIt) ComputeChangeScaled = .FALSE. 13444 13445 IF(ComputeChangeScaled) THEN 13446 ALLOCATE(NonlinVals(SIZE(x))) 13447 NonlinVals = x 13448 IF (ASSOCIATED(Solver % Variable % Perm)) & 13449 CALL RotateNTSystemAll(NonlinVals, Solver % Variable % Perm, DOFs) 13450 END IF 13451 13452 IF( AndersonAcc .AND. AndersonScaled ) THEN 13453 CALL NonlinearAcceleration( A, x, b, Solver, .TRUE., NoSolve ) 13454 IF( NoSolve ) GOTO 110 13455 END IF 13456 13457 ! Sometimes the r.h.s. may abruptly diminish in value resulting to significant 13458 ! convergence issues or it may be that the system scales linearly with the source. 13459 ! This flag tries to improve on the initial guess of the linear solvers, and may 13460 ! sometimes even result to the exact solution. 13461 IF( ListGetLogical( Params,'Linear System Normalize Guess',GotIt ) ) THEN 13462 ALLOCATE( TempVector(A % NumberOfRows) ) 13463 13464 IF ( ParEnv % PEs > 1 ) THEN 13465 IF( .NOT. ALLOCATED( TempRHS ) ) THEN 13466 ALLOCATE( TempRHS(A % NumberOfRows) ); TempRHS=0._dp 13467 END IF 13468 13469 Tempvector = 0._dp 13470 TempRHS(1:n) = b(1:n) 13471 CALL ParallelInitSolve( A, x, TempRHS, Tempvector ) 13472 13473 MP => ParallelMatrix(A,mx,mb,mr) 13474 mn = MP % NumberOfRows 13475 13476 TempVector = 0._dp 13477 CALL ParallelMatrixVector( A, mx, TempVector ) 13478 13479 bn = ParallelDot( mn, TempVector, mb ) 13480 xn = ParallelDot( mn, TempVector, TempVector ) 13481 DEALLOCATE( TempRHS ) 13482 ELSE 13483 CALL MatrixVectorMultiply( A, x, TempVector ) 13484 xn = SUM( TempVector(1:n)**2 ) 13485 bn = SUM( TempVector(1:n) * b(1:n) ) 13486 END IF 13487 13488 IF( xn > TINY( xn ) ) THEN 13489 x(1:n) = x(1:n) * ( bn / xn ) 13490 WRITE( Message,'(A,ES12.3)') 'Linear System Normalizing Factor: ',bn/xn 13491 CALL Info('SolveLinearSystem',Message,Level=6) 13492 END IF 13493 DEALLOCATE( TempVector ) 13494 END IF 13495 13496 IF( ListGetLogical( Params,'Linear System Nullify Guess',GotIt ) ) THEN 13497 x(1:n) = 0.0_dp 13498 END IF 13499 13500 Method = ListGetString(Params,'Linear System Solver',GotIt) 13501 CALL Info('SolveLinearSystem','Linear System Solver: '//TRIM(Method),Level=8) 13502 13503 IF (Method=='multigrid' .OR. Method=='iterative' ) THEN 13504 Prec = ListGetString(Params,'Linear System Preconditioning',GotIt) 13505 IF( GotIt ) THEN 13506 CALL Info('SolveLinearSystem','Linear System Preconditioning: '//TRIM(Prec),Level=8) 13507 IF ( Prec=='vanka' ) CALL VankaCreate(A,Solver) 13508 IF ( Prec=='circuit' ) CALL CircuitPrecCreate(A,Solver) 13509 END IF 13510 END IF 13511 13512 IF ( ParEnv % PEs <= 1 ) THEN 13513 CALL Info('SolveLinearSystem','Serial linear System Solver: '//TRIM(Method),Level=8) 13514 13515 SELECT CASE(Method) 13516 CASE('multigrid') 13517 CALL MultiGridSolve( A, x, b, & 13518 DOFs, Solver, Solver % MultiGridLevel ) 13519 CASE('iterative') 13520 CALL IterSolver( A, x, b, Solver ) 13521 CASE('feti') 13522 CALL Fatal('SolveLinearSystem', & 13523 'Feti solver available only in parallel.') 13524 CASE('block') 13525 CALL BlockSolveExt( A, x, b, Solver ) 13526 CASE DEFAULT 13527 CALL DirectSolver( A, x, b, Solver ) 13528 END SELECT 13529 ELSE 13530 CALL Info('SolveLinearSystem','Parallel linear System Solver: '//TRIM(Method),Level=8) 13531 13532 SELECT CASE(Method) 13533 CASE('multigrid') 13534 CALL MultiGridSolve( A, x, b, & 13535 DOFs, Solver, Solver % MultiGridLevel ) 13536 CASE('iterative') 13537 CALL ParallelIter( A, A % ParallelInfo, DOFs, & 13538 x, b, Solver, A % ParMatrix ) 13539 CASE('feti') 13540 CALL FetiSolver( A, x, b, Solver ) 13541 CASE('block') 13542 CALL BlockSolveExt( A, x, b, Solver ) 13543 CASE DEFAULT 13544 CALL DirectSolver( A, x, b, Solver ) 13545 END SELECT 13546 END IF 13547 13548110 IF( AndersonAcc .AND. AndersonScaled ) THEN 13549 CALL NonlinearAcceleration( A, x, b, Solver, .FALSE.) 13550 END IF 13551 13552 IF(ComputeChangeScaled) THEN 13553 CALL ComputeChange(Solver,.FALSE.,n, x, NonlinVals, Matrix=A, RHS=b ) 13554 DEALLOCATE(NonlinVals) 13555 END IF 13556 13557 IF ( ScaleSystem ) THEN 13558 IF ( ApplyRowEquilibration ) THEN 13559 CALL ReverseRowEquilibration( A, b ) 13560 ELSE 13561 CALL BackScaleLinearSystem( Solver, A, b, x, ConstraintScaling=.TRUE. ) 13562 END IF 13563 END IF 13564 13565120 IF( AndersonAcc .AND. .NOT. AndersonScaled ) THEN 13566 CALL NonlinearAcceleration( A, x, b, Solver, .FALSE.) 13567 END IF 13568 13569 Aaid => A 13570 IF (PRESENT(BulkMatrix)) THEN 13571 IF (ASSOCIATED(BulkMatrix) ) Aaid=>BulkMatrix 13572 END IF 13573 13574 NodalLoads => VariableGet( Solver % Mesh % Variables, & 13575 GetVarName(Solver % Variable) // ' Loads' ) 13576 IF( ASSOCIATED( NodalLoads ) ) THEN 13577 ! Nodal loads may be allocated but the user may have toggled 13578 ! the 'calculate loads' flag such that no load computation should be performed. 13579 CalcLoads = ListGetLogical( Solver % Values,'Calculate Loads',GotIt ) 13580 IF( .NOT. GotIt ) CalcLoads = .TRUE. 13581 IF( CalcLoads ) THEN 13582 CALL Info('SolveLinearSystem','Calculating nodal loads',Level=6) 13583 CALL CalculateLoads( Solver, Aaid, x, Dofs, .TRUE., NodalLoads ) 13584 END IF 13585 END IF 13586 13587 IF (BackRotation) THEN 13588 CALL BackRotateNTSystem( x, Solver % Variable % Perm, DOFs ) 13589 IF( ASSOCIATED( NodalLoads ) ) THEN 13590 CALL BackRotateNTSystem(NodalLoads % Values,NodalLoads % Perm,DOFs) 13591 END IF 13592 END IF 13593 13594!------------------------------------------------------------------------------ 13595 13596!------------------------------------------------------------------------------ 13597! Compute the change of the solution with different methods 13598!------------------------------------------------------------------------------ 13599 IF(.NOT.ComputeChangeScaled) THEN 13600 CALL ComputeChange(Solver,.FALSE.,n, x, Matrix=A, RHS=b ) 13601 END IF 13602 Norm = Solver % Variable % Norm 13603 13604!------------------------------------------------------------------------------ 13605 13606 Solver % Variable % PrimaryMesh => Solver % Mesh 13607 CALL InvalidateVariable( CurrentModel % Meshes, Solver % Mesh, & 13608 GetVarName(Solver % Variable) ) 13609 13610 IF ( ASSOCIATED( NodalLoads ) ) THEN 13611 NodalLoads % PrimaryMesh => Solver % Mesh 13612 CALL InvalidateVariable( CurrentModel % Meshes, Solver % Mesh, & 13613 GetVarName(NodalLoads) ) 13614 END IF 13615 13616!------------------------------------------------------------------------------ 13617! In order to be able to change the preconditioners or solvers the old matrix structures 13618! must be deallocated on request. 13619 13620 IF( ListGetLogical( Params, 'Linear System Preconditioning Deallocate', GotIt) ) THEN 13621 ! ILU preconditioning 13622 IF( ASSOCIATED(A % ILUValues) ) THEN 13623 IF( SIZE( A % ILUValues) /= SIZE(A % Values) ) & 13624 DEALLOCATE(A % ILUCols, A % ILURows, A % ILUDiag) 13625 DEALLOCATE(A % ILUValues) 13626 END IF 13627 13628 ! Multigrid solver / preconditioner 13629 IF( Solver % MultigridLevel > 0 ) THEN 13630 Aaid => A 13631 IF(ASSOCIATED( Aaid % Parent) ) THEN 13632 DO WHILE( ASSOCIATED( Aaid % Parent ) ) 13633 Aaid => Aaid % Parent 13634 END DO 13635 DO WHILE( ASSOCIATED( Aaid % Child) ) 13636 Aaid => Aaid % Child 13637 IF(ASSOCIATED(Aaid % Parent)) DEALLOCATE(Aaid % Parent ) 13638 IF(ASSOCIATED(Aaid % Ematrix)) DEALLOCATE(Aaid % Ematrix ) 13639 END DO 13640 END IF 13641 END IF 13642 END IF 13643 13644 END SUBROUTINE SolveLinearSystem 13645!------------------------------------------------------------------------------ 13646 13647!------------------------------------------------------------------------------ 13648!> Given a linear system Ax=b make a change of variables such that we will 13649!> be solving for the residual Adx=b-Ax0 where dx=x-x0. 13650!------------------------------------------------------------------------------ 13651 SUBROUTINE LinearSystemResidual( A, b, x, r ) 13652 13653 REAL(KIND=dp) CONTIG :: b(:) 13654 REAL(KIND=dp) CONTIG :: x(:) 13655 TYPE(Matrix_t), POINTER :: A 13656 REAL(KIND=dp), POINTER :: r(:) 13657 REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: TmpXVec, TmpRVec, TmpRHSVec 13658 13659 INTEGER :: i,n,nn 13660 13661 n = A % NumberOfRows 13662 13663 IF (Parenv % Pes>1) THEN 13664 CALL ParallelInitSolve(A,x,b,r) 13665 CALL ParallelMatrixVector(A,x,r,.TRUE.) 13666 ELSE 13667 CALL MatrixVectorMultiply( A, x, r) 13668 END IF 13669 13670 DO i=1,n 13671 r(i) = b(i) - r(i) 13672 END DO 13673 13674 END SUBROUTINE LinearSystemResidual 13675 13676 13677 13678!------------------------------------------------------------------------------ 13679!> Given a linear system Ax=b make a change of variables such that we will 13680!> be solving for the residual Adx=b-Ax0 where dx=x-x0. 13681!------------------------------------------------------------------------------ 13682 FUNCTION LinearSystemMaskedResidualNorm( A, b, x, ActiveRow, ActiveCol ) RESULT ( Nrm ) 13683 13684 REAL(KIND=dp) CONTIG :: b(:) 13685 REAL(KIND=dp) CONTIG :: x(:) 13686 TYPE(Matrix_t), POINTER :: A 13687 LOGICAL, DIMENSION(:) :: ActiveRow(:), ActiveCol(:) 13688 REAL(KIND=dp) :: Nrm 13689 13690 REAL(KIND=dp), ALLOCATABLE :: r(:) 13691 INTEGER :: i,n,totn 13692 REAL(KIND=dp) :: r2sum 13693 13694 n = A % NumberOfRows 13695 13696 ALLOCATE(r(n)) 13697 13698 IF (Parenv % Pes>1) THEN 13699 CALL Fatal('LinearSystemMaskedResidualNorm','Not implemented in parallel yet!') 13700! CALL ParallelMatrixVector(A, x, r, .TRUE.) 13701 ELSE 13702 CALL MaskedMatrixVectorMultiply( A, x, r, ActiveRow, ActiveCol ) 13703 END IF 13704 13705 DO i=1,n 13706 IF( ActiveRow(i) ) THEN 13707 r(i) = b(i) - r(i) 13708 END IF 13709 END DO 13710 13711 totn = NINT( ParallelReduction(1.0_dp * n) ) 13712 13713 r2sum = SUM( r**2 ) 13714 Nrm = SQRT( ParallelReduction(r2sum) / totn ) 13715 13716 DEALLOCATE( r ) 13717 13718 END FUNCTION LinearSystemMaskedResidualNorm 13719 13720 13721 13722 FUNCTION HaveConstraintMatrix( A ) RESULT( HaveConstraint ) 13723 13724 TYPE(Matrix_t), POINTER :: A 13725 LOGICAL :: HaveConstraint 13726 13727 INTEGER :: n 13728 13729 IF( .NOT. ASSOCIATED( A ) ) THEN 13730 CALL Fatal('HaveConstraintMatrix','Matrix A not associated!') 13731 END IF 13732 13733 n = 0 13734 IF ( ASSOCIATED(A % ConstraintMatrix) ) THEN 13735 IF ( A % ConstraintMatrix % NumberOFRows > 0 ) n = n + 1 13736 END IF 13737 13738 IF ( ASSOCIATED(A % AddMatrix) ) THEN 13739 IF ( A % AddMatrix % NumberOFRows > 0 ) n = n + 1 13740 END IF 13741 13742 n = ParallelReduction(n*1._dp) 13743 13744 HaveConstraint = ( n > 0 ) 13745 13746 END FUNCTION HaveConstraintMatrix 13747 13748 13749 13750!------------------------------------------------------------------------------ 13751!> Solve a system. Various additional utilities are included and 13752!> naturally a call to the linear system solver. 13753!------------------------------------------------------------------------------ 13754 RECURSIVE SUBROUTINE SolveSystem( A,ParA,b,x,Norm,DOFs,Solver ) 13755!------------------------------------------------------------------------------ 13756 REAL(KIND=dp) CONTIG, TARGET :: b(:) !< The RHS vector 13757 REAL(KIND=dp) CONTIG :: x(:) !< Previous solution on entry, new solution on exit (hopefully) 13758 REAL(KIND=dp) :: Norm !< L2 Norm of solution 13759 TYPE(Matrix_t), POINTER :: A !< The coefficient matrix 13760 INTEGER :: DOFs !< Number of degrees of freedom per node for this equation 13761 TYPE(Solver_t), TARGET :: Solver !< Holds various solver options. 13762 TYPE(SParIterSolverGlobalD_t), POINTER :: ParA !< holds info for parallel solver, 13763 !< if not executing in parallel this is just a dummy. 13764!------------------------------------------------------------------------------ 13765 TYPE(Variable_t), POINTER :: Var, NodalLoads 13766 TYPE(Mesh_t), POINTER :: Mesh, SaveMEsh 13767 LOGICAL :: Relax, Found, NeedPrevSol, Timing, ResidualMode,ConstraintMode, BlockMode, GloNum 13768 INTEGER :: n,i,j,k,l,m,istat,nrows,ncols,colsj,rowoffset 13769 CHARACTER(LEN=MAX_NAME_LEN) :: Method, ProcName, VariableName 13770 INTEGER(KIND=AddrInt) :: Proc 13771 REAL(KIND=dp) :: Relaxation,Beta,Gamma 13772 REAL(KIND=dp), ALLOCATABLE :: Diag(:), TempVector(:) 13773 REAL(KIND=dp), POINTER :: bb(:),Res(:) 13774 REAL(KIND=dp) :: t0,rt0,rst,st,ct 13775 TYPE(ValueList_t), POINTER :: Params 13776 13777 INTERFACE 13778 SUBROUTINE BlockSolveExt(A,x,b,Solver) 13779 USE Types 13780 TYPE(Matrix_t), POINTER :: A 13781 TYPE(Solver_t) :: Solver 13782 REAL(KIND=dp) :: x(:), b(:) 13783 END SUBROUTINE BlockSolveExt 13784 END INTERFACE 13785 13786 13787!------------------------------------------------------------------------------ 13788 Params => Solver % Values 13789 13790 CALL Info('SolveSystem','Solving linear system',Level=10) 13791 13792 Timing = ListCheckPrefix(Params,'Linear System Timing') 13793 IF( Timing ) THEN 13794 t0 = CPUTime(); rt0 = RealTime() 13795 END IF 13796 13797 n = A % NumberOfRows 13798 13799 ResidualMode = ListGetLogical( Params,'Linear System Residual Mode',Found ) 13800 13801 BlockMode = ListGetLogical( Params,'Linear System Block Mode',Found ) 13802 13803!------------------------------------------------------------------------------ 13804! The allocation of previous values has to be here in order to 13805! work properly with the Dirichlet elimination. 13806!------------------------------------------------------------------------------ 13807 NeedPrevSol = ResidualMode 13808 13809 IF(.NOT. NeedPrevSol ) THEN 13810 Relaxation = ListGetCReal( Params, & 13811 'Nonlinear System Relaxation Factor', Found ) 13812 IF( Found ) NeedPrevSol = (Relaxation /= 1.0_dp) 13813 END IF 13814 13815 IF(.NOT. NeedPrevSol ) THEN 13816 Method = ListGetString( Params, & 13817 'Nonlinear System Convergence Measure', Found ) 13818 NeedPrevSol = ( Method == 'residual' .OR. Method == 'solution' ) 13819 END IF 13820 13821 IF( NeedPrevSol ) THEN 13822 CALL Info('SolveSystem','Previous solution must be stored before system is solved',Level=10) 13823 Found = ASSOCIATED(Solver % Variable % NonlinValues) 13824 IF( Found ) THEN 13825 IF ( SIZE(Solver % Variable % NonlinValues) /= n) THEN 13826 DEALLOCATE(Solver % Variable % NonlinValues) 13827 Found = .FALSE. 13828 END IF 13829 END IF 13830 IF(.NOT. Found) THEN 13831 ALLOCATE( Solver % Variable % NonlinValues(n), STAT=istat ) 13832 IF ( istat /= 0 ) CALL Fatal( 'SolveSystem', 'Memory allocation error.' ) 13833 END IF 13834 Solver % Variable % NonlinValues = x(1:n) 13835 END IF 13836 13837 IF ( Solver % LinBeforeProc /= 0 ) THEN 13838 CALL Info('SolveSystem','Calling procedure before solving system',Level=7) 13839 istat = ExecLinSolveProcs( Solver % LinBeforeProc,CurrentModel,Solver, & 13840 A, b, x, n, DOFs, Norm ) 13841 IF ( istat /= 0 ) GOTO 10 13842 END IF 13843 13844 ! If residual mode is requested make change of variables: 13845 ! Ax=b -> Adx = b-Ax0 = r 13846 IF( ResidualMode ) THEN 13847 CALL Info('SolveSystem','Changing the equation to residual based mode',Level=10) 13848 ALLOCATE( Res(n) ) 13849 13850 ! If needed move the current solution to N-T coordinate system 13851 ! before computing the residual. 13852 IF (ASSOCIATED(Solver % Variable % Perm)) & 13853 CALL RotateNTSystemAll(x, Solver % Variable % Perm, DOFs) 13854 13855 CALL LinearSystemResidual( A, b, x, res ) 13856 bb => res 13857 ! Set the initial guess for the redidual system to zero 13858 x = 0.0_dp 13859 ELSE 13860 bb => b 13861 END IF 13862 13863 ConstraintMode = HaveConstraintMatrix( A ) 13864 13865 ! Here activate constraint solve only if constraints are not treated as blocks 13866 IF( BlockMode .AND. ConstraintMode ) THEN 13867 CALL Warn('SolveSystem','Matrix is constraint and block matrix, giving precedence to block nature!') 13868 END IF 13869 13870 IF( BlockMode ) THEN 13871 !ScaleSystem = ListGetLogical( Params,'Linear System Scaling', Found ) 13872 !IF(.NOT. Found ) ScaleSystem = .TRUE. 13873 !IF ( ScaleSystem ) CALL ScaleLinearSystem(Solver, A ) 13874 CALL BlockSolveExt( A, x, bb, Solver ) 13875 !IF ( ScaleSystem ) CALL BackScaleLinearSystem( Solver, A ) 13876 13877 ELSE IF ( ConstraintMode ) THEN 13878 CALL Info('SolveSystem','Solving linear system with constraint matrix',Level=10) 13879 IF( ListGetLogical( Params,'Save Constraint Matrix',Found ) ) THEN 13880 GloNum = ListGetLogical( Params,'Save Constaint Matrix Global Numbering',Found ) 13881 CALL SaveProjector(A % ConstraintMatrix,.TRUE.,'cm',Parallel=GloNum) 13882 END IF 13883 CALL SolveWithLinearRestriction( A,bb,x,Norm,DOFs,Solver ) 13884 ELSE ! standard mode 13885 CALL Info('SolveSystem','Solving linear system without constraint matrix',Level=12) 13886 CALL SolveLinearSystem( A,bb,x,Norm,DOFs,Solver ) 13887 END IF 13888 CALL Info('SolveSystem','System solved',Level=12) 13889 13890 ! Even in the residual mode the system is reverted back to complete vectors 13891 ! and we may forget about the residual. 13892 IF( ResidualMode ) DEALLOCATE( Res ) 13893 13894!------------------------------------------------------------------------------ 13895 1389610 CONTINUE 13897 13898 IF ( Solver % LinAfterProc /= 0 ) THEN 13899 CALL Info('SolveSystem','Calling procedure after solving system',Level=7) 13900 istat = ExecLinSolveProcs( Solver % LinAfterProc, CurrentModel, Solver, & 13901 A, b, x, n, DOFs, Norm ) 13902 END IF 13903 13904 IF ( Solver % TimeOrder == 2 ) THEN 13905 CALL Info('SolveSystem','Setting up PrevValues for 2nd order transient equations',Level=12) 13906 13907 IF ( ASSOCIATED( Solver % Variable % PrevValues ) ) THEN 13908 Gamma = 0.5d0 - Solver % Alpha 13909 Beta = (1.0d0 - Solver % Alpha)**2 / 4.0d0 13910 DO i=1,n 13911 Solver % Variable % PrevValues(i,2) = & 13912 (1.0d0/(Beta*Solver % dt**2))* & 13913 (x(i)-Solver % Variable % PrevValues(i,3)) - & 13914 (1.0d0/(Beta*Solver % dt))*Solver % Variable % PrevValues(i,4)+ & 13915 (1.0d0-1.0d0/(2*Beta))*Solver % Variable % PrevValues(i,5) 13916 13917 Solver % Variable % PrevValues(i,1) = & 13918 Solver % Variable % PrevValues(i,4) + & 13919 Solver % dt*((1.0d0-Gamma)*Solver % Variable % PrevValues(i,5)+& 13920 Gamma*Solver % Variable % PrevValues(i,2)) 13921 END DO 13922 END IF 13923 END IF 13924 13925 IF( Timing ) THEN 13926 st = CPUTime() - t0; 13927 rst = RealTime() - rt0 13928 13929 WRITE(Message,'(a,f8.2,f8.2,a)') 'Linear system time (CPU,REAL) for '& 13930 //GetVarName(Solver % Variable)//': ',st,rst,' (s)' 13931 CALL Info('SolveSystem',Message,Level=4) 13932 13933 IF( ListGetLogical(Params,'Linear System Timing',Found)) THEN 13934 CALL ListAddConstReal(CurrentModel % Simulation,'res: linsys cpu time '& 13935 //GetVarName(Solver % Variable),st) 13936 CALL ListAddConstReal(CurrentModel % Simulation,'res: linsys real time '& 13937 //GetVarName(Solver % Variable),rst) 13938 END IF 13939 13940 IF( ListGetLogical(Params,'Linear System Timing Cumulative',Found)) THEN 13941 ct = ListGetConstReal(CurrentModel % Simulation,'res: cum linsys cpu time '& 13942 //GetVarName(Solver % Variable),Found) 13943 st = st + ct 13944 ct = ListGetConstReal(CurrentModel % Simulation,'res: cum linsys real time '& 13945 //GetVarName(Solver % Variable),Found) 13946 rst = rst + ct 13947 CALL ListAddConstReal(CurrentModel % Simulation,'res: cum linsys cpu time '& 13948 //GetVarName(Solver % Variable),st) 13949 CALL ListAddConstReal(CurrentModel % Simulation,'res: cum linsys real time '& 13950 //GetVarName(Solver % Variable),rst) 13951 END IF 13952 13953 END IF 13954 13955 CALL Info('SolveSystem','Finished solving the system',Level=12) 13956 13957!------------------------------------------------------------------------------ 13958END SUBROUTINE SolveSystem 13959!------------------------------------------------------------------------------ 13960 13961!------------------------------------------------------------------------------ 13962!> Solve a linear eigen system. 13963!------------------------------------------------------------------------------ 13964SUBROUTINE SolveEigenSystem( StiffMatrix, NOFEigen, & 13965 EigenValues, EigenVectors,Solver ) 13966!------------------------------------------------------------------------------ 13967 USE EigenSolve 13968!------------------------------------------------------------------------------ 13969 COMPLEX(KIND=dp) :: EigenValues(:),EigenVectors(:,:) 13970 REAL(KIND=dp) :: Norm 13971 TYPE(Matrix_t), POINTER :: StiffMatrix 13972 INTEGER :: NOFEigen 13973 TYPE(Solver_t) :: Solver 13974 !------------------------------------------------------------------------------ 13975 INTEGER :: n 13976 !------------------------------------------------------------------------------ 13977 n = StiffMatrix % NumberOfRows 13978 13979 IF ( .NOT. Solver % Matrix % COMPLEX ) THEN 13980 IF ( ParEnv % PEs <= 1 ) THEN 13981 CALL ArpackEigenSolve( Solver, StiffMatrix, n, NOFEigen, & 13982 EigenValues, EigenVectors ) 13983 ELSE 13984 CALL ParallelArpackEigenSolve( Solver, StiffMatrix, n, NOFEigen, & 13985 EigenValues, EigenVectors ) 13986 END IF 13987 ELSE 13988 IF ( ParEnv % PEs <= 1 ) THEN 13989 CALL ArpackEigenSolveComplex( Solver, StiffMatrix, n/2, & 13990 NOFEigen, EigenValues, EigenVectors ) 13991 ELSE 13992 CALL ParallelArpackEigenSolveComplex( Solver, StiffMatrix, n/2, NOFEigen, & 13993 EigenValues, EigenVectors ) 13994 END IF 13995 END IF 13996 13997 13998!------------------------------------------------------------------------------ 13999END SUBROUTINE SolveEigenSystem 14000!------------------------------------------------------------------------------ 14001 14002 14003 14004!------------------------------------------------------------------------------ 14005!> Solve a linear system with permutated constraints. 14006!------------------------------------------------------------------------------ 14007SUBROUTINE SolveConstraintModesSystem( A, x, b, Solver ) 14008!------------------------------------------------------------------------------ 14009 TYPE(Matrix_t), POINTER :: A 14010 TYPE(Solver_t) :: Solver 14011 REAL(KIND=dp) CONTIG :: x(:),b(:) 14012!------------------------------------------------------------------------------ 14013 TYPE(Variable_t), POINTER :: Var 14014 INTEGER :: i,j,k,n,m 14015 LOGICAL :: PrecRecompute, Stat, Found, ComputeFluxes, Symmetric 14016 REAL(KIND=dp), POINTER CONTIG :: PValues(:) 14017 REAL(KIND=dp), ALLOCATABLE :: Fluxes(:), FluxesMatrix(:,:) 14018 CHARACTER(LEN=MAX_NAME_LEN) :: MatrixFile 14019 !------------------------------------------------------------------------------ 14020 n = A % NumberOfRows 14021 14022 Var => Solver % Variable 14023 IF( SIZE(x) /= n ) THEN 14024 CALL Fatal('SolveConstraintModesSystem','Conflicting sizes for matrix and variable!') 14025 END IF 14026 14027 m = Var % NumberOfConstraintModes 14028 IF( m == 0 ) THEN 14029 CALL Fatal('SolveConstraintModesSystem','No constraint modes?!') 14030 END IF 14031 14032 ComputeFluxes = ListGetLogical( Solver % Values,'Constraint Modes Fluxes',Found) 14033 IF( ComputeFluxes ) THEN 14034 CALL Info('SolveConstraintModesSystem','Allocating for lumped fluxes',Level=10) 14035 ALLOCATE( Fluxes( n ) ) 14036 ALLOCATE( FluxesMatrix( m, m ) ) 14037 FluxesMatrix = 0.0_dp 14038 END IF 14039 14040 14041 DO i=1,m 14042 CALL Info('SolveConstraintModesSystem','Solving for mode: '//TRIM(I2S(i)),Level=6) 14043 14044 IF( i == 2 ) THEN 14045 CALL ListAddLogical( Solver % Values,'No Precondition Recompute',.TRUE.) 14046 END IF 14047 14048 ! The matrix has been manipulated already before. This ensures 14049 ! that the system has values 1 at the constraint mode i. 14050 WHERE( Var % ConstraintModesIndeces == i ) b = A % Values(A % Diag) 14051 14052 CALL SolveSystem( A,ParMatrix,b,x,Var % Norm,Var % DOFs,Solver ) 14053 14054 WHERE( Var % ConstraintModesIndeces == i ) b = 0._dp 14055 14056 Var % ConstraintModes(i,:) = x 14057 14058 IF( ComputeFluxes ) THEN 14059 CALL Info('SolveConstraintModesSystem','Computing lumped fluxes',Level=8) 14060 PValues => A % Values 14061 A % Values => A % BulkValues 14062 Fluxes = 0.0_dp 14063 CALL MatrixVectorMultiply( A, x, Fluxes ) 14064 A % Values => PValues 14065 14066 DO j=1,n 14067 k = Var % ConstraintModesIndeces(j) 14068 IF( k > 0 ) THEN 14069 IF( i /= k ) THEN 14070 FluxesMatrix(i,k) = FluxesMatrix(i,k) - Fluxes(j) 14071 END IF 14072 FluxesMatrix(i,i) = FluxesMatrix(i,i) + Fluxes(j) 14073 END IF 14074 END DO 14075 END IF 14076 END DO 14077 14078 14079 IF( ComputeFluxes ) THEN 14080 Symmetric = ListGetLogical( Solver % Values,& 14081 'Constraint Modes Fluxes Symmetric', Found ) 14082 IF( Symmetric ) THEN 14083 FluxesMatrix = 0.5_dp * ( FluxesMatrix + TRANSPOSE( FluxesMatrix ) ) 14084 END IF 14085 14086 CALL Info( 'SolveConstraintModesSystem','Constraint Modes Fluxes', Level=5 ) 14087 DO i=1,m 14088 DO j=1,m 14089 IF( Symmetric .AND. j < i ) CYCLE 14090 WRITE( Message, '(I3,I3,ES15.5)' ) i,j,FluxesMatrix(i,j) 14091 CALL Info( 'SolveConstraintModesSystem', Message, Level=5 ) 14092 END DO 14093 END DO 14094 14095 MatrixFile = ListGetString(Solver % Values,'Constraint Modes Fluxes Filename',Found ) 14096 IF( Found ) THEN 14097 OPEN (10, FILE=MatrixFile) 14098 DO i=1,m 14099 DO j=1,m 14100 WRITE (10,'(ES17.9)',advance='no') FluxesMatrix(i,j) 14101 END DO 14102 WRITE(10,'(A)') ' ' 14103 END DO 14104 CLOSE(10) 14105 CALL Info( 'SolveConstraintModesSystem',& 14106 'Constraint modes fluxes was saved to file '//TRIM(MatrixFile),Level=5) 14107 END IF 14108 14109 DEALLOCATE( Fluxes ) 14110 END IF 14111 14112 CALL ListAddLogical( Solver % Values,'No Precondition Recompute',.FALSE.) 14113 14114!------------------------------------------------------------------------------ 14115 END SUBROUTINE SolveConstraintModesSystem 14116!------------------------------------------------------------------------------ 14117 14118 14119 14120 14121!------------------------------------------------------------------------------ 14122!> A parser of the variable name that returns the true variablename 14123!> where the inline options have been interpreted. 14124!------------------------------------------------------------------------------ 14125SUBROUTINE VariableNameParser(var_name, NoOutput, Global, Dofs, IpVariable, ElemVariable, DgVariable ) 14126 14127 CHARACTER(LEN=*) :: var_name 14128 LOGICAL, OPTIONAL :: NoOutput, Global 14129 INTEGER, OPTIONAL :: Dofs 14130 LOGICAL, OPTIONAL :: IpVariable 14131 LOGICAL, OPTIONAL :: ElemVariable 14132 LOGICAL, OPTIONAL :: DgVariable 14133 14134 INTEGER :: i,j,k,m 14135 14136 IF(PRESENT(NoOutput)) NoOutput = .FALSE. 14137 IF(PRESENT(Global)) Global = .FALSE. 14138 IF(PRESENT(Dofs)) Dofs = 0 14139 IF(PRESENT(IpVariable)) IpVariable = .FALSE. 14140 14141 DO WHILE( var_name(1:1) == '-' ) 14142 14143 m = 0 14144 IF ( SEQL(var_name, '-nooutput ') ) THEN 14145 IF(PRESENT(NoOutput)) NoOutput = .TRUE. 14146 m = 10 14147 14148 ELSE IF ( SEQL(var_name, '-global ') ) THEN 14149 IF(PRESENT(Global)) Global = .TRUE. 14150 m = 8 14151 14152 ELSE IF ( SEQL(var_name, '-ip ') ) THEN 14153 IF(PRESENT(IpVariable)) IpVariable = .TRUE. 14154 m = 4 14155 14156 ELSE IF ( SEQL(var_name, '-dg ') ) THEN 14157 IF(PRESENT(DgVariable)) DgVariable = .TRUE. 14158 m = 4 14159 14160 ELSE IF ( SEQL(var_name, '-elem ') ) THEN 14161 IF(PRESENT(ElemVariable)) ElemVariable = .TRUE. 14162 m = 6 14163 END IF 14164 14165 IF( m > 0 ) THEN 14166 var_name(1:LEN(var_name)-m) = var_name(m+1:) 14167 END IF 14168 14169 IF ( SEQL(var_name, '-dofs ') ) THEN 14170 IF(PRESENT(DOFs)) READ( var_name(7:), * ) DOFs 14171 j = LEN_TRIM( var_name ) 14172 k = 7 14173 DO WHILE( var_name(k:k) /= ' ' ) 14174 k = k + 1 14175 IF ( k > j ) EXIT 14176 END DO 14177 var_name(1:LEN(var_name)-(k+2)) = var_name(k+1:) 14178 END IF 14179 END DO 14180 14181END SUBROUTINE VariableNameParser 14182 14183 14184 !> Create permutation for fields on integration points, optionally with mask. 14185 !> The non-masked version is saved to Solver structure for reuse while the 14186 !> masked version may be unique to every variable. 14187 !----------------------------------------------------------------------------------- 14188 SUBROUTINE CreateIpPerm( Solver, MaskPerm, MaskName, SecName, UpdateOnly ) 14189 14190 TYPE(Solver_t), POINTER :: Solver 14191 INTEGER, POINTER, OPTIONAL :: MaskPerm(:) 14192 CHARACTER(LEN=MAX_NAME_LEN), OPTIONAL :: MaskName, SecName 14193 LOGICAL, OPTIONAL :: UpdateOnly 14194 14195 TYPE(Mesh_t), POINTER :: Mesh 14196 TYPE(GaussIntegrationPoints_t) :: IP 14197 TYPE(Element_t), POINTER :: Element 14198 INTEGER :: t, n, IpCount , RelOrder, nIp 14199 CHARACTER(LEN=MAX_NAME_LEN) :: EquationName 14200 LOGICAL :: Found, ActiveElem, ActiveElem2 14201 INTEGER, POINTER :: IpOffset(:) 14202 TYPE(ValueList_t), POINTER :: BF 14203 LOGICAL :: UpdatePerm 14204 14205 n = 0 14206 IF( PRESENT( MaskPerm ) ) n = n + 1 14207 IF( PRESENT( MaskName ) ) n = n + 1 14208 IF( PRESENT( SecName ) ) n = n + 1 14209 IF( PRESENT( UpdateOnly ) ) n = n + 1 14210 14211 ! Currently a lazy check 14212 IF( n /= 0 .AND. n /= 3 .AND. n /= 2) THEN 14213 CALL Fatal('CreateIpPerm','Only some optional parameter combinations are possible') 14214 END IF 14215 14216 UpdatePerm = .FALSE. 14217 IF( PRESENT( UpdateOnly ) ) UpdatePerm = UpdateOnly 14218 14219 IF( UpdatePerm ) THEN 14220 CALL Info('CreateIpPerm','Updating IP permutation table',Level=8) 14221 ELSE IF( PRESENT( MaskPerm ) ) THEN 14222 CALL Info('CreateIpPerm','Creating masked permutation for integration points',Level=8) 14223 ELSE 14224 IF( ASSOCIATED( Solver % IpTable ) ) THEN 14225 CALL Info('CreateIpPerm','IpTable already allocated, returning',Level=8) 14226 END IF 14227 CALL Info('CreateIpPerm','Creating permutation for integration points',Level=8) 14228 END IF 14229 14230 EquationName = ListGetString( Solver % Values, 'Equation', Found) 14231 IF( .NOT. Found ) THEN 14232 CALL Fatal('CreateIpPerm','Equation not present!') 14233 END IF 14234 14235 Mesh => Solver % Mesh 14236 NULLIFY( IpOffset ) 14237 14238 n = Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements 14239 14240 IF( UpdatePerm ) THEN 14241 IpOffset => MaskPerm 14242 ActiveElem = (IpOffset(2)-IpOffset(1) > 0 ) 14243 IF( n >= 2 ) ActiveElem2 = (IpOffset(3)-IpOffset(2) > 0 ) 14244 ELSE 14245 ALLOCATE( IpOffset( n + 1) ) 14246 IpOffset = 0 14247 IF( PRESENT( MaskPerm ) ) MaskPerm => IpOffset 14248 END IF 14249 IpCount = 0 14250 14251 nIp = ListGetInteger( Solver % Values,'Gauss Points on Ip Variables', Found ) 14252 14253 DO t=1,Mesh % NumberOfBulkElements + Mesh % NumberOFBoundaryElements 14254 Element => Mesh % Elements(t) 14255 14256 IF( .NOT. UpdatePerm ) THEN 14257 ActiveElem = .FALSE. 14258 IF( Element % PartIndex == ParEnv % myPE ) THEN 14259 IF ( CheckElementEquation( CurrentModel, Element, EquationName ) ) THEN 14260 IF( PRESENT( MaskName ) ) THEN 14261 BF => ListGetSection( Element, SecName ) 14262 ActiveElem = ListGetLogicalGen( BF, MaskName ) 14263 ELSE 14264 ActiveElem = .TRUE. 14265 END IF 14266 END IF 14267 END IF 14268 END IF 14269 14270 IF( ActiveElem ) THEN 14271 IF( nIp > 0 ) THEN 14272 IpCount = IpCount + nIp 14273 ELSE 14274 IP = GaussPointsAdapt( Element ) 14275 IpCount = IpCount + Ip % n 14276 END IF 14277 END IF 14278 14279 ! We are reusing the permutation table hence we must be one step ahead 14280 IF( UpdatePerm .AND. n >= t+1) THEN 14281 ActiveElem = ActiveElem2 14282 ActiveElem2 = (IpOffset(t+2)-IpOffset(t+1) > 0 ) 14283 END IF 14284 14285 IpOffset(t+1) = IpCount 14286 END DO 14287 14288 IF( .NOT. PRESENT( MaskPerm ) ) THEN 14289 ALLOCATE( Solver % IpTable ) 14290 Solver % IpTable % IpOffset => IpOffset 14291 Solver % IpTable % IpCount = IpCount 14292 END IF 14293 14294 IF( UpdatePerm ) THEN 14295 CALL Info('CreateIpPerm','Updated permutation for IP points: '//TRIM(I2S(IpCount)),Level=8) 14296 ELSE 14297 CALL Info('CreateIpPerm','Created permutation for IP points: '//TRIM(I2S(IpCount)),Level=8) 14298 END IF 14299 14300 END SUBROUTINE CreateIpPerm 14301 14302 14303 SUBROUTINE UpdateIpPerm( Solver, Perm ) 14304 14305 TYPE(Solver_t), POINTER :: Solver 14306 INTEGER, POINTER :: Perm(:) 14307 14308 CALL CreateIpPerm( Solver, Perm, UpdateOnly = .TRUE.) 14309 14310 END SUBROUTINE UpdateIpPerm 14311 14312 14313 14314!------------------------------------------------------------------------------ 14315!> Updates values for exported variables which are typically auxiliary variables derived 14316!> from the solution. 14317!------------------------------------------------------------------------------ 14318 SUBROUTINE UpdateExportedVariables( Solver ) 14319!------------------------------------------------------------------------------ 14320 TYPE(Solver_t), TARGET :: Solver 14321 14322 INTEGER :: i,j,k,l,n,m,t,bf_id,dofs,nsize,i1,i2,NoGauss 14323 CHARACTER(LEN=MAX_NAME_LEN) :: str, var_name,tmpname,condname 14324 REAL(KIND=dp), POINTER :: Values(:), Solution(:), LocalSol(:), LocalCond(:) 14325 INTEGER, POINTER :: Indexes(:), VarIndexes(:), Perm(:) 14326 LOGICAL :: Found, Conditional, GotIt, Stat, StateVariable, AllocationsDone = .FALSE. 14327 LOGICAL, POINTER :: ActivePart(:),ActiveCond(:) 14328 TYPE(Variable_t), POINTER :: ExpVariable 14329 TYPE(ValueList_t), POINTER :: ValueList 14330 TYPE(Element_t),POINTER :: Element 14331 TYPE(GaussIntegrationPoints_t) :: IP 14332 TYPE(Nodes_t) :: Nodes 14333 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 14334 REAL(KIND=dp) :: detJ 14335 TYPE(ValueHandle_t) :: LocalSol_h 14336 TYPE(Mesh_t), POINTER :: Mesh 14337 TYPE(Solver_t), POINTER :: pSolver 14338 14339 14340 SAVE LocalSol_h 14341 14342 CALL Info('UpdateExportedVariables','Updating variables, if any!',Level=20) 14343 14344 AllocationsDone = .FALSE. 14345 Mesh => Solver % Mesh 14346 14347 l = 0 14348 DO WHILE( .TRUE. ) 14349 l = l + 1 14350 14351 str = ComponentName( 'exported variable', l ) 14352 14353 var_name = ListGetString( Solver % Values, str, GotIt ) 14354 IF(.NOT. GotIt) EXIT 14355 14356 CALL Info('UpdateExportedVariables','Trying to set values for variable: '//TRIM(Var_name),Level=20) 14357 14358 CALL VariableNameParser( var_name ) 14359 14360 ExpVariable => VariableGet( Mesh % Variables, Var_name ) 14361 IF( .NOT. ASSOCIATED(ExpVariable)) CYCLE 14362 14363 CALL Info('UpdateExportedVariables','Setting values for variable: '//TRIM(Var_name),Level=20) 14364 14365 IF(.NOT. AllocationsDone ) THEN 14366 m = CurrentModel % NumberOFBodyForces 14367 ALLOCATE( ActivePart(m), ActiveCond(m) ) 14368 14369 m = Mesh % MaxElementDOFs 14370 ALLOCATE( LocalSol(m), LocalCond(m)) 14371 14372 m = CurrentModel % MaxElementNodes 14373 ALLOCATE( Basis(m), Nodes % x(m), Nodes % y(m), Nodes % z(m) ) 14374 14375 AllocationsDone = .TRUE. 14376 END IF 14377 14378 Dofs = ExpVariable % DOFs 14379 Values => ExpVariable % Values 14380 Perm => ExpVariable % Perm 14381 n = LEN_TRIM( var_name ) 14382 14383 StateVariable = ( SIZE( Values ) == DOFs ) .OR. ( ExpVariable % Type == Variable_Global ) 14384 IF( StateVariable ) THEN 14385 CALL Info('UpdateExportedVariables','Updating state variable',Level=20) 14386 IF( Dofs > 1 ) THEN 14387 tmpname = ComponentName( var_name(1:n), j ) 14388 Solution => Values( j:j ) 14389 ELSE 14390 tmpname = var_name(1:n) 14391 Solution => Values 14392 END IF 14393 14394 DO bf_id=1,CurrentModel % NumberOFBodyForces 14395 IF( ListCheckPresent( & 14396 CurrentModel % BodyForces(bf_id) % Values,TmpName ) ) THEN 14397 CALL Info('UpdateExportedVariables',& 14398 'Found a proper definition for state variable',Level=6) 14399 Solution = ListGetCReal( CurrentModel % BodyForces(bf_id) % Values,TmpName) 14400 EXIT 14401 END IF 14402 END DO 14403 CYCLE 14404 END IF 14405 14406 CALL Info('UpdateExportedVariables','Updating field variable with dofs: '//TRIM(I2S(DOFs)),Level=12) 14407 14408 14409 DO j=1,DOFs 14410 14411100 Values => ExpVariable % Values 14412 IF( Dofs > 1 ) THEN 14413 tmpname = ComponentName( var_name(1:n), j ) 14414 Solution => Values( j:: DOFs ) 14415 ELSE 14416 tmpname = var_name(1:n) 14417 Solution => Values 14418 END IF 14419 condname = TRIM(tmpname) //' Condition' 14420 14421 !------------------------------------------------------------------------------ 14422 ! Go through the Dirichlet conditions in the body force lists 14423 !------------------------------------------------------------------------------ 14424 ActivePart = .FALSE. 14425 ActiveCond = .FALSE. 14426 14427 DO bf_id=1,CurrentModel % NumberOFBodyForces 14428 ActivePart(bf_id) = ListCheckPresent( & 14429 CurrentModel % BodyForces(bf_id) % Values,TmpName ) 14430 ActiveCond(bf_id) = ListCheckPresent( & 14431 CurrentModel % BodyForces(bf_id) % Values,CondName ) 14432 END DO 14433 14434 IF ( .NOT. ANY( ActivePart ) ) CYCLE 14435 14436 CALL Info('UpdateExportedVariables','Found a proper definition in body forces',Level=8) 14437 14438 14439 IF( ExpVariable % TYPE == Variable_on_gauss_points ) THEN 14440 ! Initialize handle when doing values on Gauss points! 14441 CALL ListInitElementKeyword( LocalSol_h,'Body Force',TmpName ) 14442 END IF 14443 14444 DO t = 1, Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 14445 14446 Element => Mesh % Elements(t) 14447 IF( Element % BodyId <= 0 ) CYCLE 14448 bf_id = ListGetInteger( CurrentModel % Bodies(Element % BodyId) % Values,& 14449 'Body Force',GotIt) 14450 14451 IF(.NOT. GotIt) CYCLE 14452 IF(.NOT. ActivePart(bf_id)) CYCLE 14453 Conditional = ActiveCond(bf_id) 14454 14455 CurrentModel % CurrentElement => Element 14456 m = Element % TYPE % NumberOfNodes 14457 Indexes => Element % NodeIndexes 14458 ValueList => CurrentModel % BodyForces(bf_id) % Values 14459 14460 IF( ExpVariable % TYPE == Variable_on_gauss_points ) THEN 14461 14462 i1 = Perm( Element % ElementIndex ) 14463 i2 = Perm( Element % ElementIndex + 1 ) 14464 NoGauss = i2 - i1 14465 14466 ! This is not active here 14467 IF( NoGauss == 0 ) CYCLE 14468 14469 IP = GaussPointsAdapt( Element, Solver ) 14470 14471 IF( NoGauss /= IP % n ) THEN 14472 14473 CALL Info('UpdateExportedVariables',& 14474 'Number of Gauss points has changed, redoing permutations!',Level=8) 14475 14476 pSolver => Solver 14477 CALL UpdateIpPerm( pSolver, Perm ) 14478 nsize = MAXVAL( Perm ) 14479 14480 CALL Info('UpdateExportedVariables','Total number of new IP dofs: '//TRIM(I2S(nsize)),Level=7) 14481 14482 IF( SIZE( ExpVariable % Values ) /= ExpVariable % Dofs * nsize ) THEN 14483 DEALLOCATE( ExpVariable % Values ) 14484 ALLOCATE( ExpVariable % Values( nsize * ExpVariable % Dofs ) ) 14485 END IF 14486 ExpVariable % Values = 0.0_dp 14487 GOTO 100 14488 END IF 14489 14490 Nodes % x(1:m) = Mesh % Nodes % x(Indexes) 14491 Nodes % y(1:m) = Mesh % Nodes % y(Indexes) 14492 Nodes % z(1:m) = Mesh % Nodes % z(Indexes) 14493 14494 IF( Conditional ) THEN 14495 CALL Warn('UpdateExportedVariable','Elemental variable cannot be conditional!') 14496 END IF 14497 14498 DO k=1,IP % n 14499 stat = ElementInfo( Element, Nodes, IP % U(k), IP % V(k), & 14500 IP % W(k), detJ, Basis ) 14501 Solution(i1+k) = ListGetElementReal( LocalSol_h,Basis,Element,Found,GaussPoint=k) 14502 END DO 14503 14504 ELSE IF( ExpVariable % TYPE == Variable_on_elements ) THEN 14505 IF( Conditional ) THEN 14506 CALL Warn('UpdateExportedVariable','Elemental variables not conditional!') 14507 END IF 14508 LocalSol(1:m) = ListGetReal(ValueList, TmpName, m, Indexes(1:m) ) 14509 i = Perm( Element % ElementIndex ) 14510 IF( i > 0 ) Solution(i) = SUM( LocalSol(1:m) ) / m 14511 14512 ELSE 14513 IF( ExpVariable % TYPE == Variable_on_nodes_on_elements ) THEN 14514 VarIndexes => Element % DGIndexes 14515 ELSE 14516 VarIndexes => Indexes 14517 END IF 14518 14519 LocalSol(1:m) = ListGetReal(ValueList, TmpName, m, Indexes(1:m) ) 14520 14521 IF( Conditional ) THEN 14522 LocalCond(1:m) = ListGetReal(ValueList, CondName, m, Indexes(1:m) ) 14523 DO i=1,m 14524 IF( LocalCond(i) > 0.0_dp ) THEN 14525 IF( Perm(VarIndexes(i)) > 0 ) THEN 14526 Solution( Perm(VarIndexes(i)) ) = LocalSol(i) 14527 END IF 14528 END IF 14529 END DO 14530 ELSE 14531 IF( ALL( Perm(VarIndexes(1:m)) > 0 ) ) THEN 14532 Solution( Perm(VarIndexes(1:m)) ) = LocalSol(1:m) 14533 END IF 14534 END IF 14535 14536 END IF 14537 END DO 14538 14539 END DO 14540 END DO 14541 14542 IF( AllocationsDone ) THEN 14543 DEALLOCATE(ActivePart, ActiveCond, LocalSol, LocalCond, Basis, & 14544 Nodes % x, Nodes % y, Nodes % z ) 14545 END IF 14546 14547END SUBROUTINE UpdateExportedVariables 14548 14549 14550!------------------------------------------------------------------------------ 14551!> Derivates values for exported variables to come up with velocity and 14552!> acceleration fields. 14553!------------------------------------------------------------------------------ 14554 SUBROUTINE DerivateExportedVariables( Solver ) 14555!------------------------------------------------------------------------------ 14556 TYPE(Solver_t), TARGET :: Solver 14557 14558 TYPE(Mesh_t), POINTER :: Mesh 14559 TYPE(ValueList_t), POINTER :: Params 14560 TYPE(Variable_t), POINTER :: Var, DerVar, dtVar 14561 CHARACTER(LEN=MAX_NAME_LEN) :: str, var_name 14562 INTEGER :: VarNo 14563 LOGICAL :: Found, DoIt 14564 REAL(KIND=dp) :: dt 14565 14566 14567 CALL Info('DerivateExportedVariables','Derivating variables, if any!',Level=20) 14568 14569 Mesh => Solver % Mesh 14570 Params => Solver % Values 14571 14572 VarNo = 0 14573 DO WHILE( .TRUE. ) 14574 VarNo = VarNo + 1 14575 14576 str = ComponentName( 'exported variable', VarNo ) 14577 14578 var_name = ListGetString( Solver % Values, str, Found ) 14579 IF(.NOT. Found) EXIT 14580 14581 CALL VariableNameParser( var_name ) 14582 14583 Var => VariableGet( Mesh % Variables, Var_name ) 14584 IF( .NOT. ASSOCIATED(Var)) CYCLE 14585 IF( .NOT. ASSOCIATED(Var % PrevValues) ) CYCLE 14586 14587 str = TRIM( ComponentName(Var_name) )//' Calculate Velocity' 14588 DoIt = ListGetLogical( Params, str, Found ) 14589 IF( DoIt ) THEN 14590 str = TRIM( ComponentName(var_name) ) // ' Velocity' 14591 DerVar => VariableGet( Solver % Mesh % Variables, str ) 14592 IF(.NOT. ASSOCIATED(DerVar)) THEN 14593 CALL Warn('DerivatingExportedVariables','Variable does not exist:'//TRIM(str)) 14594 CYCLE 14595 END IF 14596 14597 dtVar => VariableGet( Solver % Mesh % Variables, 'timestep size' ) 14598 dt = dtVar % Values(1) 14599 14600 CALL Info('DerivatingExportedVariables','Computing numerical derivative for:'//TRIM(str),Level=8) 14601 DerVar % Values = (Var % Values(:) - Var % PrevValues(:,1)) / dt 14602 END IF 14603 14604 str = TRIM( ComponentName(Var_name) )//' Calculate Acceleration' 14605 DoIt = ListGetLogical( Params, str, Found ) 14606 IF( DoIt ) THEN 14607 str = TRIM( ComponentName(var_name) ) // ' Acceleration' 14608 DerVar => VariableGet( Solver % Mesh % Variables, str ) 14609 IF(.NOT. ASSOCIATED(DerVar)) THEN 14610 CALL Warn('DerivatingExportedVariables','Variable does not exist:'//TRIM(str)) 14611 CYCLE 14612 END IF 14613 14614 dtVar => VariableGet( Solver % Mesh % Variables, 'timestep size' ) 14615 dt = dtVar % Values(1) 14616 14617 CALL Info('DerivatingExportedVariables','Computing numerical derivative for:'//TRIM(str),Level=8) 14618 DerVar % Values = (Var % Values(:) - 2*Var % PrevValues(:,1) - Var % PrevValues(:,2)) / dt**2 14619 END IF 14620 14621 END DO 14622 14623END SUBROUTINE DerivateExportedVariables 14624 14625 14626 14627!------------------------------------------------------------------------------ 14628!> Eliminates bubble degrees of freedom from a local linear system. 14629!> This version is suitable for flow models with velocity and pressure as 14630!> unknowns. 14631!------------------------------------------------------------------------------ 14632SUBROUTINE NSCondensate( N, Nb, dim, K, F, F1 ) 14633!------------------------------------------------------------------------------ 14634 USE LinearAlgebra 14635 INTEGER :: N, Nb, dim 14636 REAL(KIND=dp) :: K(:,:), F(:) 14637 REAL(KIND=dp), OPTIONAL :: F1(:) 14638 14639 REAL(KIND=dp) :: Kbb(nb*dim,nb*dim) 14640 REAL(KIND=dp) :: Kbl(nb*dim,n*(dim+1)), Klb(n*(dim+1),nb*dim), Fb(nb*dim) 14641 14642 INTEGER :: m, i, j, l, p, Cdofs((dim+1)*n), Bdofs(dim*nb) 14643 14644 m = 0 14645 DO p = 1,n 14646 DO i = 1,dim+1 14647 m = m + 1 14648 Cdofs(m) = (dim+1)*(p-1) + i 14649 END DO 14650 END DO 14651 14652 m = 0 14653 DO p = 1,nb 14654 DO i = 1,dim 14655 m = m + 1 14656 Bdofs(m) = (dim+1)*(p-1) + i + n*(dim+1) 14657 END DO 14658 END DO 14659 14660 Kbb = K(Bdofs,Bdofs) 14661 Kbl = K(Bdofs,Cdofs) 14662 Klb = K(Cdofs,Bdofs) 14663 Fb = F(Bdofs) 14664 14665 CALL InvertMatrix( Kbb,nb*dim ) 14666 14667 F(1:(dim+1)*n) = F(1:(dim+1)*n) - MATMUL( Klb, MATMUL( Kbb, Fb ) ) 14668 K(1:(dim+1)*n,1:(dim+1)*n) = & 14669 K(1:(dim+1)*n,1:(dim+1)*n) - MATMUL( Klb, MATMUL( Kbb,Kbl ) ) 14670 14671 IF (PRESENT(F1)) THEN 14672 Fb = F1(Bdofs) 14673 F1(1:(dim+1)*n) = F1(1:(dim+1)*n) - MATMUL( Klb, MATMUL( Kbb, Fb ) ) 14674 END IF 14675!------------------------------------------------------------------------------ 14676END SUBROUTINE NSCondensate 14677!------------------------------------------------------------------------------ 14678 14679!------------------------------------------------------------------------------ 14680!> Subroutine for the static condensation of element bubbles when there are 14681!> as many bubbles as DOFs left in the matrix (historically this convention 14682!> was used; now the count of elementwise bubble functions can be chosen 14683!> flexibly and then the subroutine CondensateP should be called instead). 14684!------------------------------------------------------------------------------ 14685SUBROUTINE Condensate( N, K, F, F1 ) 14686!------------------------------------------------------------------------------ 14687 USE LinearAlgebra 14688 INTEGER :: N 14689 REAL(KIND=dp) :: K(:,:),F(:) 14690 REAL(KIND=dp), OPTIONAL :: F1(:) 14691!------------------------------------------------------------------------------ 14692 IF ( PRESENT(F1) ) THEN 14693 CALL CondensateP( N, N, K, F, F1 ) 14694 ELSE 14695 CALL CondensateP( N, N, K, F ) 14696 END IF 14697!------------------------------------------------------------------------------ 14698END SUBROUTINE Condensate 14699!------------------------------------------------------------------------------ 14700 14701!------------------------------------------------------------------------------ 14702!> Subroutine for condensation of p element bubbles from linear problem. 14703!> Modifies given stiffness matrix and force vector(s) 14704!------------------------------------------------------------------------------ 14705SUBROUTINE CondensatePR( N, Nb, K, F, F1 ) 14706!------------------------------------------------------------------------------ 14707 USE LinearAlgebra 14708 INTEGER :: N !< Sum of nodal, edge and face degrees of freedom. 14709 INTEGER :: Nb !< Sum of internal (bubble) degrees of freedom. 14710 REAL(KIND=dp) :: K(:,:) !< Local stiffness matrix. 14711 REAL(KIND=dp) :: F(:) !< Local force vector. 14712 REAL(KIND=dp), OPTIONAL :: F1(:) !< Local second force vector. 14713!------------------------------------------------------------------------------ 14714 REAL(KIND=dp) :: Kbb(Nb,Nb), Kbl(Nb,N), Klb(N,Nb), Fb(Nb) 14715 INTEGER :: i, Ldofs(N), Bdofs(Nb) 14716 14717 IF ( nb <= 0 ) RETURN 14718 14719 Ldofs = (/ (i, i=1,n) /) 14720 Bdofs = (/ (i, i=n+1,n+nb) /) 14721 14722 Kbb = K(Bdofs,Bdofs) 14723 Kbl = K(Bdofs,Ldofs) 14724 Klb = K(Ldofs,Bdofs) 14725 Fb = F(Bdofs) 14726 14727 CALL InvertMatrix( Kbb,nb ) 14728 14729 F(1:n) = F(1:n) - MATMUL( Klb, MATMUL( Kbb, Fb ) ) 14730 IF (PRESENT(F1)) THEN 14731 Fb = F1(Bdofs) 14732 F1(1:n) = F1(1:n) - MATMUL( Klb, MATMUL( Kbb, Fb ) ) 14733 END IF 14734 14735 K(1:n,1:n) = K(1:n,1:n) - MATMUL( Klb, MATMUL( Kbb, Kbl ) ) 14736!------------------------------------------------------------------------------ 14737END SUBROUTINE CondensatePR 14738!------------------------------------------------------------------------------ 14739 14740!------------------------------------------------------------------------------ 14741!> Subroutine for condensation of p element bubbles from complex-valued linear 14742!> problem. Modifies given stiffness matrix and force vector(s) 14743!------------------------------------------------------------------------------ 14744SUBROUTINE CondensatePC( N, Nb, K, F, F1 ) 14745!------------------------------------------------------------------------------ 14746 USE LinearAlgebra 14747 INTEGER :: N !< Sum of nodal, edge and face degrees of freedom. 14748 INTEGER :: Nb !< Sum of internal (bubble) degrees of freedom. 14749 COMPLEX(KIND=dp) :: K(:,:) !< Local stiffness matrix. 14750 COMPLEX(KIND=dp) :: F(:) !< Local force vector. 14751 COMPLEX(KIND=dp), OPTIONAL :: F1(:) !< Local second force vector. 14752!------------------------------------------------------------------------------ 14753 COMPLEX(KIND=dp) :: Kbb(Nb,Nb), Kbl(Nb,N), Klb(N,Nb), Fb(Nb) 14754 INTEGER :: i, Ldofs(N), Bdofs(Nb) 14755 14756 IF ( nb <= 0 ) RETURN 14757 14758 Ldofs = (/ (i, i=1,n) /) 14759 Bdofs = (/ (i, i=n+1,n+nb) /) 14760 14761 Kbb = K(Bdofs,Bdofs) 14762 Kbl = K(Bdofs,Ldofs) 14763 Klb = K(Ldofs,Bdofs) 14764 Fb = F(Bdofs) 14765 14766 CALL ComplexInvertMatrix( Kbb,nb ) 14767 14768 F(1:n) = F(1:n) - MATMUL( Klb, MATMUL( Kbb, Fb ) ) 14769 IF (PRESENT(F1)) THEN 14770 Fb = F1(Bdofs) 14771 F1(1:n) = F1(1:n) - MATMUL( Klb, MATMUL( Kbb, Fb ) ) 14772 END IF 14773 14774 K(1:n,1:n) = K(1:n,1:n) - MATMUL( Klb, MATMUL( Kbb, Kbl ) ) 14775!------------------------------------------------------------------------------ 14776 END SUBROUTINE CondensatePC 14777!------------------------------------------------------------------------------ 14778 14779!------------------------------------------------------------------------------ 14780!> Solves a harmonic system. 14781!------------------------------------------------------------------------------ 14782SUBROUTINE SolveHarmonicSystem( G, Solver ) 14783!------------------------------------------------------------------------------ 14784 TYPE(Solver_t) :: Solver 14785 TYPE(Matrix_t), TARGET :: G 14786!------------------------------------------------------------------------------ 14787 TYPE(Matrix_t), POINTER :: BMatrix, A => NULL() 14788 INTEGER :: i,j,k,n, kr, ki, DOFs, ne, niter 14789 LOGICAL :: stat, Found, OptimizeBW, Real_given,Imag_given 14790 CHARACTER(LEN=MAX_NAME_LEN) :: Name 14791 REAL(KIND=dp) :: Omega, norm, s 14792 REAL(KIND=dp), POINTER :: Freqv(:,:) 14793 REAL(KIND=dp), ALLOCATABLE :: x(:) 14794 REAL(KIND=dp), POINTER :: b(:) 14795 REAL(KIND=dp) :: frequency 14796 INTEGER :: Nfrequency 14797 TYPE(ValueList_t), POINTER :: BC 14798 14799 CALL Info( 'SolveHarmonicSystem', 'Solving initially transient style system as harmonic one', Level=5) 14800 14801 n = Solver % Matrix % NumberofRows 14802 DOFs = Solver % Variable % DOFs * 2 14803 14804 A => G 14805 DO WHILE( ASSOCIATED(A) ) 14806 BMatrix => A 14807 A => A % EMatrix 14808 IF ( ASSOCIATED(A) ) THEN 14809 IF ( A % COMPLEX ) THEN 14810 CALL Info('SolveHarmonicSystem','Reusing existing harmonic system',Level=10) 14811 EXIT 14812 END IF 14813 END IF 14814 END DO 14815 14816 IF ( .NOT. ASSOCIATED(A) ) THEN 14817 CALL Info('SolveHarmonicSystem','Creating new matrix for harmonic system',Level=10) 14818 14819 OptimizeBW = ListGetLogical(Solver % Values, 'Optimize Bandwidth', Found) 14820 IF ( .NOT. Found ) OptimizeBW = .TRUE. 14821 14822 A => CreateMatrix( CurrentModel, Solver, Solver % Mesh, & 14823 Solver % Variable % Perm, DOFs, MATRIX_CRS, OptimizeBW, & 14824 ListGetString( Solver % Values, 'Equation') ) 14825 A % COMPLEX = .TRUE. 14826 BMatrix % EMatrix => A 14827 ALLOCATE( A % rhs(2*n) ) 14828 14829 DO j=1,Solver % Variable % DOFs 14830 Name = ComponentName( Solver % Variable % Name, j ) 14831 DO i=1,CurrentModel % NumberOFBCs 14832 BC => CurrentModel % BCs(i) % Values 14833 real_given = ListCheckPresent( BC, Name ) 14834 imag_given = ListCheckPresent( BC, TRIM(Name) // ' im' ) 14835 14836 IF ( real_given .AND. .NOT. imag_given ) THEN 14837 CALL ListAddConstReal( BC, TRIM(Name) // ' im', 0._dp) 14838 ELSE IF ( imag_given .AND. .NOT. real_given ) THEN 14839 CALL ListAddConstReal( BC, Name, 0._dp ) 14840 END IF 14841 END DO 14842 END DO 14843 END IF 14844 14845 b => A % rhs 14846 ALLOCATE( x(2*n) ) 14847 x = 0 14848 14849 b(1:2*n:2) = G % RHS(1:n) 14850 b(2:2*n:2) = G % RHS_im(1:n) 14851 14852 14853 Nfrequency = ListGetInteger( Solver % Values,'Harmonic System Values',Found ) 14854 IF( Nfrequency > 1 ) THEN 14855 freqv => ListGetConstRealArray( Solver % Values, 'Frequency' ) 14856 ELSE 14857 Frequency = ListGetAngularFrequency( Solver % Values, Found ) / (2*PI) 14858 IF( .NOT. Found ) THEN 14859 CALL Fatal( 'SolveHarmonicSystem', '> Frequency < must be given for harmonic analysis.' ) 14860 END IF 14861 14862 Nfrequency = 1 14863 ! Add the number of frequencies even for case of one for some postprocessing stuff to work 14864 CALL ListAddInteger( Solver % Values,'Harmonic System Values',Nfrequency ) 14865 END IF 14866 14867 niter = MIN(Nfrequency,Solver % NOFEigenValues) 14868 ne=Solver % NofEigenValues 14869 Solver % NofEigenValues=0 14870 14871 DO i=1,niter 14872 IF( Nfrequency > 1 ) THEN 14873 Frequency = freqv(i,1) 14874 WRITE( Message, '(a,i5,e12.3)' ) 'Frequency sweep: ', i, frequency 14875 ELSE 14876 WRITE( Message, '(a,e12.3)' ) 'Frequency value: ', frequency 14877 END IF 14878 CALL Info( 'SolveHarmonicSystem', Message, Level=4 ) 14879 14880 omega = 2 * PI * Frequency 14881 DO k=1,n 14882 kr = A % Rows(2*(k-1)+1) 14883 ki = A % Rows(2*(k-1)+2) 14884 DO j=G % Rows(k),G % Rows(k+1)-1 14885 A % Values(kr) = G % Values(j) 14886 IF (ASSOCIATED(G % MassValues)) A % Values(kr) = & 14887 A % Values(kr) - omega**2*G % MassValues(j) 14888 IF (ASSOCIATED(G % DampValues)) THEN 14889 A % Values(kr+1) = -G % Dampvalues(j) * omega 14890 A % Values(ki) = G % Dampvalues(j) * omega 14891 END IF 14892 A % Values(ki+1) = G % Values(j) 14893 IF (ASSOCIATED(G % MassValues)) A % Values(ki+1) = & 14894 A % Values(ki+1) - omega**2*G % MassValues(j) 14895 kr = kr + 2 14896 ki = ki + 2 14897 END DO 14898 END DO 14899 14900 14901 DO j=1,Solver % Variable % DOFs 14902 Name = ComponentName( Solver % Variable % Name, j ) 14903 14904 CALL SetDirichletBoundaries( CurrentModel, A, b, Name, & 14905 2*j-1, DOFs, Solver % Variable % Perm ) 14906 14907 CALL SetDirichletBoundaries( CurrentModel, A, b, TRIM(Name) // ' im', & 14908 2*j, DOFs, Solver % Variable % Perm ) 14909 END DO 14910 14911 CALL EnforceDirichletConditions( Solver, A, b ) 14912 14913 14914 CALL SolveLinearSystem( A, b, x, Norm, DOFs, Solver ) 14915 14916 DO j=1,n 14917 Solver % Variable % EigenVectors(i,j) = & 14918 CMPLX( x(2*(j-1)+1),x(2*(j-1)+2),KIND=dp ) 14919 END DO 14920 END DO 14921 14922 Solver % NOFEigenValues = ne 14923 14924 DEALLOCATE( x ) 14925!------------------------------------------------------------------------------ 14926 END SUBROUTINE SolveHarmonicSystem 14927!------------------------------------------------------------------------------ 14928 14929 14930 14931!------------------------------------------------------------------------------ 14932!> Just toggles the initial system to harmonic one and back 14933!------------------------------------------------------------------------------ 14934SUBROUTINE ChangeToHarmonicSystem( Solver, BackToReal ) 14935!------------------------------------------------------------------------------ 14936 TYPE(Solver_t) :: Solver 14937 LOGICAL, OPTIONAL :: BackToReal 14938 !------------------------------------------------------------------------------ 14939 TYPE(Matrix_t), POINTER :: Are => NULL(), Aharm => NULL(), SaveMatrix 14940 INTEGER :: i,j,k,n, kr, ki, DOFs 14941 LOGICAL :: stat, Found, OptimizeBW, Real_given, Imag_given 14942 CHARACTER(LEN=MAX_NAME_LEN) :: Name 14943 REAL(KIND=dp) :: Omega, s, val 14944 REAL(KIND=dp), POINTER :: b(:), TmpVals(:) 14945 REAL(KIND=dp) :: frequency 14946 TYPE(ValueList_t), POINTER :: BC 14947 TYPE(Variable_t), POINTER :: TmpVar, ReVar, HarmVar, SaveVar 14948 LOGICAL :: ToReal, ParseName, AnyDirichlet, Diagonal, HarmonicReal 14949 14950 14951 IF( .NOT. ASSOCIATED( Solver % Variable ) ) THEN 14952 CALL Warn('ChangeToHarmonicSystem','Not applicable without a variable') 14953 RETURN 14954 END IF 14955 14956 IF( .NOT. ASSOCIATED( Solver % Matrix ) ) THEN 14957 CALL Warn('ChangeToHarmonicSystem','Not applicable without a matrix') 14958 RETURN 14959 END IF 14960 14961 ToReal = .FALSE. 14962 IF( PRESENT( BackToReal ) ) ToReal = BackToReal 14963 14964 IF( ToReal ) THEN 14965 IF( ASSOCIATED( Solver % Variable % Evar ) ) THEN 14966 IF( Solver % Variable % Evar % Dofs < Solver % Variable % Dofs ) THEN 14967 CALL Info('ChangeToHarmonicSystem','Changing the harmonic results back to real system!',Level=6) 14968 14969 SaveVar => Solver % Variable 14970 SaveMatrix => Solver % Matrix 14971 14972 Solver % Variable => Solver % Variable % Evar 14973 Solver % Variable % Evar => SaveVar 14974 14975 Solver % Matrix => Solver % Matrix % EMatrix 14976 Solver % Matrix % Ematrix => SaveMatrix 14977 14978 ! Eliminate cyclic dependence that is a bummer when deallocating stuff 14979 NULLIFY( Solver % Matrix % EMatrix % Ematrix ) 14980 END IF 14981 END IF 14982 RETURN 14983 END IF 14984 14985 14986 CALL Info('ChangeToHarmonicSystem','Changing the real transient system to harmonic one!',Level=6) 14987 14988 SaveMatrix => Solver % Matrix 14989 SaveVar => Solver % Variable 14990 14991 n = Solver % Matrix % NumberofRows 14992 DOFs = SaveVar % Dofs 14993 Are => Solver % Matrix 14994 14995 CALL Info('ChangeToHarmonicSystem','Number of real system rows: '//TRIM(I2S(n)),Level=16) 14996 14997 ! Obtain the frequency, it may depend on iteration step etc. 14998 Frequency = ListGetAngularFrequency( Solver % Values, Found ) / (2*PI) 14999 IF( .NOT. Found ) THEN 15000 CALL Fatal( 'ChangeToHarmonicSystem', '> Frequency < must be given for harmonic analysis.' ) 15001 END IF 15002 WRITE( Message, '(a,e12.3)' ) 'Frequency value: ', frequency 15003 CALL Info( 'ChangeToHarmonicSystem', Message, Level=5 ) 15004 omega = 2 * PI * Frequency 15005 15006 15007 CALL ListAddConstReal( CurrentModel % Simulation, 'res: frequency', Frequency ) 15008 15009 15010 HarmonicReal = ListGetLogical( Solver % Values,'Harmonic Mode Real',Found ) 15011 IF( HarmonicReal ) THEN 15012 CALL Info('ChangeToHarmonicSystem','Enforcing harmonic system to be real valued',Level=8) 15013 IF (ASSOCIATED(Are % MassValues)) THEN 15014 ARe % Values = Are % Values - omega**2* Are % MassValues 15015 ELSE 15016 CALL Fatal('ChangeToHarmonicSystem','Harmonic system requires mass!') 15017 END IF 15018 ! This is set outside so that it can be called more flexibilly 15019 CALL EnforceDirichletConditions( Solver, Are, Are % rhs ) 15020 RETURN 15021 END IF 15022 15023 15024 Diagonal = ListGetLogical( Solver % Values,'Harmonic Mode Block Diagonal',Found ) 15025 IF(.NOT. Found ) Diagonal = .NOT. ASSOCIATED(Are % DampValues) 15026 IF( Diagonal ) THEN 15027 CALL Info('ChangeToHarmonicSystem','Undamped system is assumed to be block diagonal',Level=8) 15028 END IF 15029 15030 15031 ! Find whether the matrix already exists 15032 Aharm => Are % EMatrix 15033 IF( ASSOCIATED( Aharm ) ) THEN 15034 CALL Info('ChangeToHarmonicSystem','Found existing harmonic system',Level=10) 15035 IF( ALLOCATED( Aharm % ConstrainedDOF ) ) Aharm % ConstrainedDOF = .FALSE. 15036 ELSE 15037 ! Create the matrix if it does not 15038 15039 Aharm => CreateChildMatrix( Are, Dofs, 2*Dofs, CreateRhs = .TRUE., Diagonal = Diagonal ) 15040 15041 IF( ParEnv % PEs > 1 ) THEN 15042 CALL Warn('ChangeToHarmonicSystem','ParallelInfo may not have been generated properly!') 15043 END IF 15044 15045 Aharm % COMPLEX = ListGetLogical( Solver % Values,'Linear System Complex', Found ) 15046 IF( .NOT. Found ) Aharm % COMPLEX = .NOT. Diagonal !TRUE. 15047 END IF 15048 15049 15050 ! Set the harmonic system r.h.s 15051 b => Aharm % rhs 15052 15053 IF( ASSOCIATED( Are % Rhs ) ) THEN 15054 b(1:2*n:2) = Are % RHS(1:n) 15055 ELSE 15056 b(1:2*n:2) = 0.0_dp 15057 END IF 15058 15059 IF( ASSOCIATED( Are % Rhs_im ) ) THEN 15060 b(2:2*n:2) = Are % RHS_im(1:n) 15061 ELSE 15062 b(2:2*n:2) = 0.0_dp 15063 END IF 15064 15065 IF( ASSOCIATED(Are % MassValues) ) THEN 15066 CALL Info('ChangeToHarmonicSystem','We have mass matrix values',Level=12) 15067 ELSE 15068 CALL Warn('ChangeToHarmonicSystem','We do not have mass matrix values!') 15069 END IF 15070 15071 IF( ASSOCIATED(Are % DampValues) ) THEN 15072 CALL Info('ChangeToHarmonicSystem','We have damp matrix values',Level=12) 15073 IF( Diagonal ) THEN 15074 CALL Fatal('ChangeToHarmonicSystem','Damping matrix cannot be block diagonal!') 15075 END IF 15076 ELSE 15077 CALL Info('ChangeToHarmonicSystem','We do not have damp matrix values',Level=12) 15078 END IF 15079 15080 15081 ! Set the harmonic system matrix 15082 IF( Diagonal ) THEN 15083 DO k=1,n 15084 kr = Aharm % Rows(2*(k-1)+1) 15085 ki = Aharm % Rows(2*(k-1)+2) 15086 DO j=Are % Rows(k),Are % Rows(k+1)-1 15087 val = Are % Values(j) 15088 IF (ASSOCIATED(Are % MassValues)) val = val - omega**2* Are % MassValues(j) 15089 15090 Aharm % Values(kr) = val 15091 Aharm % Values(ki) = val 15092 kr = kr + 1 15093 ki = ki + 1 15094 END DO 15095 END DO 15096 ELSE 15097 DO k=1,n 15098 kr = Aharm % Rows(2*(k-1)+1) 15099 ki = Aharm % Rows(2*(k-1)+2) 15100 DO j=Are % Rows(k),Are % Rows(k+1)-1 15101 val = Are % Values(j) 15102 IF (ASSOCIATED(Are % MassValues)) val = val - omega**2* Are % MassValues(j) 15103 15104 Aharm % Values(kr) = val 15105 Aharm % Values(ki+1) = val 15106 15107 IF (ASSOCIATED(Are % DampValues)) THEN 15108 Aharm % Values(kr+1) = -Are % Dampvalues(j) * omega 15109 Aharm % Values(ki) = Are % Dampvalues(j) * omega 15110 END IF 15111 15112 kr = kr + 2 15113 ki = ki + 2 15114 END DO 15115 END DO 15116 END IF 15117 15118 AnyDirichlet = .FALSE. 15119 15120 ! Finally set the Dirichlet conditions for the solver 15121 DO j=1,DOFs 15122 Name = ComponentName( Solver % Variable % Name, j ) 15123 DO i=1,CurrentModel % NumberOFBCs 15124 BC => CurrentModel % BCs(i) % Values 15125 real_given = ListCheckPresent( BC, Name ) 15126 imag_given = ListCheckPresent( BC, TRIM(Name) // ' im' ) 15127 15128 IF( real_given .OR. imag_given ) AnyDirichlet = .TRUE. 15129 15130 IF ( real_given .AND. .NOT. imag_given ) THEN 15131 CALL Info('ChangeToHarmonicSystem','Setting zero >'//TRIM(Name)//' im< on BC '//TRIM(I2S(i)),Level=12) 15132 CALL ListAddConstReal( BC, TRIM(Name) // ' im', 0._dp) 15133 ELSE IF ( imag_given .AND. .NOT. real_given ) THEN 15134 CALL Info('ChangeToHarmonicSystem','Setting zero >'//TRIM(Name)//'< on BC '//TRIM(I2S(i)),Level=12) 15135 CALL ListAddConstReal( BC, Name, 0._dp ) 15136 END IF 15137 END DO 15138 END DO 15139 15140 15141 15142 IF( AnyDirichlet ) THEN 15143 DO j=1,DOFs 15144 Name = ComponentName( SaveVar % Name, j ) 15145 15146 CALL SetDirichletBoundaries( CurrentModel, Aharm, b, Name, & 15147 2*j-1, 2*DOFs, SaveVar % Perm ) 15148 15149 CALL SetDirichletBoundaries( CurrentModel, Aharm, b, TRIM(Name) // ' im', & 15150 2*j, 2*DOFs, SaveVar % Perm ) 15151 END DO 15152 15153 CALL EnforceDirichletConditions( Solver, Aharm, b ) 15154 END IF 15155 15156 15157 15158 ! Create the new fields, the total one and the imaginary one 15159 !------------------------------------------------------------- 15160 k = INDEX( SaveVar % name, '[' ) 15161 ParseName = ( k > 0 ) 15162 15163 ! Name of the full complex variable not used for postprocessing 15164 IF( ParseName ) THEN 15165 Name = TRIM(SaveVar % Name(1:k-1))//' complex' 15166 ELSE 15167 Name = TRIM( SaveVar % Name )//' complex' 15168 END IF 15169 15170 CALL Info('ChangeToHarmonicSystem','Harmonic system full name: '//TRIM(Name),Level=12) 15171 15172 15173 HarmVar => VariableGet( Solver % Mesh % Variables, Name ) 15174 IF( ASSOCIATED( HarmVar ) ) THEN 15175 CALL Info('ChangeToHarmonicSystem','Reusing full system harmonic dofs',Level=12) 15176 ELSE 15177 CALL Info('ChangeToHarmonicSystem','Creating full system harmonic dofs',Level=12) 15178 CALL VariableAddVector( Solver % Mesh % Variables,Solver % Mesh,Solver, & 15179 Name,2*DOFs,Perm=SaveVar % Perm,Output=.FALSE.) 15180 HarmVar => VariableGet( Solver % Mesh % Variables, Name ) 15181 IF(.NOT. ASSOCIATED( HarmVar ) ) CALL Fatal('ChangeToHarmonicSystem','New created variable should exist!') 15182 15183 ! Repoint the values of the original solution vector 15184 HarmVar % Values(1:2*n:2) = SaveVar % Values(1:n) 15185 15186 ! It beats me why this cannot be deallocated without some NaNs later 15187 !DEALLOCATE( SaveVar % Values ) 15188 SaveVar % Values => HarmVar % Values(1:2*n:2) 15189 SaveVar % Secondary = .TRUE. 15190 15191 ! Repoint the components of the original solution 15192 IF( Dofs > 1 ) THEN 15193 DO i=1,Dofs 15194 TmpVar => VariableGet( Solver % Mesh % Variables, ComponentName( SaveVar % Name, i ) ) 15195 IF( ASSOCIATED( TmpVar ) ) THEN 15196 TmpVar % Values => HarmVar % Values(2*i-1::HarmVar % Dofs) 15197 ELSE 15198 CALL Fatal('ChangeToHarmonicSystem','Could not find re component '//TRIM(I2S(i))) 15199 END IF 15200 END DO 15201 END IF 15202 15203 IF( ParseName ) THEN 15204 Name = ListGetString( Solver % Values,'Imaginary Variable',Found ) 15205 IF(.NOT. Found ) THEN 15206 CALL Fatal('ChangeToHarmonicSystem','We need > Imaginary Variable < to create harmonic system!') 15207 END IF 15208 ELSE 15209 Name = TRIM( SaveVar % Name )//' im' 15210 CALL Info('ChangeToHarmonicSystem','Using derived name for imaginary component: '//TRIM(Name),Level=12) 15211 END IF 15212 15213 TmpVals => HarmVar % Values(2:2*n:2) 15214 CALL VariableAdd( Solver % Mesh % Variables,Solver % Mesh,Solver, & 15215 Name, DOFs,TmpVals, Perm=SaveVar % Perm,Output=.TRUE.,Secondary=.TRUE.) 15216 15217 IF( Dofs > 1 ) THEN 15218 DO i=1,Dofs 15219 TmpVals => HarmVar % Values(2*i:2*n:2*Dofs) 15220 CALL VariableAdd( Solver % Mesh % Variables,Solver % Mesh,Solver, & 15221 ComponentName(Name,i),1,TmpVals,Perm=SaveVar % Perm,Output=.TRUE.,Secondary=.TRUE.) 15222 END DO 15223 END IF 15224 15225 END IF 15226 15227 ! Now change the pointers such that when we visit the linear solver 15228 ! the system will automatically be solved as complex 15229 Solver % Variable => HarmVar 15230 Solver % Matrix => Aharm 15231 15232 ! Save the original matrix and variable in Ematrix and Evar 15233 Solver % Matrix % Ematrix => SaveMatrix 15234 Solver % Variable % Evar => SaveVar 15235 15236 ! Eliminate cyclic dependence that is a bummer when deallocating stuff 15237 ! We are toggling {Are,Aharm} in {Solver % Matrix, Solver % Matrix % Ematrix} 15238 NULLIFY( Solver % Matrix % EMatrix % Ematrix ) 15239 15240!------------------------------------------------------------------------------ 15241END SUBROUTINE ChangeToHarmonicSystem 15242!------------------------------------------------------------------------------ 15243 15244 15245 15246!------------------------------------------------------------------------------ 15247!> This subroutine will solve the system with some linear restriction. 15248!> The restriction matrix is assumed to be in the ConstraintMatrix-field of 15249!> the StiffMatrix. The restriction vector is the RHS-field of the 15250!> ConstraintMatrix. 15251!> NOTE: Only serial solver implemented so far ... 15252!------------------------------------------------------------------------------ 15253RECURSIVE SUBROUTINE SolveWithLinearRestriction( StiffMatrix, ForceVector, Solution, & 15254 Norm, DOFs, Solver ) 15255!------------------------------------------------------------------------------ 15256 IMPLICIT NONE 15257 TYPE(Matrix_t), POINTER :: StiffMatrix !< Linear equation matrix information. 15258 !< The restriction matrix is assumed to be in the EMatrix-field 15259 REAL(KIND=dp),TARGET :: ForceVector(:) !< The right hand side of the linear equation 15260 REAL(KIND=dp),TARGET :: Solution(:) !< Previous solution as input, new solution as output. 15261 REAL(KIND=dp) :: Norm !< The L2 norm of the solution. 15262 INTEGER :: DOFs !< Number of degrees of freedom of the equation. 15263 TYPE(Solver_t), TARGET :: Solver !< Linear equation solver options. 15264!------------------------------------------------------------------------------ 15265 TYPE(Solver_t), POINTER :: SolverPointer 15266 TYPE(Matrix_t), POINTER :: CollectionMatrix, RestMatrix, AddMatrix, & 15267 RestMatrixTranspose, TMat, XMat 15268 REAL(KIND=dp), POINTER CONTIG :: CollectionVector(:), RestVector(:),& 15269 AddVector(:), Tvals(:), Vals(:) 15270 REAL(KIND=dp), POINTER :: MultiplierValues(:) 15271 REAL(KIND=dp), ALLOCATABLE, TARGET :: CollectionSolution(:), TotValues(:) 15272 INTEGER :: NumberOfRows, NumberOfValues, MultiplierDOFs, istat, NoEmptyRows 15273 INTEGER :: i, j, k, l, m, n, p,q, ix, Loop 15274 TYPE(Variable_t), POINTER :: MultVar 15275 REAL(KIND=dp) :: scl, rowsum 15276 LOGICAL :: Found, ExportMultiplier, NotExplicit, Refactorize, EnforceDirichlet, EliminateDiscont, & 15277 NonEmptyRow, ComplexSystem, ConstraintScaling, UseTranspose, EliminateConstraints, & 15278 SkipConstraints 15279 SAVE MultiplierValues, SolverPointer 15280 15281 CHARACTER(LEN=MAX_NAME_LEN) :: MultiplierName, str 15282 TYPE(ListMatrix_t), POINTER :: cList 15283 TYPE(ListMatrixEntry_t), POINTER :: cPtr, cPrev, cTmp 15284 15285 INTEGER, ALLOCATABLE, TARGET :: SlavePerm(:), SlaveIPerm(:), MasterPerm(:), MasterIPerm(:) 15286 INTEGER, POINTER :: UsePerm(:), UseIPerm(:) 15287 REAL(KIND=dp), POINTER :: UseDiag(:) 15288 TYPE(ListMatrix_t), POINTER :: Lmat(:) 15289 LOGICAL :: EliminateFromMaster, EliminateSlave, Parallel, UseTreeGauge 15290 REAL(KIND=dp), ALLOCATABLE, TARGET :: SlaveDiag(:), MasterDiag(:), DiagDiag(:) 15291 LOGICAL, ALLOCATABLE :: TrueDof(:) 15292 INTEGER, ALLOCATABLE :: Iperm(:) 15293 CHARACTER(*), PARAMETER :: Caller = 'SolveWithLinearRestriction' 15294 15295 15296!------------------------------------------------------------------------------ 15297 CALL Info( Caller, ' ', Level=6 ) 15298 15299 SolverPointer => Solver 15300 Parallel = (ParEnv % PEs > 1 ) 15301 15302 NotExplicit = ListGetLogical(Solver % Values,'No Explicit Constrained Matrix',Found) 15303 IF(.NOT. Found) NotExplicit=.FALSE. 15304 15305 RestMatrix => NULL() 15306 IF(.NOT.NotExplicit) & 15307 RestMatrix => StiffMatrix % ConstraintMatrix 15308 RestVector => Null() 15309 IF(ASSOCIATED(RestMatrix)) RestVector => RestMatrix % RHS 15310 15311 AddMatrix => StiffMatrix % AddMatrix 15312 AddVector => NULL() 15313 IF(ASSOCIATED(AddMatrix)) & 15314 AddVector => AddMatrix % RHS 15315 15316 NumberOfRows = StiffMatrix % NumberOfRows 15317 15318 CollectionMatrix => StiffMatrix % CollectionMatrix 15319 Refactorize = ListGetLogical(Solver % Values,'Linear System Refactorize',Found) 15320 IF(.NOT.Found) Refactorize = .TRUE. 15321 15322 IF(ASSOCIATED(CollectionMatrix)) THEN 15323 IF(Refactorize.AND..NOT.NotExplicit) THEN 15324 CALL Info( Caller,'Freeing previous collection matrix structures',Level=10) 15325 CALL FreeMatrix(CollectionMatrix) 15326 CollectionMatrix => NULL() 15327 ELSE 15328 CALL Info( Caller,'Keeping previous collection matrix structures',Level=10) 15329 END IF 15330 END IF 15331 15332 IF(.NOT.ASSOCIATED(CollectionMatrix)) THEN 15333 CollectionMatrix => AllocateMatrix() 15334 CollectionMatrix % FORMAT = MATRIX_LIST 15335 ELSE 15336 DEALLOCATE(CollectionMatrix % RHS) 15337 CollectionMatrix % Values = 0.0_dp 15338 END IF 15339 IF(NotExplicit) CollectionMatrix % ConstraintMatrix => StiffMatrix % ConstraintMatrix 15340 15341 NumberOfRows = StiffMatrix % NumberOfRows 15342 IF(ASSOCIATED(AddMatrix)) NumberOfRows = MAX(NumberOfRows,AddMatrix % NumberOfRows) 15343 EliminateConstraints = ListGetLogical( Solver % Values, 'Eliminate Linear Constraints', Found) 15344 IF(ASSOCIATED(RestMatrix)) THEN 15345 IF(.NOT.EliminateConstraints) & 15346 NumberOfRows = NumberOFRows + RestMatrix % NumberOfRows 15347 END IF 15348 15349 ALLOCATE( CollectionMatrix % RHS( NumberOfRows ), & 15350 CollectionSolution( NumberOfRows ), STAT = istat ) 15351 IF ( istat /= 0 ) CALL Fatal( Caller, 'Memory allocation error.' ) 15352 15353 CollectionVector => CollectionMatrix % RHS 15354 CollectionVector = 0.0_dp 15355 CollectionSolution = 0.0_dp 15356 15357!------------------------------------------------------------------------------ 15358! If multiplier should be exported, allocate memory and export the variable. 15359!------------------------------------------------------------------------------ 15360 15361 ExportMultiplier = ListGetLogical( Solver % Values, 'Export Lagrange Multiplier', Found ) 15362 IF ( .NOT. Found ) ExportMultiplier = .FALSE. 15363 15364 15365 IF ( ExportMultiplier ) THEN 15366 MultiplierName = ListGetString( Solver % Values, 'Lagrange Multiplier Name', Found ) 15367 IF ( .NOT. Found ) THEN 15368 CALL Info( Caller, & 15369 'Lagrange Multiplier Name set to LagrangeMultiplier', Level=6 ) 15370 MultiplierName = "LagrangeMultiplier" 15371 END IF 15372 15373 MultVar => VariableGet(Solver % Mesh % Variables, MultiplierName) 15374 j = 0 15375 IF(ASSOCIATED(RestMatrix)) j = RestMatrix % NumberofRows 15376 IF(ASSOCIATED(AddMatrix)) j = j+MAX(0,AddMatrix % NumberofRows-StiffMatrix % NumberOfRows) 15377 15378 IF ( .NOT. ASSOCIATED(MultVar) ) THEN 15379 ALLOCATE( MultiplierValues(j), STAT=istat ) 15380 IF ( istat /= 0 ) CALL Fatal(Caller,'Memory allocation error.') 15381 15382 MultiplierValues = 0.0_dp 15383 CALL VariableAdd(Solver % Mesh % Variables, Solver % Mesh, SolverPointer, & 15384 MultiplierName, 1, MultiplierValues) 15385 END IF 15386 MultVar => VariableGet(Solver % Mesh % Variables, MultiplierName) 15387 15388 MultiplierValues => MultVar % Values 15389 15390 IF (j>SIZE(MultiplierValues)) THEN 15391 ALLOCATE(MultiplierValues(j)); MultiplierValues=0._dp 15392 MultiplierValues(1:SIZE(MultVar % Values)) = MultVar % Values 15393 DEALLOCATE(MultVar % Values) 15394 MultVar % Values => MultiplierValues 15395 END IF 15396 ELSE 15397 MultiplierValues => NULL() 15398 END IF 15399 15400 UseTreeGauge = ListGetlogical( Solver % Values, 'Use Tree Gauge', Found ) 15401 15402!------------------------------------------------------------------------------ 15403! Put the RestMatrix to lower part of CollectionMatrix 15404!------------------------------------------------------------------------------ 15405 15406 EnforceDirichlet = ListGetLogical( Solver % Values, 'Enforce Exact Dirichlet BCs',Found) 15407 IF(.NOT.Found) EnforceDirichlet = .TRUE. 15408 EnforceDirichlet = EnforceDirichlet .AND. ALLOCATED(StiffMatrix % ConstrainedDOF) 15409 15410 ComplexSystem = StiffMatrix % COMPLEX 15411 ComplexSystem = ComplexSystem .OR. ListGetLogical( Solver % Values, & 15412 'Linear System Complex', Found ) 15413 15414 UseTranspose = ListGetLogical( Solver % Values, 'Use Transpose values', Found) 15415 15416 IF(ASSOCIATED(RestMatrix).AND..NOT.EliminateConstraints) THEN 15417 15418 CALL Info(Caller,'Adding ConstraintMatrix into CollectionMatrix',Level=8) 15419 CALL Info(Caller,'Number of Rows in constraint matrix: '& 15420 //TRIM(I2S(RestMatrix % NumberOfRows)),Level=12) 15421 CALL Info(Caller,'Number of Nofs in constraint matrix: '& 15422 //TRIM(I2S(SIZE(RestMatrix % Values))),Level=12) 15423 15424 NoEmptyRows = 0 15425 ConstraintScaling = ListGetLogical(Solver % Values, 'Constraint Scaling',Found) 15426 IF(ConstraintScaling) THEN 15427 rowsum = ListGetConstReal( Solver % Values, 'Constraint Scale', Found) 15428 IF(Found) RestMatrix % Values = RestMatrix % Values * rowsum 15429 END IF 15430 15431 ALLOCATE( iperm(SIZE(Solver % Variable % Perm)) ) 15432 iperm = 0 15433 DO i=1,SIZE(Solver % Variable % Perm) 15434 IF ( Solver % Variable % Perm(i)>0) Iperm(Solver % Variable % Perm(i))=i 15435 END DO 15436 15437 DO i=RestMatrix % NumberOfRows,1,-1 15438 15439 k=StiffMatrix % NumberOfRows 15440 IF(ASSOCIATED(AddMatrix)) k=MAX(k,AddMatrix % NumberOfRows) 15441 k=k+i 15442 15443 CALL AddToMatrixElement( CollectionMatrix,k,k,0._dp ) 15444 IF(ComplexSystem) THEN 15445 IF(MOD(k,2)==0) THEN 15446 CALL AddToMatrixElement( CollectionMatrix,k,k-1,0._dp ) 15447 ELSE 15448 CALL AddToMatrixElement( CollectionMatrix,k,k+1,0._dp ) 15449 END IF 15450 END IF 15451 NonEmptyRow = .FALSE. 15452 15453 rowsum = 0._dp 15454 l = -1 15455 DO j=RestMatrix % Rows(i+1)-1,RestMatrix % Rows(i),-1 15456 IF(RestMatrix % Cols(j)==k) l=j 15457 rowsum = rowsum + ABS(RestMatrix % Values(j)) 15458 END DO 15459 15460 IF(rowsum>EPSILON(1._dp)) THEN 15461 IF(ConstraintScaling) THEN 15462 IF(l<=0.OR.l>0.AND.RestMatrix % Values(l)==0) THEN 15463 DO j=RestMatrix % Rows(i+1)-1,RestMatrix % Rows(i),-1 15464 RestMatrix % Values(j) = RestMatrix % values(j)/rowsum 15465 END DO 15466 RestMatrix % RHS(i) = RestMatrix % RHS(i) / rowsum 15467 END IF 15468 END IF 15469 15470 DO j=RestMatrix % Rows(i+1)-1,RestMatrix % Rows(i),-1 15471 Found = .TRUE. 15472 15473 ! Skip non-positive column indexes 15474 IF( RestMatrix % Cols(j) <= 0 ) CYCLE 15475 IF ( .NOT. ComplexSystem ) THEN 15476 IF( ABS(RestMatrix % Values(j)) < EPSILON(1._dp)*rowsum ) CYCLE 15477 END IF 15478 15479 IF (EnforceDirichlet .AND. RestMatrix % Cols(j) <= StiffMatrix % NumberOfRows) & 15480 Found = .NOT.StiffMatrix % ConstrainedDOF(RestMatrix % Cols(j)) 15481 15482 IF(Found) THEN 15483 IF (ASSOCIATED(RestMatrix % TValues)) THEN 15484 CALL AddToMatrixElement( CollectionMatrix, & 15485 RestMatrix % Cols(j), k, RestMatrix % TValues(j)) 15486 ELSE 15487 CALL AddToMatrixElement( CollectionMatrix, & 15488 RestMatrix % Cols(j), k, RestMatrix % Values(j)) 15489 END IF 15490 15491 IF (UseTranspose .AND. ASSOCIATED(RestMatrix % TValues)) THEN 15492 CALL AddToMatrixElement( CollectionMatrix, & 15493 k, RestMatrix % Cols(j), RestMatrix % TValues(j)) 15494 NonEmptyRow = NonEmptyRow .OR. RestMatrix % TValues(j) /= 0 15495 ELSE 15496 CALL AddToMatrixElement( CollectionMatrix, & 15497 k, RestMatrix % Cols(j), RestMatrix % Values(j)) 15498 NonEmptyRow = NonEmptyRow .OR. RestMatrix % Values(j) /= 0 15499 END IF 15500 ELSE 15501 IF (UseTranspose .AND. ASSOCIATED(RestMatrix % TValues)) THEN 15502 CollectionVector(k) = CollectionVector(k) - & 15503 RestMatrix % TValues(j) * ForceVector(RestMatrix % Cols(j)) / & 15504 StiffMatrix % Values(StiffMatrix % Diag(RestMatrix % Cols(j))) 15505! CALL AddToMatrixElement( CollectionMatrix, & 15506! k, RestMatrix % Cols(j), RestMatrix % TValues(j) ) 15507! NonEmptyRow = NonEmptyRow .OR. RestMatrix % TValues(j) /= 0 15508 ELSE 15509 CollectionVector(k) = CollectionVector(k) - & 15510 RestMatrix % Values(j) * ForceVector(RestMatrix % Cols(j)) / & 15511 StiffMatrix % Values(StiffMatrix % Diag(RestMatrix % Cols(j))) 15512! CALL AddToMatrixElement( CollectionMatrix, & 15513! k, RestMatrix % Cols(j), RestMatrix % Values(j) ) 15514! NonEmptyRow = NonEmptyRow .OR. RestMatrix % Values(j) /= 0 15515 END IF 15516 END IF 15517 15518 END DO 15519 END IF 15520 15521 Found = .TRUE. 15522 IF (EnforceDirichlet) THEN 15523 IF(ASSOCIATED(RestMatrix % InvPerm)) THEN 15524 l = RestMatrix % InvPerm(i) 15525 IF(l>0) THEN 15526 l = MOD(l-1,StiffMatrix % NumberOfRows)+1 15527 IF(StiffMatrix % ConstrainedDOF(l)) THEN 15528 l = iperm((l-1)/Solver % Variable % DOFs+1) 15529 IF (l<=Solver % Mesh % NumberOfNodes) THEN 15530 Found = .FALSE. 15531 CALL ZeroRow(CollectionMatrix,k) 15532 CollectionVector(k) = 0 15533 CALL SetMatrixElement(CollectionMatrix,k,k,1._dp) 15534 END IF 15535 END IF 15536 END IF 15537 END IF 15538 END IF 15539 15540 ! If there is no matrix entry, there can be no non-zero r.h.s. 15541 IF ( Found ) THEN 15542 IF( .NOT.NonEmptyRow ) THEN 15543 NoEmptyRows = NoEmptyRows + 1 15544 CollectionVector(k) = 0._dp 15545! might not be the right thing to do in parallel!! 15546 IF(UseTreeGauge) THEN 15547 CALL SetMatrixElement( CollectionMatrix,k,k,1._dp ) 15548 END IF 15549 ELSE 15550 IF( ASSOCIATED( RestVector ) ) CollectionVector(k) = CollectionVector(k) + RestVector(i) 15551 END IF 15552 END IF 15553 END DO 15554 15555 IF( NoEmptyRows > 0 ) THEN 15556 CALL Info(Caller,& 15557 'Constraint Matrix in partition '//TRIM(I2S(ParEnv % MyPe))// & 15558 ' has '//TRIM(I2S(NoEmptyRows))// & 15559 ' empty rows out of '//TRIM(I2S(RestMatrix % NumberOfRows)), & 15560 Level=6 ) 15561 END IF 15562 15563 CALL Info(Caller,'Finished Adding ConstraintMatrix',Level=12) 15564 END IF 15565 15566!------------------------------------------------------------------------------ 15567! Put the AddMatrix to upper part of CollectionMatrix 15568!------------------------------------------------------------------------------ 15569 IF(ASSOCIATED(AddMatrix)) THEN 15570 15571 CALL Info(Caller,'Adding AddMatrix into CollectionMatrix',Level=10) 15572 15573 DO i=AddMatrix % NumberOfRows,1,-1 15574 15575 Found = .TRUE. 15576 IF (EnforceDirichlet .AND. i<=StiffMatrix % NumberOFRows) & 15577 Found = .NOT.StiffMatrix % ConstrainedDOF(i) 15578 15579 IF(Found) THEN 15580 Found = .FALSE. 15581 DO j=AddMatrix % Rows(i+1)-1,AddMatrix % Rows(i),-1 15582 CALL AddToMatrixElement( CollectionMatrix, & 15583 i, AddMatrix % Cols(j), AddMatrix % Values(j)) 15584 IF (i == AddMatrix % Cols(j)) Found = .TRUE. 15585 END DO 15586 15587 CollectionVector(i) = CollectionVector(i) + AddVector(i) 15588 IF (.NOT.Found) THEN 15589 CALL AddToMatrixElement( CollectionMatrix, i, i, 0._dp ) 15590 IF(ComplexSystem) THEN 15591 IF(MOD(i,2)==0) THEN 15592 CALL AddToMatrixElement( CollectionMatrix,i,i-1,0._dp ) 15593 ELSE 15594 CALL AddToMatrixElement( CollectionMatrix,i,i+1,0._dp ) 15595 END IF 15596 END IF 15597 END IF 15598 END IF 15599 END DO 15600 CALL Info(Caller,'Finished Adding AddMatrix',Level=12) 15601 END IF 15602 15603!------------------------------------------------------------------------------ 15604! Put the StiffMatrix to upper part of CollectionMatrix 15605!------------------------------------------------------------------------------ 15606 CALL Info(Caller,'Adding Stiffness Matrix into CollectionMatrix',Level=10) 15607 15608 DO i=StiffMatrix % NumberOfRows,1,-1 15609 DO j=StiffMatrix % Rows(i+1)-1,StiffMatrix % Rows(i),-1 15610 CALL AddToMatrixElement( CollectionMatrix, & 15611 i, StiffMatrix % Cols(j), StiffMatrix % Values(j) ) 15612 END DO 15613 CollectionVector(i) = CollectionVector(i) + ForceVector(i) 15614 END DO 15615 15616!------------------------------------------------------------------------------ 15617! Eliminate constraints instead of adding the Lagrange coefficient equations. 15618! Assumes biorthogonal basis for Lagrange coefficient interpolation, but not 15619! necessarily biorthogonal constraint equation test functions. 15620!------------------------------------------------------------------------------ 15621 IF (ASSOCIATED(RestMatrix).AND.EliminateConstraints) THEN 15622 CALL Info(Caller,'Eliminating Constraints from CollectionMatrix',Level=10) 15623 15624 n = StiffMatrix % NumberOfRows 15625 m = RestMatrix % NumberOfRows 15626 15627 ALLOCATE(SlaveDiag(m),MasterDiag(m),SlavePerm(n),MasterPerm(n),& 15628 SlaveIPerm(m),MasterIPerm(m),DiagDiag(m)) 15629 SlavePerm = 0; SlaveIPerm = 0; 15630 MasterPerm = 0; MasterIPerm = 0 15631 15632 Tvals => RestMatrix % TValues 15633 IF (.NOT.ASSOCIATED(Tvals)) Tvals => RestMatrix % Values 15634 15635 ! Extract diagonal entries for constraints: 15636 !------------------------------------------ 15637 CALL Info(Caller,'Extracting diagonal entries for constraints',Level=15) 15638 DO i=1, RestMatrix % NumberOfRows 15639 m = RestMatrix % InvPerm(i) 15640 15641 IF( m == 0 ) THEN 15642 PRINT *,'InvPerm is zero:',ParEnv % MyPe, i 15643 CYCLE 15644 END IF 15645 15646 m = MOD(m-1,n) + 1 15647 SlavePerm(m) = i 15648 SlaveIperm(i) = m 15649 15650 DO j=RestMatrix % Rows(i), RestMatrix % Rows(i+1)-1 15651 k = RestMatrix % Cols(j) 15652 IF(k>n) THEN 15653 DiagDiag(i) = Tvals(j) 15654 CYCLE 15655 END IF 15656 15657 IF( ABS( TVals(j) ) < TINY( 1.0_dp ) ) THEN 15658 PRINT *,'Tvals too small',ParEnv % MyPe,j,i,k,RestMatrix % InvPerm(i),Tvals(j) 15659 END IF 15660 15661 IF(k == RestMatrix % InvPerm(i)) THEN 15662 SlaveDiag(i) = Tvals(j) 15663 ELSE 15664 MasterDiag(i) = Tvals(j) 15665 MasterPerm(k) = i 15666 MasterIperm(i) = k 15667 END IF 15668 END DO 15669 END DO 15670 END IF 15671 15672 IF (ASSOCIATED(RestMatrix).AND.EliminateConstraints) THEN 15673 EliminateSlave = ListGetLogical( Solver % values, 'Eliminate Slave',Found ) 15674 EliminateFromMaster = ListGetLogical( Solver % values, 'Eliminate From Master',Found ) 15675 15676 IF(EliminateFromMaster) THEN 15677 CALL Info(Caller,'Eliminating from master',Level=15) 15678 UsePerm => MasterPerm 15679 UseDiag => MasterDiag 15680 UseIPerm => MasterIPerm 15681 ELSE 15682 CALL Info(Caller,'Eliminating from slave',Level=15) 15683 UsePerm => SlavePerm 15684 UseDiag => SlaveDiag 15685 UseIPerm => SlaveIPerm 15686 END IF 15687 15688 IF(UseTranspose) THEN 15689 Vals => Tvals 15690 ELSE 15691 Vals => RestMatrix % Values 15692 END IF 15693 END IF 15694 15695 IF ( ParEnv % Pes>1 ) THEN 15696 EliminateDiscont = ListGetLogical( Solver % values, 'Eliminate Discont',Found ) 15697 IF( EliminateDiscont ) THEN 15698 CALL totv( StiffMatrix, SlaveDiag, SlaveIPerm ) 15699 CALL totv( StiffMatrix, DiagDiag, SlaveIPerm ) 15700 CALL totv( StiffMatrix, MasterDiag, MasterIPerm ) 15701 CALL tota( StiffMatrix, TotValues, SlavePerm ) 15702 END IF 15703 ELSE 15704 EliminateDiscont = .FALSE. 15705 END IF 15706 15707 IF (ASSOCIATED(RestMatrix).AND.EliminateConstraints) THEN 15708 ! Replace elimination equations by the constraints (could done be as a postprocessing 15709 ! step, if eq's totally eliminated from linsys.) 15710 ! ---------------------------------------------------------------------------------- 15711 CALL Info(Caller,'Deleting rows from equation to be eliminated',Level=15) 15712 15713 Lmat => CollectionMatrix % ListMatrix 15714 DO m=1,RestMatrix % NumberOfRows 15715 i = UseIPerm(m) 15716 CALL List_DeleteRow(Lmat, i, Keep=.TRUE.) 15717 END DO 15718 15719 CALL Info(Caller,'Copying rows from constraint matrix to eliminate dofs',Level=15) 15720 DO m=1,RestMatrix % NumberOfRows 15721 i = UseIPerm(m) 15722 DO l=RestMatrix % Rows(m+1)-1, RestMatrix % Rows(m), -1 15723 j = RestMatrix % Cols(l) 15724 15725 ! skip l-coeffient entries, handled separately afterwards: 15726 ! -------------------------------------------------------- 15727 IF(j > n) CYCLE 15728 15729 CALL List_AddToMatrixElement( Lmat, i, j, Vals(l) ) 15730 END DO 15731 CollectionVector(i) = RestVector(m) 15732 END DO 15733 15734 ! Eliminate slave dof cycles: 15735 ! --------------------------- 15736 Xmat => RestMatrix 15737 Found = .TRUE. 15738 Loop = 0 15739 DO WHILE(Found) 15740 DO i=Xmat % NumberofRows,1,-1 15741 q = 0 15742 DO j = Xmat % Rows(i+1)-1, Xmat % Rows(i),-1 15743 k = Xmat % Cols(j) 15744 IF(k>n) CYCLE 15745 IF(UsePerm(k)>0 .AND. ABS(TVals(j))>AEPS) q=q+1 15746 END DO 15747 IF(q>1) EXIT 15748 END DO 15749 Found = q>1 15750 15751 Tmat => Xmat 15752 IF(Found) THEN 15753 Loop = Loop + 1 15754 CALL Info(Caller,'Recursive elimination round: '//TRIM(I2S(Loop)),Level=15) 15755 15756 Tmat => AllocateMatrix() 15757 Tmat % Format = MATRIX_LIST 15758 15759 DO i=Xmat % NumberofRows,1,-1 15760 DO j = Xmat % Rows(i+1)-1, Xmat % Rows(i),-1 15761 k = Xmat % Cols(j) 15762 IF ( ABS(Tvals(j))>AEPS ) & 15763 CALL List_AddToMatrixElement(Tmat % ListMatrix, i, k, TVals(j)) 15764 END DO 15765 END DO 15766 15767 15768 DO m=1,Xmat % NumberOfRows 15769 i = UseIPerm(m) 15770 DO j=Xmat % Rows(m), Xmat % Rows(m+1)-1 15771 k = Xmat % Cols(j) 15772 15773 ! The size of SlavePerm is often exceeded but I don't really undersrtand the operation... 15774 ! so this is just a dirty fix. 15775 IF( k > SIZE( SlavePerm ) ) CYCLE 15776 15777 l = SlavePerm(k) 15778 15779 IF(l>0 .AND. k/=i) THEN 15780 IF(ABS(Tvals(j))<AEPS) CYCLE 15781 scl = -TVals(j) / SlaveDiag(l) 15782 15783 CALL List_DeleteMatrixElement( Tmat % ListMatrix, m, k ) 15784 15785 DO q=Xmat % Rows(l+1)-1, Xmat % Rows(l),-1 15786 IF(ABS(Tvals(q))<AEPS) CYCLE 15787 ix = Xmat % Cols(q) 15788 IF ( ix/=k ) & 15789 CALL List_AddToMatrixElement( Tmat % ListMatrix, m, ix, scl * TVals(q) ) 15790 END DO 15791 END IF 15792 END DO 15793 END DO 15794 15795 CALL List_ToCRSMatrix(Tmat) 15796 Tvals => Tmat % Values 15797 IF(.NOT.ASSOCIATED(Xmat,RestMatrix)) CALL FreeMatrix(Xmat) 15798 END IF 15799 Xmat => TMat 15800 END DO 15801 15802 ! Eliminate Lagrange Coefficients: 15803 ! -------------------------------- 15804 15805 CALL Info(Caller,'Eliminating Largrange Coefficients',Level=15) 15806 15807 DO m=1,Tmat % NumberOfRows 15808 i = UseIPerm(m) 15809 IF( ABS( UseDiag(m) ) < TINY( 1.0_dp ) ) THEN 15810 PRINT *,'UseDiag too small:',m,ParEnv % MyPe,UseDiag(m) 15811 CYCLE 15812 END IF 15813 15814 DO j=TMat % Rows(m), TMat % Rows(m+1)-1 15815 k = TMat % Cols(j) 15816 IF(k<=n) THEN 15817 IF(UsePerm(k)/=0) CYCLE 15818 15819 IF ( EliminateDiscont ) THEN 15820 IF (EliminateFromMaster) THEN 15821 scl = -SlaveDiag(SlavePerm(k)) / UseDiag(m) 15822 ELSE 15823 scl = -MasterDiag(MasterPerm(k)) / UseDiag(m) 15824 END IF 15825 ELSE 15826 scl = -Tvals(j) / UseDiag(m) 15827 END IF 15828 ELSE 15829 k = UseIPerm(k-n) 15830 ! multiplied by 1/2 in GenerateConstraintMatrix() 15831 IF (EliminateDiscont) THEN 15832 scl = -2*DiagDiag(m) / UseDiag(m) 15833 ELSE 15834 scl = -2*Tvals(j) / UseDiag(m) 15835 END IF 15836 END IF 15837 15838 DO l=StiffMatrix % Rows(i+1)-1, StiffMatrix % Rows(i),-1 15839 CALL List_AddToMatrixElement( Lmat, k, & 15840 StiffMatrix % Cols(l), scl * StiffMatrix % Values(l) ) 15841 END DO 15842 CollectionVector(k) = CollectionVector(k) + scl * ForceVector(i) 15843 END DO 15844 END DO 15845 15846 IF ( .NOT.ASSOCIATED(Tmat, RestMatrix ) ) CALL FreeMatrix(Tmat) 15847 15848 ! Eliminate slave dofs, using the constraint equations: 15849 ! ----------------------------------------------------- 15850 IF ( EliminateSlave ) THEN 15851 CALL Info(Caller,'Eliminate slave dofs using constraint equations',Level=15) 15852 15853 IF(EliminateDiscont) THEN 15854 DO i=1,StiffMatrix % NumberOfRows 15855 IF ( UsePerm(i)/=0 ) CYCLE 15856 15857 DO m=StiffMatrix % Rows(i), StiffMatrix % Rows(i+1)-1 15858 j = SlavePerm(StiffMatrix % Cols(m)) 15859 IF ( j==0 ) CYCLE 15860 scl = -TotValues(m) / SlaveDiag(j) 15861 15862 ! Delete elimination entry: 15863 ! ------------------------- 15864 CALL List_DeleteMatrixElement(Lmat,i,StiffMatrix % Cols(m)) 15865 15866 k = UseIPerm(j) 15867 cTmp => Lmat(k) % Head 15868 DO WHILE(ASSOCIATED(cTmp)) 15869 l = cTmp % Index 15870 IF ( l /= SlaveIPerm(j) ) & 15871 CALL List_AddToMatrixElement( Lmat, i, l, scl*cTmp % Value ) 15872 cTmp => cTmp % Next 15873 END DO 15874 CollectionVector(i) = CollectionVector(i) + scl * CollectionVector(k) 15875 END DO 15876 END DO 15877 ELSE 15878 15879 CALL List_ToCRSMatrix(CollectionMatrix) 15880 Tmat => AllocateMatrix() 15881 Tmat % Format = MATRIX_LIST 15882 15883 DO i=1,StiffMatrix % NumberOfRows 15884 IF(UsePerm(i)/=0) CYCLE 15885 15886 DO m = CollectionMatrix % Rows(i), CollectionMatrix % Rows(i+1)-1 15887 j = SlavePerm(CollectionMatrix % Cols(m)) 15888 15889 IF(j==0) THEN 15890 CYCLE 15891 END IF 15892 IF( ABS( SlaveDiag(j) ) < TINY( 1.0_dp ) ) THEN 15893 PRINT *,'SlaveDiag too small:',j,ParEnv % MyPe,SlaveDiag(j) 15894 CYCLE 15895 END IF 15896 15897 scl = -CollectionMatrix % Values(m) / SlaveDiag(j) 15898 CollectionMatrix % Values(m) = 0._dp 15899 15900 ! ... and add replacement values: 15901 ! ------------------------------- 15902 k = UseIPerm(j) 15903 DO p=CollectionMatrix % Rows(k+1)-1, CollectionMatrix % Rows(k), -1 15904 l = CollectionMatrix % Cols(p) 15905 IF ( l /= SlaveIPerm(j) ) & 15906 CALL List_AddToMatrixElement( Tmat % listmatrix, i, l, scl*CollectionMatrix % Values(p) ) 15907 END DO 15908 CollectionVector(i) = CollectionVector(i) + scl * CollectionVector(k) 15909 END DO 15910 END DO 15911 15912 CALL List_ToListMatrix(CollectionMatrix) 15913 Lmat => CollectionMatrix % ListMatrix 15914 15915 CALL List_ToCRSMatrix(Tmat) 15916 DO i=TMat % NumberOfRows,1,-1 15917 DO j=TMat % Rows(i+1)-1,TMat % Rows(i),-1 15918 CALL List_AddToMatrixElement( Lmat, i, TMat % cols(j), TMat % Values(j) ) 15919 END DO 15920 END DO 15921 CALL FreeMatrix(Tmat) 15922 END IF 15923 END IF 15924 15925 ! Optimize bandwidth, if needed: 15926 ! ------------------------------ 15927 IF(EliminateFromMaster) THEN 15928 CALL Info(Caller,& 15929 'Optimizing bandwidth after elimination',Level=15) 15930 DO i=1,RestMatrix % NumberOfRows 15931 j = SlaveIPerm(i) 15932 k = MasterIPerm(i) 15933 15934 Ctmp => Lmat(j) % Head 15935 Lmat(j) % Head => Lmat(k) % Head 15936 Lmat(k) % Head => Ctmp 15937 15938 l = Lmat(j) % Degree 15939 Lmat(j) % Degree = Lmat(k) % Degree 15940 Lmat(k) % Degree = l 15941 15942 scl = CollectionVector(j) 15943 CollectionVector(j) = CollectionVector(k) 15944 CollectionVector(k) = scl 15945 END DO 15946 END IF 15947 15948 CALL Info(Caller,'Finished Adding ConstraintMatrix',Level=12) 15949 END IF 15950 15951 CALL Info(Caller,'Reverting CollectionMatrix back to CRS matrix',Level=10) 15952 IF(CollectionMatrix % FORMAT==MATRIX_LIST) & 15953 CALL List_toCRSMatrix(CollectionMatrix) 15954 15955 CALL Info( Caller, 'CollectionMatrix done', Level=5 ) 15956 15957!------------------------------------------------------------------------------ 15958! Assign values to CollectionVector 15959!------------------------------------------------------------------------------ 15960 15961 j = StiffMatrix % NumberOfRows 15962 CollectionSolution(1:j) = Solution(1:j) 15963 15964 i = StiffMatrix % NumberOfRows+1 15965 j = SIZE(CollectionSolution) 15966 CollectionSolution(i:j) = 0._dp 15967 IF(ExportMultiplier) CollectionSolution(i:j) = MultiplierValues(1:j-i+1) 15968 15969 CollectionMatrix % ExtraDOFs = CollectionMatrix % NumberOfRows - & 15970 StiffMatrix % NumberOfRows 15971 15972 CollectionMatrix % ParallelDOFs = 0 15973 IF(ASSOCIATED(AddMatrix)) & 15974 CollectionMatrix % ParallelDOFs = MAX(AddMatrix % NumberOfRows - & 15975 StiffMatrix % NumberOfRows,0) 15976 15977 CALL Info( Caller, 'CollectionVector done', Level=5 ) 15978 15979!------------------------------------------------------------------------------ 15980! Solve the Collection-system 15981!------------------------------------------------------------------------------ 15982 15983! Collectionmatrix % Complex = StiffMatrix % Complex 15984 15985 ! We may want to skip the constraints for norm if we use certain other options 15986 SkipConstraints = ListGetLogical( Solver % values, & 15987 'Nonlinear System Convergence Without Constraints',Found ) 15988 IF(.NOT. Found ) THEN 15989 SkipConstraints = ListGetLogical( Solver % values, 'Linear System Residual Mode',Found ) 15990 IF( SkipConstraints ) THEN 15991 CALL Info(Caller,'Linear system residual mode must skip constraints',Level=8) 15992 ELSE 15993 SkipConstraints = ListGetLogical( Solver % values, 'NonLinear System Consistent Norm',Found ) 15994 IF( SkipConstraints ) THEN 15995 CALL Info(Caller,'Nonlinear system consistent norm must skip constraints',Level=8) 15996 END IF 15997 END IF 15998 str = ListGetString( Solver % values, 'NonLinear System Convergence Measure',Found ) 15999 IF( str == 'solution' ) THEN 16000 SkipConstraints = .TRUE. 16001 CALL Info(Caller,& 16002 'Nonlinear system convergence measure == "solution" must skip constraints',Level=8) 16003 END IF 16004 IF( SkipConstraints ) THEN 16005 CALL Info(Caller,'Enforcing convergence without constraints to True',Level=8) 16006 CALL ListAddLogical( Solver % Values, & 16007 'Nonlinear System Convergence Without Constraints',.TRUE.) 16008 END IF 16009 END IF 16010 16011 !------------------------------------------------------------------------------ 16012 ! Look at the nonlinear system previous values again, not taking the constrained 16013 ! system into account... 16014 !------------------------------------------------------------------------------ 16015 Found = ASSOCIATED(Solver % Variable % NonlinValues) 16016 IF( Found .AND. .NOT. SkipConstraints ) THEN 16017 k = CollectionMatrix % NumberOfRows 16018 IF ( SIZE(Solver % Variable % NonlinValues) /= k) THEN 16019 DEALLOCATE(Solver % Variable % NonlinValues) 16020 ALLOCATE(Solver % Variable % NonlinValues(k)) 16021 END IF 16022 Solver % Variable % NonlinValues(1:k) = CollectionSolution(1:k) 16023 END IF 16024 16025 CollectionMatrix % Comm = StiffMatrix % Comm 16026 16027 CALL Info(Caller,'Now going for the coupled linear system',Level=10) 16028 16029 CALL SolveLinearSystem( CollectionMatrix, CollectionVector, & 16030 CollectionSolution, Norm, DOFs, Solver, StiffMatrix ) 16031 16032 16033 !------------------------------------------------------------------------------- 16034 ! For restricted systems study the norm without some block components. 16035 ! For example, excluding gauge constraints may give valuable information 16036 ! of the real accuracy of the unconstrained system. Currently just for info. 16037 !------------------------------------------------------------------------------- 16038 IF( ListGetLogical( Solver % Values,'Restricted System Norm',Found ) ) THEN 16039 ALLOCATE( TrueDof( CollectionMatrix % NumberOfRows ) ) 16040 TrueDof = .TRUE. 16041 16042 Norm = LinearSystemMaskedResidualNorm( CollectionMatrix, CollectionVector, & 16043 CollectionSolution, TrueDof, TrueDof ) 16044 16045 WRITE( Message,'(A,ES13.6)') 'Residual norm of the original system:',Norm 16046 CALL Info(Caller,Message, Level = 5 ) 16047 16048 IF( ListGetLogical( Solver % Values,'Restricted System Norm Skip Nodes',Found ) ) THEN 16049 i = 1 16050 j = MAXVAL( Solver % Variable % Perm(1:Solver % Mesh % NumberOfNodes) ) 16051 CALL Info(Caller,'Skipping nodal dof range: '& 16052 //TRIM(I2S(i))//'-'//TRIM(I2S(j)),Level=8) 16053 TrueDof(i:j) = .FALSE. 16054 END IF 16055 16056 IF( ListGetLogical( Solver % Values,'Restricted System Norm Skip Constraints',Found ) ) THEN 16057 i = StiffMatrix % NumberOfRows + 1 16058 j = CollectionMatrix % NumberOfRows 16059 CALL Info(Caller,'Skipping constraints dof range: '& 16060 //TRIM(I2S(i))//'-'//TRIM(I2S(j)),Level=8) 16061 TrueDof(i:j) = .FALSE. 16062 END IF 16063 16064 Norm = LinearSystemMaskedResidualNorm( CollectionMatrix, CollectionVector, & 16065 CollectionSolution, TrueDof, TrueDof ) 16066 16067 WRITE( Message,'(A,ES13.6)') 'Residual norm of the masked system:',Norm 16068 CALL Info(Caller,Message, Level = 5 ) 16069 16070 DEALLOCATE( TrueDof ) 16071 END IF 16072 16073 16074 16075!------------------------------------------------------------------------------ 16076! Separate the solution from CollectionSolution 16077!------------------------------------------------------------------------------ 16078 CALL Info(Caller,'Picking solution from collection solution',Level=10) 16079 16080 Solution = 0.0_dp 16081 i = 1 16082 j = StiffMatrix % NumberOfRows 16083 Solution(i:j) = CollectionSolution(i:j) 16084 16085 IF ( ExportMultiplier ) THEN 16086 i = StiffMatrix % NumberOfRows 16087 j=0 16088 IF(ASSOCIATED(RestMatrix)) j = RestMatrix % NumberOfRows 16089 IF(ASSOCIATED(AddMatrix)) & 16090 j=j+MAX(0,AddMatrix % NumberOfRows - StiffMatrix % NumberOFRows) 16091 16092 MultiplierValues = 0.0_dp 16093 IF(ASSOCIATED(RestMatrix).AND.EliminateConstraints) THEN 16094 ! Compute eliminated l-coefficient values: 16095 ! --------------------------------------- 16096 DO i=1,RestMatrix % NumberOfRows 16097 scl = 1._dp / UseDiag(i) 16098 m = UseIPerm(i) 16099 MultiplierValues(i) = scl * ForceVector(m) 16100 DO j=StiffMatrix % Rows(m), StiffMatrix % Rows(m+1)-1 16101 MultiplierValues(i) = MultiplierValues(i) - & 16102 scl * StiffMatrix % Values(j) * Solution(StiffMatrix % Cols(j)) 16103 END DO 16104 END DO 16105 ELSE 16106 MultiplierValues(1:j) = CollectionSolution(i+1:i+j) 16107 END IF 16108 16109 IF(EliminateConstraints.AND.EliminateDiscont) THEN 16110 IF (EliminateFromMaster) THEN 16111 CALL totv(StiffMatrix,MultiplierValues,MasterIPerm) 16112 ELSE 16113 CALL totv(StiffMatrix,MultiplierValues,SlaveIPerm) 16114 END IF 16115 END IF 16116 END IF 16117 16118!------------------------------------------------------------------------------ 16119 16120 StiffMatrix % CollectionMatrix => CollectionMatrix 16121 DEALLOCATE(CollectionSolution) 16122 CollectionMatrix % ConstraintMatrix => NULL() 16123 16124 CALL Info( Caller, 'All done', Level=10 ) 16125 16126CONTAINS 16127 16128 SUBROUTINE totv( A, totvalues, perm ) 16129 type(matrix_t), pointer :: A 16130 real(kind=dp) :: totvalues(:) 16131 integer, allocatable :: perm(:) 16132 16133 real(kind=dp), ALLOCATABLE :: x(:),r(:) 16134 INTEGER :: i,j,ng 16135 16136 ng = A % NumberOfRows 16137! ng = ParallelReduction(1._dp*MAXVAL(A % ParallelInfo % GLobalDOfs)) 16138 ALLOCATE(x(ng),r(ng)) 16139 16140 x = 0._dp 16141 IF(ALLOCATED(perm)) THEN 16142 DO i=1,SIZE(perm) 16143 j = Perm(i) 16144 !j = a % parallelinfo % globaldofs(j) 16145 x(j) = totvalues(i) 16146 END DO 16147 END IF 16148 16149 CALL ParallelSumVector(A, x) 16150! CALL MPI_ALLREDUCE( x,r, ng, MPI_DOUBLE_PRECISION, MPI_SUM, ELMER_COMM_WORLD, i ); x=r 16151 16152 IF(ALLOCATED(perm)) THEN 16153 DO i=1,SIZE(perm) 16154 j = Perm(i) 16155 !j = A % parallelinfo % globaldofs(j) 16156 totvalues(i) = x(j) 16157 END DO 16158 END IF 16159 END SUBROUTINE Totv 16160 16161 16162 SUBROUTINE Tota( A, TotValues, cperm ) 16163 type(matrix_t), pointer :: A 16164 integer, allocatable :: cperm(:) 16165 real(kind=dp), ALLOCATABLE :: totvalues(:) 16166 16167 INTEGER, POINTER :: Diag(:), Rows(:), Cols(:) 16168 LOGICAL :: found 16169 INTEGER :: status(MPI_STATUS_SIZE) 16170 REAL(KIND=dp), ALLOCATABLE, TARGET :: rval(:) 16171 INTEGER, ALLOCATABLE :: cnt(:), rrow(:),rcol(:), perm(:) 16172 INTEGER :: i,j,k,l,m,ii,jj,proc,rcnt,nn, dof, dofs, Active, n, nm,ierr 16173 16174 TYPE Buf_t 16175 REAL(KIND=dp), ALLOCATABLE :: gval(:) 16176 INTEGER, ALLOCATABLE :: grow(:),gcol(:) 16177 END TYPE Buf_t 16178 TYPE(Buf_t), POINTER :: buf(:) 16179 16180 Diag => A % Diag 16181 Rows => A % Rows 16182 Cols => A % Cols 16183 16184 n = A % NumberOfRows 16185 16186 ALLOCATE(TotValues(SIZE(A % Values))); TotValues=A % Values 16187 16188 IF (ParEnv % PEs>1 ) THEN 16189 ALLOCATE(cnt(0:ParEnv % PEs-1)) 16190 cnt = 0 16191 DO i=1,n 16192 DO j=Rows(i),Rows(i+1)-1 16193! IF(Cols(j)<=nm .OR. Cols(j)>nm+n) CYCLE 16194 iF ( ALLOCATED(CPerm)) THEN 16195 IF(cperm(Cols(j))==0) CYCLE 16196 END IF 16197 IF(TotValues(j)==0) CYCLE 16198 16199 IF ( A % ParallelInfo % Interface(Cols(j)) ) THEN 16200 DO k=1,SIZE(A % ParallelInfo % NeighbourList(Cols(j)) % Neighbours) 16201 m = A % ParallelInfo % NeighbourList(Cols(j)) % Neighbours(k) 16202 IF ( m==ParEnv % myPE ) CYCLE 16203 cnt(m) = cnt(m)+1 16204 END DO 16205 END IF 16206 END DO 16207 END DO 16208 16209 ALLOCATE( buf(0:ParEnv % PEs-1) ) 16210 DO i=0,ParEnv % PEs-1 16211 IF ( cnt(i) > 0 ) & 16212 ALLOCATE( Buf(i) % gval(cnt(i)), Buf(i) % grow(cnt(i)), Buf(i) % gcol(cnt(i)) ) 16213 END DO 16214 16215 cnt = 0 16216 DO i=1,n 16217 DO j=Rows(i),Rows(i+1)-1 16218! IF(Cols(j)<=nm .OR. Cols(j)>nm+n) CYCLE 16219 iF ( ALLOCATED(CPerm)) THEN 16220 IF(cperm(Cols(j))==0) CYCLE 16221 END IF 16222 IF(TotValues(j)==0) CYCLE 16223 16224 IF ( A % ParallelInfo % Interface(Cols(j)) ) THEN 16225 DO k=1,SIZE(A % ParallelInfo % NeighbourList(Cols(j)) % Neighbours) 16226 m = A % ParallelInfo % NeighbourList(Cols(j)) % Neighbours(k) 16227 IF ( m==ParEnv % myPE ) CYCLE 16228 cnt(m) = cnt(m)+1 16229 Buf(m) % gcol(cnt(m)) = A % ParallelInfo % GlobalDOFs(Cols(j)) 16230 Buf(m) % gval(cnt(m)) = TotValues(j) 16231 Buf(m) % grow(cnt(m)) = A % ParallelInfo % GlobalDOFs(i) 16232 END DO 16233 END IF 16234 END DO 16235 END DO 16236 16237 DO i=0,ParEnv % PEs-1 16238 IF ( ParEnv % IsNeighbour(i+1) ) THEN 16239 CALL MPI_BSEND( cnt(i), 1, MPI_INTEGER, i, 7001, ELMER_COMM_WORLD, status, ierr ) 16240 IF ( cnt(i)>0 ) THEN 16241 CALL MPI_BSEND( Buf(i) % grow, cnt(i), MPI_INTEGER, & 16242 i, 7002, ELMER_COMM_WORLD, status, ierr ) 16243 16244 CALL MPI_BSEND( Buf(i) % gcol, cnt(i), MPI_INTEGER, & 16245 i, 7003, ELMER_COMM_WORLD, status, ierr ) 16246 16247 CALL MPI_BSEND( Buf(i) % gval, cnt(i), MPI_DOUBLE_PRECISION, & 16248 i, 7004, ELMER_COMM_WORLD, status, ierr ) 16249 END IF 16250 END IF 16251 END DO 16252 16253 DO i=0,ParEnv % PEs-1 16254 IF ( cnt(i)>0 ) & 16255 DEALLOCATE( Buf(i) % gval, Buf(i) % grow, Buf(i) % gcol ) 16256 END DO 16257 DEALLOCATE( cnt,Buf ) 16258 16259 DO i=1,ParEnv % NumOfNeighbours 16260 CALL MPI_RECV( rcnt, 1, MPI_INTEGER, & 16261 MPI_ANY_SOURCE, 7001, ELMER_COMM_WORLD, status, ierr ) 16262 16263 IF ( rcnt>0 ) THEN 16264 IF(.NOT.ALLOCATED(rrow)) THEN 16265 ALLOCATE( rrow(rcnt), rcol(rcnt), rval(rcnt) ) 16266 ELSE IF(SIZE(rrow)<rcnt) THEN 16267 DEALLOCATE(rrow,rcol,rval) 16268 ALLOCATE( rrow(rcnt), rcol(rcnt), rval(rcnt) ) 16269 ENDIF 16270 16271 proc = status(MPI_SOURCE) 16272 CALL MPI_RECV( rrow, rcnt, MPI_INTEGER, & 16273 proc, 7002, ELMER_COMM_WORLD, status, ierr ) 16274 16275 CALL MPI_RECV( rcol, rcnt, MPI_INTEGER, & 16276 proc, 7003, ELMER_COMM_WORLD, status, ierr ) 16277 16278 CALL MPI_RECV( rval, rcnt, MPI_DOUBLE_PRECISION, & 16279 proc, 7004, ELMER_COMM_WORLD, status, ierr ) 16280 16281 DO j=1,rcnt 16282 l = SearchNode(A % ParallelInfo,rcol(j),Order=A % ParallelInfo % Gorder ) 16283 IF ( l>0 ) THEN 16284 k = SearchNode(A % ParallelInfo,rrow(j),Order=A % ParallelInfo % Gorder ) 16285 IF ( k>0 ) THEN 16286 IF ( l>=k ) THEN 16287 DO m=Diag(k),Rows(k+1)-1 16288 IF ( Cols(m) == l ) THEN 16289 TotValues(m) = TotValues(m) + rval(j) 16290 EXIT 16291 ELSE IF( Cols(m)>l) THEN 16292 EXIT 16293 END IF 16294 END DO 16295 ELSE 16296 DO m=Rows(k),Diag(k)-1 16297 IF ( Cols(m)==l ) THEN 16298 TotValues(m) = TotValues(m) + rval(j) 16299 EXIT 16300 ELSE IF( Cols(m)>l) THEN 16301 EXIT 16302 END IF 16303 END DO 16304 END IF 16305 END IF 16306 END IF 16307 END DO 16308 END IF 16309 END DO 16310 END IF 16311 END SUBROUTINE tota 16312 16313!------------------------------------------------------------------------------ 16314 END SUBROUTINE SolveWithLinearRestriction 16315!------------------------------------------------------------------------------ 16316 16317 16318!------------------------------------------------------------------------------ 16319!> Given the operation point and an additional r.h.s. source vector find the 16320!> amplitude for the latter one such that the control problem is resolved. 16321!> We can request a field value at given point, for example. This tries to 16322!> mimic some ideas of the "Smart Heater Control" of "HeatSolver" available 16323!> long ago. This would hopefully be applicable to wider set of modules. 16324!------------------------------------------------------------------------------ 16325 SUBROUTINE ControlLinearSystem(Solver,PreSolve) 16326 TYPE(Solver_t), POINTER :: Solver 16327 LOGICAL :: PreSolve 16328 16329 TYPE(ValueList_t), POINTER :: Params 16330 TYPE(Matrix_t), POINTER :: A 16331 TYPE(Variable_t), POINTER :: Var 16332 TYPE(Mesh_t), POINTER :: Mesh 16333 REAL(KIND=dp), POINTER :: x0(:),b(:),BulkRhsSave(:),dr(:),r0(:),dy(:),y0(:) 16334 REAL(KIND=dp), ALLOCATABLE, TARGET :: dx(:),f(:) 16335 INTEGER, POINTER :: Perm(:) 16336 INTEGER :: dofs, i, j, nsize, ControlNode, dof0 16337 REAL(KIND=dp) :: Nrm, c, dc, val, cand 16338 LOGICAL :: GotF, Found, UseLoads 16339 CHARACTER(LEN=MAX_NAME_LEN) :: SourceName 16340 CHARACTER(*), PARAMETER :: Caller = 'ControlLinearSystem' 16341 16342 SAVE f 16343 16344 IF( ParEnv % PEs > 1 ) THEN 16345 CALL Fatal(Caller,'Controlling of source terms implemented only in serial!') 16346 END IF 16347 16348 16349 Params => Solver % Values 16350 Mesh => Solver % Mesh 16351 A => Solver % Matrix 16352 Var => Solver % Variable 16353 b => A % RHS 16354 x0 => Var % Values 16355 dofs = Var % Dofs 16356 Perm => Var % Perm 16357 nsize = SIZE(x0) 16358 16359 ! Default name for controlled source term 16360 SourceName = TRIM(Var % Name)//' Control' 16361 16362 IF( PreSolve ) THEN 16363 ! We need to add the control source here in order to be able to use 16364 ! standard means for convergence monitoring. 16365 CALL Info(Caller,'Computing source term for control',Level=7) 16366 ALLOCATE(f(nsize)) 16367 f = 0.0_dp 16368 CALL SetNodalSources( CurrentModel,Mesh,SourceName, & 16369 dofs, Perm, GotF, f ) 16370 16371 ! The additional source needs to be nullified for Dirichlet conditions 16372 IF( ALLOCATED( A % ConstrainedDOF ) ) THEN 16373 WHERE( A % ConstrainedDOF ) f = 0.0_dp 16374 END IF 16375 16376 ! This is inhereted from previous control iterations. 16377 c = ListGetCReal( Params,'Control Amplitude',Found ) 16378 16379! DO i=1,dofs 16380! PRINT *,'ranges b:',i,MINVAL(b(i::dofs)),MAXVAL(b(i::dofs)),SUM(b(i::dofs)) 16381! PRINT *,'ranges f:',i,MINVAL(f(i::dofs)),MAXVAL(f(i::dofs)),SUM(f(i::dofs)) 16382! END DO 16383 16384 IF( Found ) THEN 16385 b(1:nsize) = b(1:nsize) + c * f(1:nsize) 16386 END IF 16387 ELSE 16388 CALL Info(Caller,'Applying control to tune source term amplitude',Level=7) 16389 CALL ListPushNameSpace('control:') 16390 CALL ListAddLogical( Params,'control: Skip Compute Nonlinear Change',.TRUE.) 16391 CALL ListAddLogical( Params,'control: Skip Advance Nonlinear iter',.TRUE.) 16392 16393 ALLOCATE(dx(nsize)) 16394 dx = 0.0_dp 16395 CALL SolveSystem(A,ParMatrix,f,dx,Nrm,dofs,Solver) 16396 CALL ListPopNamespace() 16397 16398 16399 UseLoads = ListGetLogical( Params,'Control Use Loads', Found ) 16400 IF( UseLoads ) THEN 16401 ALLOCATE(r0(nsize),dr(nsize)) 16402 CALL CalculateLoads( Solver, A, x0, dofs, .TRUE., NodalValues = r0 ) 16403 BulkRhsSave => A % BulkRhs 16404 A % BulkRhs => f 16405 CALL CalculateLoads( Solver, A, dx, dofs, .TRUE., NodalValues = dr ) 16406 A % BulkRhs => BulkRhsSave 16407 y0 => r0 16408 dy => dr 16409 ELSE 16410 y0 => x0 16411 dy => dx 16412 END IF 16413 16414 val = ListGetCReal( Params,'Control Target Value',UnfoundFatal=.TRUE.) 16415 c = ListGetCReal( Params,'Control Amplitude',Found ) 16416 16417 dof0 = 1 16418 IF( dofs > 1) THEN 16419 dof0 = ListGetInteger( Params,'Control Target Component',UnfoundFatal=.TRUE.) 16420 END IF 16421 16422 ControlNode = ListGetInteger( Params,'Control Node Index',Found ) 16423 16424 IF(.NOT. Found ) THEN 16425 BLOCK 16426 REAL(KIND=dp) :: Coord(3),Coord0(3),mindist,dist 16427 REAL(KIND=dp), POINTER :: RealWork(:,:) 16428 16429 RealWork => ListGetConstRealArray( Params,'Control Node Coordinates',Found ) 16430 IF( Found ) THEN 16431 CALL Info(Caller,'Locating control node coordinates',Level=15) 16432 Coord0(1:3) = RealWork(1:3,1) 16433 16434 mindist = HUGE( mindist ) 16435 DO i=1,Mesh % NumberOfNodes 16436 IF( Perm(i) == 0 ) CYCLE 16437 Coord(1) = Mesh % Nodes % x(i) 16438 Coord(2) = Mesh % Nodes % y(i) 16439 Coord(3) = Mesh % Nodes % z(i) 16440 16441 dist = SUM((Coord0-Coord)**2) 16442 IF( dist < mindist ) THEN 16443 mindist = dist 16444 ControlNode = i 16445 END IF 16446 END DO 16447 CALL Info(Caller,'Control Node located to index: '//TRIM(I2S(ControlNode)),Level=6) 16448 CALL ListAddInteger( Params,'Control Node Index',ControlNode ) 16449 END IF 16450 END BLOCK 16451 END IF 16452 16453 ! We use either solution or reaction force for (y0,dy) so that we can 16454 ! generalize the control procedures for both. 16455 IF( ControlNode > 0 ) THEN 16456 IF( ControlNode > nsize ) CALL Fatal(Caller,& 16457 'Invalid "Control Node Index": '//TRIM(I2S(ControlNode))) 16458 i = Perm(ControlNode) 16459 j = dofs*(i-1)+dof0 16460 dc = (val-y0(j))/dy(j) 16461 WRITE(Message,'(A,ES15.6)') 'Scaling control update for control node:',dc 16462 ELSE 16463 dc = HUGE(dc) 16464 DO i=1,nsize 16465 j = dofs*(i-1)+dof0 16466 IF(ABS(dy(j)) < TINY(dy(j))) CYCLE 16467 cand = (val-y0(j))/dy(j) 16468 IF( ABS(cand) < ABS(dc) ) dc = cand 16469 END DO 16470 WRITE(Message,'(A,ES15.6)') 'Scaling control update for extrumum value:',dc 16471 END IF 16472 CALL Info(Caller,Message,Level=6) 16473 16474 c = c + dc 16475 CALL ListAddConstReal( Params,'Control Amplitude', c ) 16476 16477 ! Apply control, this always to the solution - not to load 16478 x0(1:nsize) = x0(1:nsize) + dc * dx(1:nsize) 16479 16480 WRITE(Message,'(A,ES15.6)') 'Scaling control applied:',c 16481 CALL Info(Caller,Message,Level=5) 16482 16483 DEALLOCATE(f,dx) 16484 IF(UseLoads) DEALLOCATE(dr,r0) 16485 END IF 16486 16487 END SUBROUTINE ControlLinearSystem 16488 16489 16490!------------------------------------------------------------------------------ 16491 SUBROUTINE SaveLinearSystem( Solver, Ain ) 16492!------------------------------------------------------------------------------ 16493 TYPE( Solver_t ) :: Solver 16494 TYPE(Matrix_t), POINTER, OPTIONAL :: Ain 16495!------------------------------------------------------------------------------ 16496 TYPE(Matrix_t), POINTER :: A 16497 TYPE(ValueList_t), POINTER :: Params 16498 CHARACTER(LEN=MAX_NAME_LEN) :: dumpfile, dumpprefix 16499 INTEGER, POINTER :: Perm(:) 16500 REAL(KIND=dp), POINTER :: Sol(:) 16501 INTEGER :: i 16502 LOGICAL :: SaveMass, SaveDamp, SavePerm, SaveSol, Found , Parallel, CNumbering 16503 CHARACTER(*), PARAMETER :: Caller = 'SaveLinearSystem' 16504!------------------------------------------------------------------------------ 16505 16506 CALL Info(Caller,'Saving linear system',Level=6) 16507 16508 Parallel = ParEnv % PEs > 1 16509 16510 Params => Solver % Values 16511 IF(.NOT. ASSOCIATED( Params ) ) THEN 16512 CALL Fatal(Caller,'Parameter list not associated!') 16513 END IF 16514 16515 CNumbering = ListGetLogical(Params, 'Linear System Save Continuous Numbering',Found) 16516 16517 IF( PRESENT(Ain)) THEN 16518 A => Ain 16519 ELSE 16520 A => Solver % Matrix 16521 END IF 16522 16523 IF(.NOT. ASSOCIATED( A ) ) THEN 16524 CALL Fatal(Caller,'Matrix not assciated!') 16525 END IF 16526 16527 SaveMass = ListGetLogical( Params,'Linear System Save Mass',Found) 16528 16529 SaveDamp = ListGetLogical( Params,'Linear System Save Damp',Found) 16530 16531 dumpprefix = ListGetString( Params, 'Linear System Save Prefix', Found) 16532 IF(.NOT. Found ) dumpprefix = 'linsys' 16533 16534 dumpfile = TRIM(dumpprefix)//'_a.dat' 16535 IF(Parallel) dumpfile = TRIM(dumpfile)//'.'//TRIM(I2S(ParEnv % myPE)) 16536 CALL Info(Caller,'Saving matrix to: '//TRIM(dumpfile),Level=5) 16537 OPEN(1,FILE=dumpfile, STATUS='Unknown') 16538 CALL PrintMatrix(A,Parallel,Cnumbering,SaveMass=SaveMass,SaveDamp=SaveDamp) 16539 CLOSE(1) 16540 16541 dumpfile = TRIM(dumpprefix)//'_b.dat' 16542 IF(Parallel) dumpfile = TRIM(dumpfile)//'.'//TRIM(I2S(ParEnv % myPE)) 16543 CALL Info(Caller,'Saving matrix rhs to: '//TRIM(dumpfile),Level=5) 16544 OPEN(1,FILE=dumpfile, STATUS='Unknown') 16545 CALL PrintRHS(A, Parallel, CNumbering) 16546 CLOSE(1) 16547 16548 SavePerm = ListGetLogical( Params,'Linear System Save Perm',Found) 16549 IF( SavePerm ) THEN 16550 Perm => Solver % Variable % Perm 16551 IF( .NOT. ASSOCIATED( Perm ) ) THEN 16552 CALL Warn(Caller,'Permuation not associated!') 16553 SavePerm = .FALSE. 16554 ELSE 16555 dumpfile = TRIM(dumpprefix)//'_perm.dat' 16556 IF(Parallel) dumpfile = TRIM(dumpfile)//'.'//TRIM(I2S(ParEnv % myPE)) 16557 CALL Info(Caller,'Saving permutation to: '//TRIM(dumpfile),Level=5) 16558 OPEN(1,FILE=dumpfile, STATUS='Unknown') 16559 DO i=1,SIZE(Perm) 16560 WRITE(1,'(I0,A,I0)') i,' ',Perm(i) 16561 END DO 16562 CLOSE( 1 ) 16563 END IF 16564 END IF 16565 16566 16567 SaveSol = ListGetLogical( Params,'Linear System Save Solution',Found) 16568 IF( SaveSol ) THEN 16569 Sol => Solver % Variable % Values 16570 IF( .NOT. ASSOCIATED( Sol ) ) THEN 16571 CALL Warn(Caller,'Solution not associated!') 16572 SaveSol = .FALSE. 16573 ELSE 16574 dumpfile = TRIM(dumpprefix)//'_sol.dat' 16575 IF(Parallel) dumpfile = TRIM(dumpfile)//'.'//TRIM(I2S(ParEnv % myPE)) 16576 CALL Info(Caller,'Saving solution to: '//TRIM(dumpfile),Level=5) 16577 OPEN(1,FILE=dumpfile, STATUS='Unknown') 16578 DO i=1,SIZE(Sol) 16579 WRITE(1,'(I0,ES15.6)') i,Sol(i) 16580 END DO 16581 CLOSE( 1 ) 16582 END IF 16583 END IF 16584 16585 16586 dumpfile = TRIM(dumpprefix)//'_sizes.dat' 16587 IF(Parallel) dumpfile = TRIM(dumpfile)//'.'//TRIM(I2S(ParEnv % myPE)) 16588 CALL Info(Caller,'Saving matrix sizes to: '//TRIM(dumpfile),Level=5) 16589 OPEN(1,FILE=dumpfile, STATUS='Unknown') 16590 WRITE(1,*) A % NumberOfRows 16591 WRITE(1,*) SIZE(A % Values) 16592 IF( SavePerm ) WRITE(1,*) SIZE( Perm ) 16593 CLOSE(1) 16594 16595 IF(Parallel) THEN 16596 dumpfile = TRIM(dumpprefix)//'_sizes.dat' 16597 CALL Info(Caller,'Saving matrix sizes to: '//TRIM(dumpfile),Level=6) 16598 OPEN(1,FILE=dumpfile, STATUS='Unknown') 16599 WRITE(1,*) NINT(ParallelReduction(1._dP*A % ParMatrix % & 16600 SplittedMatrix % InsideMatrix % NumberOfRows)) 16601 WRITE(1,*) NINT(ParallelReduction(1._dp*SIZE(A % Values))) 16602 IF( SavePerm ) WRITE(1,*) NINT(ParallelReduction(1._dp*SIZE( Perm ))) 16603 CLOSE(1) 16604 END IF 16605 16606 IF( ListGetLogical( Params,'Linear System Save and Stop',Found ) ) THEN 16607 CALL Info(Caller,'Just saved matrix and stopped!',Level=4) 16608 STOP EXIT_OK 16609 END IF 16610!------------------------------------------------------------------------------ 16611 END SUBROUTINE SaveLinearSystem 16612!------------------------------------------------------------------------------ 16613 16614!------------------------------------------------------------------------------ 16615!> Assemble Laplace matrix related to a solver and permutation vector. 16616!------------------------------------------------------------------------------ 16617 SUBROUTINE LaplaceMatrixAssembly( Solver, Perm, A ) 16618 16619 TYPE(Solver_t) :: Solver 16620 INTEGER, POINTER :: Perm(:) 16621 TYPE(Matrix_t), POINTER :: A 16622 TYPE(Mesh_t), POINTER :: Mesh 16623 !------------------------------------------------------------------------------ 16624 16625 INTEGER, POINTER :: BoundaryPerm(:), Indexes(:) 16626 INTEGER :: i,j,k,n,t,istat,BoundaryNodes 16627 TYPE(Element_t), POINTER :: Element 16628 TYPE(GaussIntegrationPoints_t) :: IP 16629 CHARACTER(LEN=MAX_NAME_LEN) :: BoundaryName 16630 TYPE(Nodes_t) :: Nodes 16631 REAL(KIND=dp), ALLOCATABLE :: STIFF(:,:), FORCE(:) 16632 REAL(KIND=dp), POINTER :: Basis(:), dBasisdx(:,:) 16633 REAL(KIND=dp) :: detJ, val 16634 LOGICAL :: Stat 16635 16636 16637 Mesh => Solver % Mesh 16638 16639 N = Mesh % MaxElementNodes 16640 ALLOCATE( Basis(n), dBasisdx(n, 3), FORCE(N), STIFF(N,N), & 16641 Nodes % x(n), Nodes % y(n), Nodes % z(n), & 16642 STAT=istat) 16643 16644 IF(.FALSE.) THEN 16645 N = Mesh % NumberOfNodes 16646 ALLOCATE( BoundaryPerm(n) ) 16647 BoundaryPerm = 0 16648 BoundaryNodes = 0 16649 BoundaryName = 'Laplace Boundary' 16650 CALL MakePermUsingMask( CurrentModel,Solver,Mesh,BoundaryName, & 16651 .FALSE., BoundaryPerm, BoundaryNodes ) 16652 END IF 16653 16654 16655 DO t=1,Mesh % NumberOfBulkElements 16656 Element => Mesh % Elements(t) 16657 n = Element % TYPE % NumberOfNodes 16658 Indexes => Element % NodeIndexes 16659 IF( ANY( Perm(Indexes) == 0 ) ) CYCLE 16660 16661 Nodes % x(1:n) = Mesh % Nodes % x(Indexes) 16662 Nodes % y(1:n) = Mesh % Nodes % y(Indexes) 16663 Nodes % z(1:n) = Mesh % Nodes % z(Indexes) 16664 16665 STIFF = 0.0d0 16666 FORCE = 0.0d0 16667 16668 ! Numerical integration: 16669 !---------------------- 16670 IP = GaussPoints( Element ) 16671 DO k=1,IP % n 16672 ! Basis function values & derivatives at the integration point: 16673 !-------------------------------------------------------------- 16674 stat = ElementInfo( Element, Nodes, IP % U(k), IP % V(k), & 16675 IP % W(k), detJ, Basis, dBasisdx ) 16676 16677 ! Finally, the elemental matrix & vector: 16678 !---------------------------------------- 16679 DO i=1,n 16680 val = IP % s(k) * DetJ 16681 16682 ! This condition removes the natural boundary condition that would 16683 ! try to fix the normal gradient of the field to zero. 16684 !-------------------------------------------------------------------- 16685 IF(.FALSE.) THEN 16686 IF( BoundaryPerm( Indexes(i) ) > 0 ) CYCLE 16687 END IF 16688 16689 DO j=1,n 16690 STIFF(i,j) = STIFF(i,j) + val * & 16691 SUM( dBasisdx(i,:) * dBasisdx(j,:) ) 16692 END DO 16693 END DO 16694 END DO 16695 16696 CALL UpdateGlobalEquations( A,STIFF,A % rhs,FORCE,n,1,Perm(Indexes(1:n)) ) 16697 END DO 16698 16699 DEALLOCATE( Basis, dBasisdx, FORCE, STIFF, & 16700 Nodes % x, Nodes % y, Nodes % z) 16701 16702 END SUBROUTINE LaplaceMatrixAssembly 16703 16704 16705!------------------------------------------------------------------------------ 16706!> Assemble mass matrix related to a solver and permutation vector. 16707!------------------------------------------------------------------------------ 16708 SUBROUTINE MassMatrixAssembly( Solver, Perm, A ) 16709 16710 TYPE(Solver_t) :: Solver 16711 INTEGER, POINTER :: Perm(:) 16712 TYPE(Matrix_t), POINTER :: A 16713 TYPE(Mesh_t), POINTER :: Mesh 16714 !------------------------------------------------------------------------------ 16715 16716 INTEGER, POINTER :: Indexes(:) 16717 INTEGER :: i,j,k,n,t,istat 16718 TYPE(Element_t), POINTER :: Element 16719 TYPE(GaussIntegrationPoints_t) :: IP 16720 TYPE(Nodes_t) :: Nodes 16721 REAL(KIND=dp), ALLOCATABLE :: STIFF(:,:), FORCE(:) 16722 REAL(KIND=dp), POINTER :: Basis(:),rhs(:) 16723 REAL(KIND=dp) :: detJ, val 16724 LOGICAL :: Stat 16725 16726 16727 Mesh => Solver % Mesh 16728 16729 N = Mesh % MaxElementNodes 16730 ALLOCATE( Basis(n), FORCE(N), STIFF(N,N), & 16731 Nodes % x(n), Nodes % y(n), Nodes % z(n), & 16732 STAT=istat) 16733 16734 ALLOCATE( rhs(A % NumberOfRows) ) 16735 rhs = 0.0_dp 16736 16737 DO t=1,Mesh % NumberOfBulkElements 16738 Element => Mesh % Elements(t) 16739 n = Element % TYPE % NumberOfNodes 16740 Indexes => Element % NodeIndexes 16741 IF( ANY( Perm(Indexes) == 0 ) ) CYCLE 16742 16743 Nodes % x(1:n) = Mesh % Nodes % x(Indexes) 16744 Nodes % y(1:n) = Mesh % Nodes % y(Indexes) 16745 Nodes % z(1:n) = Mesh % Nodes % z(Indexes) 16746 16747 STIFF = 0.0d0 16748 FORCE = 0.0d0 16749 16750 ! Numerical integration: 16751 !---------------------- 16752 IP = GaussPoints( Element ) 16753 16754 DO k=1,IP % n 16755 16756 ! Basis function values & derivatives at the integration point: 16757 !-------------------------------------------------------------- 16758 stat = ElementInfo( Element, Nodes, IP % U(k), IP % V(k), & 16759 IP % W(k), detJ, Basis ) 16760 16761 ! Finally, the elemental matrix & vector: 16762 !---------------------------------------- 16763 DO i=1,n 16764 val = IP % s(k) * DetJ 16765 DO j=1,n 16766 STIFF(i,j) = STIFF(i,j) + val * Basis(i) * Basis(j) 16767 END DO 16768 END DO 16769 END DO 16770 16771 CALL UpdateGlobalEquations( A,STIFF,rhs,FORCE,n,1,Perm(Indexes(1:n)) ) 16772 END DO 16773 16774 DEALLOCATE( Basis, FORCE, STIFF, & 16775 Nodes % x, Nodes % y, Nodes % z) 16776 DEALLOCATE( rhs ) 16777 16778 END SUBROUTINE MassMatrixAssembly 16779 16780 16781 16782!------------------------------------------------------------------------------ 16783!> Create diagonal matrix from P (not square) by summing the entries together 16784!> and multiplying with a constant. 16785!------------------------------------------------------------------------------ 16786 SUBROUTINE DiagonalMatrixSumming( Solver, P, A ) 16787 16788 TYPE(Solver_t) :: Solver 16789 TYPE(Matrix_t), POINTER :: P, A 16790 !------------------------------------------------------------------------------ 16791 INTEGER :: i,j,k,n 16792 REAL(KIND=dp) :: val, rowsum, minsum, maxsum, sumsum 16793 16794 CALL Info('DiagonalMatrixSumming','Creating diagonal matrix from absolute rowsums',Level=8) 16795 16796 IF(.NOT. ASSOCIATED(P) ) CALL Fatal('DiagonalMatrixSumming','Matrix P not associated!') 16797 IF(.NOT. ASSOCIATED(A) ) CALL Fatal('DiagonalMatrixSumming','Matrix A not associated!') 16798 16799 16800 n = P % NumberOfRows 16801 CALL Info('DiagonalMatrixSumming','Number of rows in matrix: '//TRIM(I2S(n)),Level=10) 16802 16803 A % FORMAT = MATRIX_CRS 16804 16805 A % NumberOfRows = n 16806 ALLOCATE( A % Cols(n), A % Rows(n+1), A % Values(n) ) 16807 16808 A % Cols = 0 16809 A % Rows = 0 16810 A % Values = 0.0_dp 16811 16812 minsum = HUGE(minsum) 16813 maxsum = 0.0_dp 16814 sumsum = 0.0_dp 16815 16816 DO i = 1, n 16817 rowsum = 0.0_dp 16818 DO j=P % Rows(i),P % Rows(i+1)-1 16819 k = P % Cols(j) 16820 val = P % Values(j) 16821 rowsum = rowsum + ABS( val ) 16822 END DO 16823 16824 A % Values(i) = rowsum 16825 A % Cols(i) = i 16826 A % Rows(i) = i 16827 16828 minsum = MIN(minsum, rowsum) 16829 maxsum = MAX(maxsum, rowsum) 16830 sumsum = sumsum + rowsum 16831 END DO 16832 A % Rows(n+1) = n+1 16833 16834 PRINT *,'diagonal sums:',minsum,maxsum,sumsum/n 16835 16836 END SUBROUTINE DiagonalMatrixSumming 16837 16838 16839 16840!------------------------------------------------------------------------------ 16841!> Assemble coupling matrix related to fluid-structure interaction 16842!------------------------------------------------------------------------------ 16843 SUBROUTINE FsiCouplingAssembly( Solver, FVar, SVar, A_f, A_s, A_fs, A_sf, & 16844 IsPlate, IsShell, IsNS ) 16845 16846 TYPE(Solver_t) :: Solver ! leading solver 16847 TYPE(Variable_t), POINTER :: FVar ! fluid variable 16848 TYPE(Variable_t), POINTER :: SVar ! structure variable 16849 TYPE(Matrix_t), POINTER :: A_fs, A_sf, A_f, A_s 16850 LOGICAL :: IsPlate, IsShell, IsNS 16851 !------------------------------------------------------------------------------ 16852 LOGICAL, POINTER :: ConstrainedF(:), ConstrainedS(:) 16853 INTEGER, POINTER :: FPerm(:), SPerm(:) 16854 INTEGER :: FDofs, SDofs 16855 TYPE(Mesh_t), POINTER :: Mesh 16856 INTEGER, POINTER :: Indexes(:), pIndexes(:) 16857 INTEGER :: i,j,ii,jj,k,n,t,istat,pn,ifluid,jstruct,pcomp 16858 TYPE(Element_t), POINTER :: Element, Parent 16859 TYPE(GaussIntegrationPoints_t) :: IP 16860 TYPE(Solver_t), POINTER :: PSolver 16861 TYPE(Nodes_t) :: Nodes 16862 REAL(KIND=dp), ALLOCATABLE :: MASS(:,:) 16863 REAL(KIND=dp), POINTER :: Basis(:) 16864 REAL(KIND=dp) :: detJ, val, c(3), pc(3), Normal(3), coeff, Omega, Rho, area, fdiag 16865 LOGICAL :: Stat, IsHarmonic 16866 INTEGER :: dim,mat_id,tcount 16867 LOGICAL :: FreeF, FreeS, FreeFim, FreeSim, UseDensity, Found 16868 LOGICAL, ALLOCATABLE :: NodeDone(:) 16869 REAL(KIND=dp) :: MultSF, MultFS 16870 CHARACTER(*), PARAMETER :: Caller = 'FsiCouplingAssembly' 16871 16872 16873 CALL Info(Caller,'Creating coupling matrix for harmonic FSI',Level=6) 16874 16875 16876 IF( A_fs % FORMAT /= MATRIX_LIST ) THEN 16877 A_fs % Values = 0.0_dp 16878 A_sf % Values = 0.0_dp 16879 END IF 16880 16881 16882 Mesh => Solver % Mesh 16883 FPerm => FVar % Perm 16884 SPerm => SVar % Perm 16885 16886 fdofs = FVar % Dofs 16887 sdofs = SVar % Dofs 16888 16889 IF( IsPlate ) CALL Info(Caller,'Assuming structure to be plate',Level=8) 16890 16891 IF( IsShell ) CALL Info(Caller,'Assuming structure to be shell',Level=8) 16892 16893 IF( IsNS ) CALL Info(Caller,'Assuming fluid to have velocities',Level=8) 16894 16895 16896 UseDensity = .FALSE. 16897 DO i=1,CurrentModel % NumberOfSolvers 16898 PSolver => CurrentModel % Solvers(i) 16899 IF( ASSOCIATED( PSolver % Variable, FVar ) ) THEN 16900 UseDensity = ListGetLogical( PSolver % Values,'Use Density',Found ) 16901 EXIT 16902 END IF 16903 END DO 16904 IF( UseDensity ) THEN 16905 CALL Info(Caller,'The Helmholtz equation is multiplied by density',Level=10) 16906 END IF 16907 16908 16909 ConstrainedF => A_f % ConstrainedDof 16910 ConstrainedS => A_s % ConstrainedDof 16911 16912 16913 ! Here we assume harmonic coupling if there are more then 3 structure dofs 16914 dim = 3 16915 IsHarmonic = .FALSE. 16916 IF( IsPlate ) THEN 16917 IF( sdofs == 6 ) THEN 16918 IsHarmonic = .TRUE. 16919 ELSE IF( sdofs /= 3 ) THEN 16920 CALL Fatal(Caller,'Invalid number of dofs in plate solver: '//TRIM(I2S(sdofs))) 16921 END IF 16922 ELSE IF( IsShell ) THEN 16923 IF( sdofs == 12 ) THEN 16924 IsHarmonic = .TRUE. 16925 ELSE IF( sdofs /= 6 ) THEN 16926 CALL Fatal(Caller,'Invalid number of dofs in shell solver: '//TRIM(I2S(sdofs))) 16927 END IF 16928 ELSE 16929 IF( sdofs == 4 .OR. sdofs == 6 ) THEN 16930 IsHarmonic = .TRUE. 16931 ELSE IF( sdofs /= 2 .AND. sdofs /= 3 ) THEN 16932 CALL Fatal(Caller,'Invalid number of dofs in elasticity solver: '//TRIM(I2S(sdofs))) 16933 END IF 16934 IF( sdofs == 4 .OR. sdofs == 2 ) dim = 2 16935 END IF 16936 16937 ! The elasticity solver defines whether the system is real or harmonic 16938 IF( IsHarmonic ) THEN 16939 CALL Info(Caller,'Assuming harmonic coupling matrix',Level=10) 16940 ELSE 16941 CALL Info(Caller,'Assuming real valued coupling matrix',Level=10) 16942 END IF 16943 16944 16945 ! The fluid system must be consistent with elasticity system 16946 IF( IsNS ) THEN 16947 IF( IsHarmonic ) THEN 16948 IF( fdofs /= 2*(dim+2) .AND. fdofs /= 2*(dim+1) ) THEN 16949 CALL Fatal(Caller,& 16950 'Inconsistent number of harmonic dofs in NS solver: '//TRIM(I2S(fdofs))) 16951 END IF 16952 ! pressure component 16953 pcomp = fdofs / 2 16954 ELSE 16955 IF( fdofs /= (dim+2) .AND. fdofs /= (dim+1) ) THEN 16956 CALL Fatal(Caller,& 16957 'Inconsistent number of real dofs in NS solver: '//TRIM(I2S(fdofs))) 16958 END IF 16959 pcomp = fdofs 16960 END IF 16961 ALLOCATE( NodeDone(MAXVAL(FPerm)) ) 16962 NodeDone = .FALSE. 16963 ELSE 16964 IF( IsHarmonic ) THEN 16965 IF( fdofs /= 2 ) CALL Fatal(Caller,& 16966 'Inconsistent number of harmonic dofs in pressure solver: '//TRIM(I2S(fdofs))) 16967 ELSE 16968 IF( fdofs /= 1 ) CALL Fatal(Caller,& 16969 'Inconsistent number of real dofs in pressure solver: '//TRIM(I2S(fdofs))) 16970 END IF 16971 pcomp = 1 16972 END IF 16973 16974 16975 IF( IsHarmonic ) THEN 16976 Omega = 2 * PI * ListGetCReal( CurrentModel % Simulation,'Frequency',Stat ) 16977 IF( .NOT. Stat) THEN 16978 CALL Fatal(Caller,'Frequency in Simulation list not found!') 16979 END IF 16980 ELSE 16981 Omega = 0.0_dp 16982 END IF 16983 16984 i = SIZE( FVar % Values ) 16985 j = SIZE( SVar % Values ) 16986 16987 CALL Info(Caller,'Fluid dofs '//TRIM(I2S(i))//& 16988 ' with '//TRIM(I2S(fdofs))//' components',Level=10) 16989 CALL Info(Caller,'Structure dofs '//TRIM(I2S(j))//& 16990 ' with '//TRIM(I2S(sdofs))//' components',Level=10) 16991 CALL Info(Caller,'Assuming '//TRIM(I2S(dim))//& 16992 ' active dimensions',Level=10) 16993 16994 ! Add the lasrgest entry that allocates the whole list matrix structure 16995 CALL AddToMatrixElement(A_fs,i,j,0.0_dp) 16996 CALL AddToMatrixElement(A_sf,j,i,0.0_dp) 16997 16998 N = Mesh % MaxElementNodes 16999 ALLOCATE( Basis(n), MASS(N,N), Nodes % x(n), Nodes % y(n), Nodes % z(n), & 17000 STAT=istat) 17001 17002 tcount = 0 17003 area = 0.0_dp 17004 17005 MultFS = ListGetCReal( Solver % Values,'FS multiplier',Found) 17006 IF( .NOT. Found ) MultFS = 1.0_dp 17007 17008 MultSF = ListGetCReal( Solver % Values,'SF multiplier',Found) 17009 IF( .NOT. Found ) MultSF = 1.0_dp 17010 17011 FreeS = .TRUE.; FreeSim = .TRUE. 17012 FreeF = .TRUE.; FreeFim = .TRUE. 17013 17014 17015 DO t=Mesh % NumberOfBulkElements+1, & 17016 Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 17017 17018 Element => Mesh % Elements(t) 17019 n = Element % TYPE % NumberOfNodes 17020 Indexes => Element % NodeIndexes 17021 17022 IF( ANY( FPerm(Indexes) == 0 ) ) CYCLE 17023 IF( ANY( SPerm(Indexes) == 0 ) ) CYCLE 17024 IF( .NOT. ASSOCIATED( Element % BoundaryInfo ) ) CYCLE 17025 17026 Nodes % x(1:n) = Mesh % Nodes % x(Indexes) 17027 Nodes % y(1:n) = Mesh % Nodes % y(Indexes) 17028 Nodes % z(1:n) = Mesh % Nodes % z(Indexes) 17029 17030 Normal = NormalVector( Element, Nodes ) 17031 17032 17033 ! The following is done in order to check that the normal points to the fluid 17034 Parent => Element % BoundaryInfo % Left 17035 IF( ASSOCIATED( Parent ) ) THEN 17036 IF( ANY( FPerm(Parent % NodeIndexes) == 0 ) ) Parent => NULL() 17037 END IF 17038 17039 IF(.NOT. ASSOCIATED( Parent ) ) THEN 17040 Parent => Element % BoundaryInfo % Right 17041 IF( ASSOCIATED( Parent ) ) THEN 17042 IF( ANY( FPerm(Parent % NodeIndexes) == 0 ) ) Parent => NULL() 17043 END IF 17044 END IF 17045 17046 ! Could not find a proper fluid element to define the normal 17047 IF(.NOT. ASSOCIATED( Parent ) ) CYCLE 17048 17049 tcount = tcount + 1 17050 17051 17052 pn = Parent % TYPE % NumberOfNodes 17053 pIndexes => Parent % NodeIndexes 17054 17055 c(1) = SUM( Nodes % x(1:n) ) / n 17056 c(2) = SUM( Nodes % y(1:n) ) / n 17057 c(3) = SUM( Nodes % z(1:n) ) / n 17058 17059 pc(1) = SUM( Mesh % Nodes % x(pIndexes) ) / pn 17060 pc(2) = SUM( Mesh % Nodes % y(pIndexes) ) / pn 17061 pc(3) = SUM( Mesh % Nodes % z(pIndexes) ) / pn 17062 17063 ! The normal vector has negative projection to the vector drawn from center of 17064 ! boundary element to the center of bulk element. 17065 IF( SUM( (pc-c) * Normal ) < 0.0_dp ) THEN 17066 Normal = -Normal 17067 END IF 17068 17069 MASS(1:n,1:n) = 0.0_dp 17070 17071 mat_id = ListGetInteger( CurrentModel % Bodies(Parent % BodyId) % Values,'Material' ) 17072 rho = ListGetConstReal( CurrentModel % Materials(mat_id) % Values,'Density',Stat) 17073 IF(.NOT. Stat) rho = ListGetConstReal( CurrentModel % Materials(mat_id) % Values, & 17074 'Equilibrium Density',Stat) 17075 17076 IF( .NOT. Stat) THEN 17077 CALL Fatal(Caller,'Fluid density not found in material :'//TRIM(I2S(mat_id))) 17078 END IF 17079 17080 ! The sign depends on the convection of the normal direction 17081 ! If density is divided out already in the Helmholtz equation the multiplier will 17082 ! be different. 17083 IF( UseDensity ) THEN 17084 coeff = omega**2 17085 ELSE 17086 coeff = rho * omega**2 17087 END IF 17088 17089 ! Numerical integration: 17090 !---------------------- 17091 IP = GaussPoints( Element ) 17092 17093 DO k=1,IP % n 17094 ! Basis function values & derivatives at the integration point: 17095 !-------------------------------------------------------------- 17096 stat = ElementInfo( Element, Nodes, IP % U(k), IP % V(k), & 17097 IP % W(k), detJ, Basis ) 17098 17099 ! The mass matrix of the boundary element 17100 !---------------------------------------- 17101 val = IP % s(k) * detJ 17102 DO i=1,n 17103 DO j=1,n 17104 MASS(i,j) = MASS(i,j) + val * Basis(i) * Basis(j) 17105 END DO 17106 END DO 17107 area = area + val 17108 END DO 17109 17110 ! A: fs 17111 ! Effect of structure on fluid 17112 IF( IsNs ) THEN 17113 ! For the N-S equation the condition applies directly on the velocity components 17114 17115 DO i=1,n 17116 ii = Indexes(i) 17117 j = i 17118 jj = Indexes(j) ! one-to-one mapping 17119 17120 17121 IF( NodeDone( Fperm(ii) ) ) CYCLE 17122 NodeDone( FPerm(ii) ) = .TRUE. 17123 17124 17125 DO k=1,dim 17126 17127 ! The velocity component of the fluid 17128 IF( IsHarmonic ) THEN 17129 ifluid = fdofs*(FPerm(ii)-1)+2*(k-1)+1 17130 !IF( ASSOCIATED( ConstrainedF ) ) THEN 17131 ! FreeF = .NOT. ConstrainedF(ifluid) 17132 ! FreeFim = .NOT. ConstrainedF(ifluid+1) 17133 !END IF 17134 ELSE 17135 ifluid = fdofs*(FPerm(ii)-1)+k 17136 !IF( ASSOCIATED( ConstrainedF ) ) THEN 17137 ! FreeF = .NOT. ConstrainedF(ifluid) 17138 !END IF 17139 END IF 17140 17141 ! Shell and 3D elasticity are both treated with the same routine 17142 IF( .NOT. IsPlate ) THEN 17143 17144 IF( IsHarmonic ) THEN 17145 val = omega 17146 jstruct = sdofs*(SPerm(jj)-1)+2*(k-1)+1 17147 ELSE 17148 CALL Fatal(Caller,'NS coupling only done for harmonic system!') 17149 END IF 17150 17151 17152 ELSE ! If IsPlate 17153 IF( IsHarmonic ) THEN 17154 val = omega * Normal(k) 17155 17156 ! By default the plate should be oriented so that normal points to z 17157 ! If there is a plate then fluid is always 3D 17158 IF( Normal(3) < 0 ) val = -val 17159 17160 jstruct = sdofs*(SPerm(jj)-1)+1 17161 ELSE 17162 CALL Fatal(Caller,'NS coupling only done for harmonic system!') 17163 END IF 17164 END IF 17165 17166 IF( IsHarmonic ) THEN 17167 ! Structure load on the fluid: v = i*omega*u 17168 fdiag = A_f % Values( A_f % diag(ifluid) ) 17169 IF( FreeF ) THEN 17170 CALL AddToMatrixElement(A_fs,ifluid,jstruct+1,MultFS*val*fdiag) ! Re 17171 ELSE 17172 CALL AddToMatrixElement(A_fs,ifluid,jstruct+1,0.0_dp) 17173 END IF 17174 17175 fdiag = A_f % Values( A_f % diag(ifluid+1) ) 17176 IF( FreeFim ) THEN 17177 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct,-MultFS*val*fdiag) ! Im 17178 ELSE 17179 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct+1,0.0_dp ) 17180 END IF 17181 17182 ! These must be created for completeness because the matrix topology of complex 17183 ! matrices must be the same for all components. 17184 CALL AddToMatrixElement(A_fs,ifluid,jstruct,0.0_dp) 17185 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct+1,0.0_dp) 17186 ELSE 17187 CALL Fatal(Caller,'NS coupling only done for harmonic system!') 17188 END IF 17189 END DO 17190 END DO 17191 17192 ELSE ! .NOT. IsNS 17193 ! For pressure equations (Helmholtz) the structure applies a Neumann condition 17194 17195 DO i=1,n 17196 ii = Indexes(i) 17197 17198 ! The pressure component of the fluid 17199 IF( IsHarmonic ) THEN 17200 ifluid = fdofs*(FPerm(ii)-1)+2*(pcomp-1)+1 17201 IF( ASSOCIATED( ConstrainedF ) ) THEN 17202 FreeF = .NOT. ConstrainedF(ifluid) 17203 FreeFim = .NOT. ConstrainedF(ifluid+1) 17204 END IF 17205 ELSE 17206 ifluid = fdofs*(FPerm(ii)-1)+pcomp 17207 IF( ASSOCIATED( ConstrainedF ) ) THEN 17208 FreeF = .NOT. ConstrainedF(ifluid) 17209 END IF 17210 END IF 17211 17212 17213 DO j=1,n 17214 jj = Indexes(j) 17215 17216 ! Shell and 3D elasticity are both treated with the same routine 17217 IF( .NOT. IsPlate ) THEN 17218 17219 DO k=1,dim 17220 17221 val = MASS(i,j) * Normal(k) 17222 17223 IF( IsHarmonic ) THEN 17224 jstruct = sdofs*(SPerm(jj)-1)+2*(k-1)+1 17225 17226 ! Structure load on the fluid: This assembles 17227 ! 17228 ! -1/rho <dp/dn,v> = -omega^2 <u.n,v> = omega^2 <u.m,v> 17229 ! 17230 ! with the normal vectors satisfying m = -n. Note that the density (rho) 17231 ! must be defined for Helmholtz solver to make it assemble a system 17232 ! consistent with the boundary integral -1/rho <dp/dn,v>. 17233 IF( FreeF ) THEN 17234 CALL AddToMatrixElement(A_fs,ifluid,jstruct,MultFS*val*coeff) ! Re 17235 ELSE 17236 CALL AddToMatrixElement(A_fs,ifluid,jstruct,0.0_dp) 17237 END IF 17238 17239 IF( FreeFim ) THEN 17240 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct+1,MultFS*val*coeff) ! Im 17241 ELSE 17242 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct+1,0.0_dp ) 17243 END IF 17244 17245 ! These must be created for completeness because the matrix topology of complex 17246 ! matrices must be the same for all components. 17247 CALL AddToMatrixElement(A_fs,ifluid,jstruct+1,0.0_dp) 17248 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct,0.0_dp) 17249 ELSE 17250 jstruct = sdofs*(SPerm(jj)-1)+k 17251 17252 ! Structure load on the fluid: dp/dn = -u. (This seems strange???) 17253 IF( FreeF ) THEN 17254 CALL AddToMatrixElement(A_fs,ifluid,jstruct,-MultFS*val) 17255 END IF 17256 END IF 17257 END DO 17258 17259 ELSE ! If IsPlate 17260 17261 val = MASS(i,j) 17262 17263 ! By default the plate should be oriented so that normal points to z 17264 ! If there is a plate then fluid is always 3D 17265 IF( Normal(3) < 0 ) val = -val 17266 17267 IF( IsHarmonic ) THEN 17268 jstruct = sdofs*(SPerm(jj)-1)+1 17269 17270 ! Structure load on the fluid: -1/rho dp/dn = -omega^2 u.n = omega^2 u.m 17271 IF( FreeF ) THEN 17272 CALL AddToMatrixElement(A_fs,ifluid,jstruct,MultFS*val*coeff) ! Re 17273 ELSE 17274 CALL AddToMatrixElement(A_fs,ifluid,jstruct,0.0_dp) 17275 END IF 17276 17277 IF( FreeFim ) THEN 17278 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct+1,MultFS*val*coeff) ! Im 17279 ELSE 17280 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct+1,0.0_dp ) 17281 END IF 17282 17283 ! These must be created for completeness because the matrix topology of complex 17284 ! matrices must be the same for all components. 17285 CALL AddToMatrixElement(A_fs,ifluid,jstruct+1,0.0_dp) 17286 CALL AddToMatrixElement(A_fs,ifluid+1,jstruct,0.0_dp) 17287 ELSE 17288 jstruct = sdofs*(SPerm(jj)-1)+1 17289 17290 ! Structure load on the fluid: dp/dn = -u. (This seems strange???) 17291 IF( FreeF ) THEN 17292 CALL AddToMatrixElement(A_fs,ifluid,jstruct,-MultFS*val) 17293 END IF 17294 END IF 17295 17296 END IF 17297 17298 END DO 17299 END DO 17300 END IF 17301 17302 17303 ! A_sf: 17304 ! Effect of fluid (pressure) on structure. 17305 ! Each component get the normal component of the pressure as a r.h.s. term. 17306 ! The plate equation just gets the full load and is treated separately. 17307 !---------------------------------------------------------------------------- 17308 DO i=1,n 17309 ii = Indexes(i) 17310 17311 ! The pressure component of the fluid 17312 IF( IsHarmonic ) THEN 17313 ifluid = fdofs*(FPerm(ii)-1)+2*(pcomp-1)+1 17314 ELSE 17315 ifluid = fdofs*(FPerm(ii)-1)+pcomp 17316 END IF 17317 17318 DO j=1,n 17319 jj = Indexes(j) 17320 17321 ! Shell and 3D elasticity are both treated with the same routine 17322 IF( .NOT. IsPlate ) THEN 17323 17324 DO k=1,dim 17325 17326 val = MASS(i,j) * Normal(k) 17327 17328 IF( IsHarmonic ) THEN 17329 jstruct = sdofs*(SPerm(jj)-1)+2*(k-1)+1 17330 17331 IF( ASSOCIATED( ConstrainedS ) ) THEN 17332 FreeS = .NOT. ConstrainedS(jstruct) 17333 FreeSim = .NOT. ConstrainedS(jstruct+1) 17334 END IF 17335 17336 ! Fluid load on the structure: tau \cdot n = p * n 17337 IF( FreeS ) THEN 17338 CALL AddToMatrixElement(A_sf,jstruct,ifluid,MultSF*val) ! Re terms coupling 17339 ELSE 17340 CALL AddToMatrixElement(A_sf,jstruct,ifluid,0.0_dp) 17341 END IF 17342 17343 IF( FreeSim ) THEN 17344 CALL AddToMatrixElement(A_sf,jstruct+1,ifluid+1,MultSF*val) ! Im 17345 ELSE 17346 CALL AddToMatrixElement(A_sf,jstruct+1,ifluid+1,0.0_dp) 17347 END IF 17348 17349 ! These must be created for completeness because the matrix topology of complex 17350 ! matrices must be the same for all components. 17351 CALL AddToMatrixElement(A_sf,jstruct,ifluid+1,0.0_dp) 17352 CALL AddToMatrixElement(A_sf,jstruct+1,ifluid,0.0_dp) 17353 ELSE 17354 jstruct = sdofs*(SPerm(jj)-1)+k 17355 17356 IF( ASSOCIATED( ConstrainedS ) ) THEN 17357 FreeS = .NOT. ConstrainedS(jstruct) 17358 END IF 17359 17360 ! Fluid load on the structure: tau \cdot n = p * n 17361 IF( FreeS ) THEN 17362 CALL AddToMatrixElement(A_sf,jstruct,ifluid,MultSF*val) 17363 END IF 17364 17365 END IF 17366 END DO 17367 17368 ELSE ! If IsPlate 17369 17370 val = MASS(i,j) 17371 17372 ! By default the plate should be oriented so that normal points to z 17373 ! If there is a plate then fluid is always 3D 17374 IF( Normal(3) < 0 ) val = -val 17375 17376 IF( IsHarmonic ) THEN 17377 jstruct = sdofs*(SPerm(jj)-1)+1 17378 17379 IF( ASSOCIATED( ConstrainedS ) ) THEN 17380 FreeS = .NOT. ConstrainedS(jstruct) 17381 FreeSim = .NOT. ConstrainedS(jstruct+1) 17382 END IF 17383 17384 ! Fluid load on the structure: tau \cdot n = p * n 17385 IF( FreeS ) THEN 17386 CALL AddToMatrixElement(A_sf,jstruct,ifluid,MultSF*val) ! Re terms coupling 17387 ELSE 17388 CALL AddToMatrixElement(A_sf,jstruct,ifluid,0.0_dp) 17389 END IF 17390 17391 IF( FreeSim ) THEN 17392 CALL AddToMatrixElement(A_sf,jstruct+1,ifluid+1,MultSF*val) ! Im 17393 ELSE 17394 CALL AddToMatrixElement(A_sf,jstruct+1,ifluid+1,0.0_dp) 17395 END IF 17396 17397 ! These must be created for completeness because the matrix topology of complex 17398 ! matrices must be the same for all components. 17399 CALL AddToMatrixElement(A_sf,jstruct,ifluid+1,0.0_dp) 17400 CALL AddToMatrixElement(A_sf,jstruct+1,ifluid,0.0_dp) 17401 ELSE 17402 jstruct = sdofs*(SPerm(jj)-1)+1 17403 17404 IF( ASSOCIATED( ConstrainedS ) ) THEN 17405 FreeS = .NOT. ConstrainedS(jstruct) 17406 END IF 17407 17408 ! Fluid load on the structure: tau \cdot n = p * n 17409 IF( FreeS ) THEN 17410 CALL AddToMatrixElement(A_sf,jstruct,ifluid,MultSF*val) 17411 END IF 17412 END IF 17413 17414 END IF 17415 17416 END DO 17417 END DO 17418 17419 END DO ! Loop over boundary elements 17420 17421 17422 DEALLOCATE( Basis, MASS, Nodes % x, Nodes % y, Nodes % z) 17423 17424 IF( A_fs % FORMAT == MATRIX_LIST ) THEN 17425 CALL List_toCRSMatrix(A_fs) 17426 CALL List_toCRSMatrix(A_sf) 17427 END IF 17428 17429 !PRINT *,'interface area:',area 17430 !PRINT *,'interface fs sum:',SUM(A_fs % Values), SUM( ABS( A_fs % Values ) ) 17431 !PRINT *,'interface sf sum:',SUM(A_sf % Values), SUM( ABS( A_sf % Values ) ) 17432 17433 CALL Info(Caller,'Number of elements on interface: '& 17434 //TRIM(I2S(tcount)),Level=10) 17435 CALL Info(Caller,'Number of entries in fluid-structure matrix: '& 17436 //TRIM(I2S(SIZE(A_fs % Values))),Level=10) 17437 CALL Info(Caller,'Number of entries in structure-fluid matrix: '& 17438 //TRIM(I2S(SIZE(A_sf % Values))),Level=10) 17439 17440 CALL Info(Caller,'All done',Level=20) 17441 17442 17443 END SUBROUTINE FsiCouplingAssembly 17444 17445 17446 17447 17448 17449 17450 ! The following function is a copy from ShellSolver.F90. 17451 ! The suffix Int is added for unique naming. 17452 !------------------------------------------------------------------------------- 17453 FUNCTION GetElementalDirectorInt(Mesh, Element, & 17454 ElementNodes, node) RESULT(DirectorValues) 17455 !------------------------------------------------------------------------------- 17456 TYPE(Mesh_t), POINTER :: Mesh 17457 TYPE(Element_t), POINTER, INTENT(IN) :: Element 17458 TYPE(Nodes_t), OPTIONAL, INTENT(IN) :: ElementNodes 17459 INTEGER, OPTIONAL :: node 17460 REAL(KIND=dp), POINTER :: DirectorValues(:) 17461 !------------------------------------------------------------------------------- 17462 TYPE(Nodes_t) :: Nodes 17463 LOGICAL :: Visited = .FALSE., UseElementProperty = .FALSE., UseNormalSolver = .FALSE. 17464 REAL(KIND=dp) :: Normal(3) 17465 REAL(KIND=dp), POINTER :: NodalNormals(:) 17466 REAL(KIND=dp), POINTER :: DirectorAtNode(:) 17467 REAL(KIND=dp), POINTER :: PropertyValues(:) 17468 INTEGER :: n 17469 17470 SAVE Visited, UseElementProperty, NodalNormals, DirectorAtNode, Nodes 17471 !------------------------------------------------------------------------------- 17472 17473 IF (.NOT. Visited) THEN 17474 DirectorValues => GetElementPropertyInt('director', Element) 17475 UseElementProperty = ASSOCIATED( DirectorValues ) 17476 17477 IF (.NOT. UseElementProperty) THEN 17478 n = CurrentModel % MaxElementNodes 17479 ALLOCATE( NodalNormals(3*n), Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 17480 END IF 17481 ALLOCATE( DirectorAtNode(3) ) 17482 Visited = .TRUE. 17483 END IF 17484 17485 IF ( UseElementProperty ) THEN 17486 PropertyValues => GetElementPropertyInt('director', Element) 17487 IF( PRESENT( node ) ) THEN 17488 DirectorAtNode(1:3) = PropertyValues(3*(node-1)+1:3*node) 17489 DirectorValues => DirectorAtNode 17490 ELSE 17491 DirectorValues => PropertyValues 17492 END IF 17493 17494 ELSE 17495 IF( PRESENT( ElementNodes ) ) THEN 17496 Normal = NormalVector( Element, ElementNodes, Check = .TRUE. ) 17497 ELSE 17498 n = Element % Type % NumberOfNodes 17499 Nodes % x(1:n) = Mesh % Nodes % x(Element % NodeIndexes) 17500 Nodes % y(1:n) = Mesh % Nodes % y(Element % NodeIndexes) 17501 Nodes % z(1:n) = Mesh % Nodes % z(Element % NodeIndexes) 17502 Normal = NormalVector( Element, Nodes, Check = .TRUE. ) 17503 END IF 17504 17505 IF( PRESENT( node ) ) THEN 17506 !PRINT *,'Normal:',Normal 17507 DirectorAtNode(1:3) = Normal(1:3) 17508 DirectorValues => DirectorAtNode 17509 ELSE 17510 n = Element % TYPE % NumberOfNodes 17511 NodalNormals(1:3*n:3) = Normal(1) 17512 NodalNormals(2:3*n:3) = Normal(2) 17513 NodalNormals(3:3*n:3) = Normal(3) 17514 DirectorValues => NodalNormals 17515 END IF 17516 END IF 17517 17518 CONTAINS 17519 17520 FUNCTION GetElementPropertyInt( Name, Element ) RESULT(Values) 17521 CHARACTER(LEN=*) :: Name 17522 TYPE(Element_t), POINTER :: Element 17523 REAL(KIND=dp), POINTER :: Values(:) 17524 17525 TYPE(ElementData_t), POINTER :: p 17526 17527 Values => NULL() 17528 p=> Element % PropertyData 17529 17530 DO WHILE( ASSOCIATED(p) ) 17531 IF ( Name==p % Name ) THEN 17532 Values => p % Values 17533 RETURN 17534 END IF 17535 p => p % Next 17536 END DO 17537 END FUNCTION GetElementPropertyInt 17538 17539 !------------------------------------------------------------------------------- 17540 END FUNCTION GetElementalDirectorInt 17541 !------------------------------------------------------------------------------- 17542 17543 17544 17545!------------------------------------------------------------------------------ 17546!> Assemble coupling matrices related to structure-structure interaction. 17547!> A possible scenario is that the diagonal blocks are the matrices of the 17548!> solvers listed using the keyword "Block Solvers". The (1,1)-block is then 17549!> tied up with the value of the first entry in the "Block Solvers" array. 17550!------------------------------------------------------------------------------ 17551 SUBROUTINE StructureCouplingAssembly(Solver, FVar, SVar, A_f, A_s, A_fs, A_sf, & 17552 IsSolid, IsPlate, IsShell, IsBeam, DrillingDOFs) 17553!------------------------------------------------------------------------------ 17554 TYPE(Solver_t) :: Solver !< The leading solver defining block structure 17555 TYPE(Variable_t), POINTER :: FVar !< "Slave" structure variable 17556 TYPE(Variable_t), POINTER :: SVar !< "Master" structure variable 17557 TYPE(Matrix_t), POINTER :: A_f !< (2,2)-block for the "slave" variable 17558 TYPE(Matrix_t), POINTER :: A_s !< (1,1)-block for the "master" variable 17559 TYPE(Matrix_t), POINTER :: A_fs !< (2,1)-block for interaction 17560 TYPE(Matrix_t), POINTER :: A_sf !< (1,2)-block for interaction 17561 LOGICAL :: IsSolid, IsPlate, IsShell, IsBeam !< The type of the slave variable 17562 LOGICAL :: DrillingDOFs !< Use drilling rotation formulation for shells 17563 !------------------------------------------------------------------------------ 17564 TYPE(Mesh_t), POINTER :: Mesh 17565 LOGICAL, POINTER :: ConstrainedF(:), ConstrainedS(:) 17566 LOGICAL :: DoDamp, DoMass 17567 INTEGER, POINTER :: FPerm(:), SPerm(:) 17568 INTEGER :: FDofs, SDofs 17569 INTEGER :: i,j,k,jf,js,kf,ks,nf,ns,dim,ncount 17570 REAL(KIND=dp) :: vdiag 17571 CHARACTER(*), PARAMETER :: Caller = 'StructureCouplingAssembly' 17572 !------------------------------------------------------------------------------ 17573 17574 CALL Info(Caller,'Creating coupling matrix for structures',Level=6) 17575 17576 Mesh => Solver % Mesh 17577 dim = Mesh % MeshDim 17578 17579 ! S refers to the first and F to the second block (was fluid): 17580 FPerm => FVar % Perm 17581 SPerm => SVar % Perm 17582 17583 fdofs = FVar % Dofs 17584 sdofs = SVar % Dofs 17585 17586 IF( IsSolid ) CALL Info(Caller,'Assuming coupling with solid solver',Level=8) 17587 IF( IsBeam ) CALL Info(Caller,'Assuming coupling with beam solver',Level=8) 17588 IF( IsPlate ) CALL Info(Caller,'Assuming coupling with plate solver',Level=8) 17589 IF( IsShell ) CALL Info(Caller,'Assuming coupling with shell solver',Level=8) 17590 17591 ConstrainedF => A_f % ConstrainedDof 17592 ConstrainedS => A_s % ConstrainedDof 17593 17594 nf = SIZE( FVar % Values ) 17595 ns = SIZE( SVar % Values ) 17596 17597 CALL Info(Caller,'Slave structure dofs '//TRIM(I2S(nf))//& 17598 ' with '//TRIM(I2S(fdofs))//' components',Level=10) 17599 CALL Info(Caller,'Master structure dofs '//TRIM(I2S(ns))//& 17600 ' with '//TRIM(I2S(sdofs))//' components',Level=10) 17601 CALL Info(Caller,'Assuming '//TRIM(I2S(dim))//& 17602 ' active dimensions',Level=10) 17603 17604 IF( A_fs % FORMAT == MATRIX_LIST ) THEN 17605 ! Add the largest entry that allocates the whole list matrix structure 17606 CALL AddToMatrixElement(A_fs,nf,ns,0.0_dp) 17607 CALL AddToMatrixElement(A_sf,ns,nf,0.0_dp) 17608 ELSE 17609 ! If we are revisiting then initialize the CRS matrices to zero 17610 A_fs % Values = 0.0_dp 17611 A_sf % Values = 0.0_dp 17612 END IF 17613 17614 DoMass = .FALSE. 17615 IF( ASSOCIATED( A_f % MassValues ) ) THEN 17616 IF( ASSOCIATED( A_s % MassValues ) ) THEN 17617 DoMass = .TRUE. 17618 ELSE 17619 CALL Warn(Caller,'Both models should have MassValues!') 17620 END IF 17621 END IF 17622 17623 DoDamp = ASSOCIATED( A_f % DampValues ) 17624 IF( DoDamp ) THEN 17625 CALL Warn(Caller,'Damping matrix values at a coupling interface will be dropped!') 17626 END IF 17627 17628 ! This is still under development and not used for anything 17629 ! Probably this will not be needed at all but rather we need the director. 17630 !IF( IsShell ) CALL DetermineCouplingNormals() 17631 17632 ! For the shell equation enforce the directional derivative of the displacement 17633 ! field in implicit manner from solid displacements. The interaction conditions 17634 ! for the corresponding forces are also created. 17635 IF (IsShell) THEN 17636 BLOCK 17637 INTEGER, POINTER :: Indexes(:) 17638 INTEGER, ALLOCATABLE :: NodeHits(:), InterfacePerm(:), InterfaceElems(:,:) 17639 INTEGER :: InterfaceN, hits 17640 INTEGER :: p,lf,ls,ii,jj,n,m,t 17641 INTEGER :: NormalDir 17642 REAL(KIND=dp), POINTER :: Director(:) 17643 REAL(KIND=dp), POINTER :: Basis(:), dBasisdx(:,:) 17644 REAL(KIND=dp), ALLOCATABLE :: A_f0(:), rhs0(:), Mass0(:) 17645 REAL(KIND=dp) :: u,v,w,weight,detJ,val 17646 REAL(KIND=dp) :: x, y, z 17647 17648 TYPE(Element_t), POINTER :: Element, ShellElement 17649 TYPE(Nodes_t) :: Nodes 17650 LOGICAL :: Stat 17651 17652 n = Mesh % MaxElementNodes 17653 ALLOCATE( Basis(n), dBasisdx(n,3), Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 17654 17655 ! Memorize the original values 17656 ALLOCATE( A_f0( SIZE( A_f % Values ) ) ) 17657 A_f0 = A_f % Values 17658 IF (DrillingDOFs) THEN 17659 ALLOCATE(rhs0(SIZE(A_f % rhs))) 17660 rhs0 = A_f % rhs 17661 IF (DoMass) THEN 17662 ALLOCATE(Mass0(SIZE(A_f % MassValues))) 17663 Mass0 = A_f % MassValues 17664 END IF 17665 END IF 17666 17667 ALLOCATE( NodeHits( Mesh % NumberOfNodes ), InterfacePerm( Mesh % NumberOfNodes ) ) 17668 NodeHits = 0 17669 InterfacePerm = 0 17670 17671 ! First, in the basic case zero the rows related to directional derivative dofs, 17672 ! i.e. the components 4,5,6. "s" refers to solid and "f" to shell. 17673 ! 17674 InterfaceN = 0 17675 DO i=1,Mesh % NumberOfNodes 17676 jf = FPerm(i) 17677 js = SPerm(i) 17678 IF( jf == 0 .OR. js == 0 ) CYCLE 17679 17680 ! also number the interface 17681 InterfaceN = InterfaceN + 1 17682 InterfacePerm(i) = InterfaceN 17683 17684 DO lf = 4, 6 17685 kf = fdofs*(jf-1)+lf 17686 17687 IF( ConstrainedF(kf) ) CYCLE 17688 17689 DO k=A_f % Rows(kf),A_f % Rows(kf+1)-1 17690 A_f % Values(k) = 0.0_dp 17691 IF (DoMass) THEN 17692 A_f % MassValues(k) = 0.0_dp 17693 END IF 17694 IF( DoDamp) THEN 17695 A_f % DampValues(k) = 0.0_dp 17696 END IF 17697 END DO 17698 A_f % rhs(kf) = 0.0_dp 17699 END DO 17700 END DO 17701 17702 CALL Info(Caller,'Number of nodes at interface: '//TRIM(I2S(InterfaceN)),Level=12) 17703 17704 ALLOCATE( InterfaceElems(InterfaceN,2) ) 17705 InterfaceElems = 0 17706 17707 ! Then go through shell elements and associate each interface node with a list of 17708 ! shell elements defined in terms of the interface node 17709 DO t=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 17710 Element => Mesh % Elements(t) 17711 Indexes => Element % NodeIndexes 17712 17713 n = Element % TYPE % ElementCode 17714 IF( n > 500 .OR. n < 300 ) CYCLE 17715 17716 ! We must have shell equation present everywhere and solid equation at least in two nodes 17717 IF(ANY( FPerm(Indexes) == 0 ) ) CYCLE 17718 k = COUNT( SPerm(Indexes) > 0 ) 17719 IF( k < 2 ) CYCLE 17720 17721 n = Element % Type % NumberOfNodes 17722 DO i=1,n 17723 j = Indexes(i) 17724 k = InterfacePerm(j) 17725 IF( k == 0) CYCLE 17726 17727 ! Assuming just two shell parents currently 17728 IF( InterfaceElems(k,1) == 0 ) THEN 17729 InterfaceElems(k,1) = t 17730 ELSE IF( InterfaceElems(k,2) == 0 ) THEN 17731 InterfaceElems(k,2) = t 17732 ELSE 17733 CALL Fatal(Caller,'Tree interface elems?') 17734 END IF 17735 END DO 17736 END DO 17737 17738 17739 ! Then go through solid elements associated with the interface and count 17740 ! how many solid elements share each interface node. 17741 NodeHits = 0 17742 DO t=1,Mesh % NumberOfBulkElements 17743 Element => Mesh % Elements(t) 17744 Indexes => Element % NodeIndexes 17745 17746 ! We must have solid equation present everywhere and shell at least at one node. 17747 IF(ANY( SPerm(Indexes) == 0 ) ) CYCLE 17748 IF(ALL( FPerm(Indexes) == 0 ) ) CYCLE 17749 17750 n = COUNT( FPerm(Indexes) > 0 ) 17751 IF( n /= 2 ) THEN 17752 CALL Fatal(Caller,'Currently we can only deal with two hits!') 17753 END IF 17754 17755 DO i=1,SIZE(Indexes) 17756 j = FPerm(Indexes(i)) 17757 IF( j == 0 ) CYCLE 17758 NodeHits(j) = NodeHits(j) + 1 17759 END DO 17760 END DO 17761 17762 !PRINT *,'Maximum node hits:',MAXVAL(NodeHits) 17763 17764 ! Then go through each solid element associated with the interface and 17765 ! create matrix entries defining the interaction conditions for the 17766 ! directional derivatives and corresponding forces. 17767 DO t=1,Mesh % NumberOfBulkElements 17768 Element => Mesh % Elements(t) 17769 Indexes => Element % NodeIndexes 17770 17771 ! We must have solid equation present everywhere and shell at least at one node. 17772 IF(ANY( SPerm(Indexes) == 0 ) ) CYCLE 17773 IF(ALL( FPerm(Indexes) == 0 ) ) CYCLE 17774 17775 n = Element % TYPE % NumberOfNodes 17776 Nodes % x(1:n) = Mesh % Nodes % x(Indexes) 17777 Nodes % y(1:n) = Mesh % Nodes % y(Indexes) 17778 Nodes % z(1:n) = Mesh % Nodes % z(Indexes) 17779 17780 x = 0.0_dp; y = 0.0_dp; z = 0.0_dp 17781 DO i=1,n 17782 IF( FPerm(Indexes(i)) == 0 ) CYCLE 17783 x = x + Nodes % x(i) 17784 y = y + Nodes % y(i) 17785 z = z + Nodes % z(i) 17786 END DO 17787 x = x/2; y = y/2; z = z/2; 17788 17789 ! TO DO: The following call may not work for p-elements! 17790 CALL GlobalToLocal( u, v, w, x, y, z, Element, Nodes ) 17791 17792 ! Integration at the center of the edge 17793 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis, dBasisdx ) 17794 17795 DO ii = 1, n 17796 i = Indexes(ii) 17797 jf = FPerm(i) 17798 IF( jf == 0 ) CYCLE 17799 17800 Weight = 1.0_dp / NodeHits(jf) 17801 17802 !PRINT *,'Weight:',Weight 17803 17804 DO j=1,2 17805 ShellElement => Mesh % Elements(InterfaceElems(InterfacePerm(i),j)) 17806 hits = 0 17807 DO k=1,ShellElement % TYPE % NumberOfNodes 17808 IF( ANY( Indexes == ShellElement % NodeIndexes(k) ) ) hits = hits + 1 17809 END DO 17810 IF( hits >= 2 ) EXIT 17811 END DO 17812 17813 ! Retrieve the director of the shell element: 17814 m = ShellElement % TYPE % NumberOfNodes 17815 DO jj=1,m 17816 IF(Element % NodeIndexes(ii) == ShellElement % NodeIndexes(jj) ) EXIT 17817 END DO 17818 Director => GetElementalDirectorInt(Mesh,ShellElement,node=jj) 17819 17820 !PRINT *,'Director:',ShellElement % ElementIndex,jj,Director 17821 17822 17823 DO lf = 4, 6 17824 kf = fdofs*(jf-1)+lf 17825 17826 IF( ConstrainedF(kf) ) CYCLE 17827 17828 IF (DrillingDOFs) THEN 17829 ! 17830 ! In the case of drilling rotation formulation, the tangential components 17831 ! trace of the global rotations ROT is related to the directional derivative 17832 ! of the displacement field u by -Du[d] x d = d x ROT x d. This implementation 17833 ! is limited to cases where the director is aligned with one of the global 17834 ! coordinate axes. 17835 ! 17836 NormalDir = 0 17837 IF (ABS(1.0_dp - ABS(Director(1))) < 1.0d-5) THEN 17838 NormalDir = 1 17839 ELSE IF (ABS(1.0_dp - ABS(Director(2))) < 1.0d-5) THEN 17840 NormalDir = 2 17841 ELSE IF (ABS(1.0_dp - ABS(Director(3))) < 1.0d-5) THEN 17842 NormalDir = 3 17843 END IF 17844 IF (NormalDir == 0) CALL Fatal(Caller, & 17845 'Coupling with drilling rotation formulation needs an axis-aligned director') 17846 17847 IF ((lf-3) /= NormalDir) THEN 17848 17849 DO p = 1,n 17850 js = SPerm(Indexes(p)) 17851 17852 IF (NormalDir == 1) THEN 17853 SELECT CASE(lf) 17854 CASE(5) 17855 ks = sdofs*(js-1)+3 17856 val = dBasisdx(p,1) 17857 CASE(6) 17858 ks = sdofs*(js-1)+2 17859 val = -dBasisdx(p,1) 17860 END SELECT 17861 ELSE IF (NormalDir == 2) THEN 17862 SELECT CASE(lf) 17863 CASE(4) 17864 ks = sdofs*(js-1)+3 17865 val = -dBasisdx(p,2) 17866 CASE(6) 17867 ks = sdofs*(js-1)+1 17868 val = dBasisdx(p,2) 17869 END SELECT 17870 ELSE IF (NormalDir == 3) THEN 17871 SELECT CASE(lf) 17872 CASE(4) 17873 ks = sdofs*(js-1)+2 17874 val = dBasisdx(p,3) 17875 CASE(5) 17876 ks = sdofs*(js-1)+1 17877 val = -dBasisdx(p,3) 17878 END SELECT 17879 END IF 17880 17881 CALL AddToMatrixElement(A_fs,kf,ks,weight*val) 17882 17883 DO k=A_f % Rows(kf),A_f % Rows(kf+1)-1 17884 CALL AddToMatrixElement(A_sf,ks,A_f % Cols(k),-weight*val*A_f0(k)) 17885 END DO 17886 END DO 17887 17888 ELSE 17889 ! 17890 ! Return one row of deleted values to the shell matrix 17891 ! 17892 DO k=A_f % Rows(kf),A_f % Rows(kf+1)-1 17893 A_f % Values(k) = A_f0(k) 17894 IF (DoMass) A_f % MassValues(k) = Mass0(k) 17895 END DO 17896 17897 A_f % rhs(kf) = rhs0(kf) 17898 17899 ! TO DO: Return also damp values if used 17900 17901 END IF 17902 17903 ELSE 17904 ! 17905 ! Directional derivative dofs D_{i+3} of the shell equations: 17906 ! We try to enforce the condition D_{i+3}=-<(grad u)d,e_i> 17907 ! where i=1,2,3; i+3=lf, d is director, e_i is unit vector, and 17908 ! u is the displacement field of the solid. 17909 ! 17910 DO p = 1, n 17911 js = SPerm(Indexes(p)) 17912 ks = sdofs*(js-1)+lf-3 17913 DO ls = 1, dim 17914 val = Director(ls) * dBasisdx(p,ls) 17915 17916 CALL AddToMatrixElement(A_fs,kf,ks,weight*val) 17917 17918 ! Here the idea is to distribute the implicit moments of the shell solver 17919 ! to forces for the solid solver. So even though the stiffness matrix related to the 17920 ! directional derivatives is nullified, the forces are not forgotten. 17921 ! This part may be thought of as being based on two (Råback's) conjectures: 17922 ! in the first place the Lagrange variable formulation should bring us to a symmetric 17923 ! coefficient matrix and the values of Lagrange variables can be estimated as nodal 17924 ! reactions obtained by performing a matrix-vector product. 17925 ! 17926 ! Note that no attempt is currently made to transfer external moment 17927 ! loads of the shell model to loads of the coupled model. Likewise 17928 ! rotational inertia terms of the shell model are not transformed 17929 ! to inertia terms of the coupled model. Neglecting the rotational 17930 ! inertia might be acceptable in many cases. 17931 ! 17932 ! Note that the minus sign of the entries is correct here: 17933 DO k=A_f % Rows(kf),A_f % Rows(kf+1)-1 17934 CALL AddToMatrixElement(A_sf,ks,A_f % Cols(k),-weight*val*A_f0(k)) 17935 END DO 17936 END DO 17937 END DO 17938 END IF 17939 17940 ! This should sum up to unity! 17941 CALL AddToMatrixElement(A_f,kf,kf,weight) 17942 END DO 17943 END DO 17944 END DO 17945 DEALLOCATE( Basis, dBasisdx, Nodes % x, Nodes % y, Nodes % z ) 17946 DEALLOCATE(A_f0, NodeHits, InterfacePerm, InterfaceElems) 17947 IF (DrillingDOFs) THEN 17948 DEALLOCATE(rhs0) 17949 IF (DoMass) DEALLOCATE(Mass0) 17950 END IF 17951 17952 END BLOCK 17953 END IF 17954 17955 ! Note: we may have to recheck this coupling if visiting for 2nd time! 17956 ! 17957 ! Three DOFs for both shells and solids are the real Cartesian components of 17958 ! the displacement. Hence we can deal with the common parts of solid-solid and 17959 ! solid-shell coupling in same subroutine. 17960 ! 17961 IF( IsSolid .OR. IsShell ) THEN 17962 ncount = 0 17963 DO i=1,Mesh % NumberOfNodes 17964 jf = FPerm(i) 17965 js = SPerm(i) 17966 17967 ! We set coupling at nodes that belong to both equations. 17968 IF( jf == 0 .OR. js == 0 ) CYCLE 17969 ncount = ncount + 1 17970 17971 ! For the given node go through all displacement components. 17972 DO j = 1, dim 17973 ! Indices for matrix rows 17974 kf = fdofs*(jf-1)+j 17975 ks = sdofs*(js-1)+j 17976 17977 ! This is the original diagonal entry of the stiffness matrix. 17978 ! Let's keep it so that Dirichlet conditions are ideally set. 17979 vdiag = A_f % Values( A_f % Diag(kf) ) 17980 17981 ! Copy the force from rhs from "F" to "S" and zero it 17982 A_s % rhs(ks) = A_s % rhs(ks) + A_f % rhs(kf) 17983 A_f % rhs(kf) = 0.0_dp 17984 17985 ! Copy the force in implicit form from "F" to "SF" coupling matrix, and zero it. 17986 ! Now the solid equation includes forces of both equations. 17987 DO k=A_f % Rows(kf),A_f % Rows(kf+1)-1 17988 IF( .NOT. ConstrainedS(ks) ) THEN 17989 CALL AddToMatrixElement(A_sf,ks,A_f % Cols(k), A_f % Values(k) ) 17990 END IF 17991 A_f % Values(k) = 0.0_dp 17992 17993 ! We zero the mass associated to the Dirichlet conditions since 17994 ! otherwise the inertia will affect the condition. 17995 ! We use mass lumping since not all dofs of shell are present in the solid. 17996 IF( DoMass ) THEN 17997 A_s % MassValues(A_s % Diag(ks)) = A_s % MassValues(A_s % Diag(ks)) + A_f % MassValues(k) 17998 A_f % MassValues(k) = 0.0_dp 17999 END IF 18000 IF( DoDamp) THEN 18001 A_f % DampValues(k) = 0.0_dp 18002 END IF 18003 END DO 18004 18005 ! Set Dirichlet Condition to "F" such that it is equal to "S". 18006 ! Basically we could eliminate displacement condition and do this afterwards 18007 ! but this is much more economical. 18008 A_f % Values( A_f % Diag(kf)) = vdiag 18009 CALL AddToMatrixElement(A_fs,kf,ks, -vdiag ) 18010 18011 END DO 18012 END DO 18013 ELSE 18014 CALL Fatal(Caller,'Coupling type not implemented yet!') 18015 END IF 18016 18017 18018 IF( A_fs % FORMAT == MATRIX_LIST ) THEN 18019 CALL List_toCRSMatrix(A_fs) 18020 CALL List_toCRSMatrix(A_sf) 18021 END IF 18022 18023 !PRINT *,'interface fs sum:',SUM(A_fs % Values), SUM( ABS( A_fs % Values ) ) 18024 !PRINT *,'interface sf sum:',SUM(A_sf % Values), SUM( ABS( A_sf % Values ) ) 18025 18026 CALL Info(Caller,'Number of nodes on interface: '& 18027 //TRIM(I2S(ncount)),Level=10) 18028 CALL Info(Caller,'Number of entries in slave-master coupling matrix: '& 18029 //TRIM(I2S(SIZE(A_fs % Values))),Level=10) 18030 CALL Info(Caller,'Number of entries in master-slave coupling matrix: '& 18031 //TRIM(I2S(SIZE(A_sf % Values))),Level=10) 18032 18033 CALL Info(Caller,'All done',Level=20) 18034 18035 CONTAINS 18036 18037 18038 ! This routine determines normals of the solid at the common nodes with shell solver. 18039 ! The normals are determined by summing up potential outer normals and thereafter 18040 ! subtracting projections to the shell normals. 18041 !------------------------------------------------------------------------------------ 18042 SUBROUTINE DetermineCouplingNormals() 18043 INTEGER, ALLOCATABLE :: CouplingPerm(:) 18044 REAL(KIND=dp), ALLOCATABLE, TARGET :: CouplingNormals(:,:) 18045 REAL(KIND=dp), POINTER :: WallNormal(:) 18046 REAL(KIND=dp) :: Normal(3), sNormal 18047 INTEGER :: CouplingNodes, n, t, nbulk, nbound 18048 TYPE(Element_t), POINTER :: Element, Parent1, Parent2 18049 TYPE(Nodes_t), SAVE :: Nodes 18050 LOGICAL :: Solid1,Solid2 18051 18052 18053 ! allocate elemental stuff 18054 n = Mesh % MaxElementNodes 18055 IF ( .NOT. ASSOCIATED( Nodes % x ) ) THEN 18056 ALLOCATE( Nodes % x(n), Nodes % y(n),Nodes % z(n) ) 18057 END IF 18058 18059 ! Generate the permutation for the common nodes 18060 n = Mesh % NumberOfNodes 18061 ALLOCATE(CouplingPerm(n)) 18062 WHERE( FVar % Perm(1:n) > 0 .AND. SVar % Perm(1:n) > 0 ) 18063 CouplingPerm = 1 18064 ELSE WHERE 18065 CouplingPerm = 0 18066 END WHERE 18067 j = 0 18068 DO i=1,n 18069 IF( CouplingPerm(i) > 0 ) THEN 18070 j = j + 1 18071 CouplingPerm(i) = j 18072 END IF 18073 END DO 18074 CouplingNodes = j 18075 PRINT *,'number of common nodes:',j 18076 18077 ALLOCATE( CouplingNormals(j,3) ) 18078 CouplingNormals = 0.0_dp 18079 18080 nbulk = Mesh % NumberOfBulkElements 18081 nbound = Mesh % NumberOfBoundaryElements 18082 18083 ! Sum up all the wall normals associated to coupling nodes together 18084 DO t=nbulk+1, nbulk+nbound 18085 Element => Mesh % Elements(t) 18086 18087 ! If there a node for which we need normal? 18088 IF( COUNT( CouplingPerm( Element % NodeIndexes ) > 0 ) < 2 ) CYCLE 18089 18090 IF( ANY( SVar % Perm( Element % NodeIndexes ) == 0 ) ) CYCLE 18091 18092 ! This needs to be an element where normal can be defined 18093 !IF( GetElementDim(Element) /= 2 ) CYCLE 18094 IF( Element % TYPE % ElementCode > 500 ) CYCLE 18095 IF( Element % TYPE % ElementCode < 300 ) CYCLE 18096 18097 IF( .NOT. ASSOCIATED( Element % BoundaryInfo ) ) CYCLE 18098 18099 n = Element % TYPE % NumberOfNodes 18100 18101 !CALL GetElementNodes(Nodes,Element) 18102 Nodes % x(1:n) = Mesh % Nodes % x(Element % NodeIndexes) 18103 Nodes % y(1:n) = Mesh % Nodes % y(Element % NodeIndexes) 18104 Nodes % z(1:n) = Mesh % Nodes % z(Element % NodeIndexes) 18105 18106 ! Determine whether parents also are active on the solid 18107 Solid1 = .FALSE. 18108 Parent1 => Element % BoundaryInfo % Left 18109 IF( ASSOCIATED( Parent1 ) ) THEN 18110 Solid1 = ALL( SVar % Perm( Parent1 % NodeIndexes ) > 0 ) 18111 END IF 18112 18113 Solid2 = .FALSE. 18114 Parent2 => Element % BoundaryInfo % Right 18115 IF( ASSOCIATED( Parent2 ) ) THEN 18116 Solid2 = ALL( SVar % Perm( Parent2 % NodeIndexes ) > 0 ) 18117 END IF 18118 18119 ! Only consider external walls with just either parent in solid 18120 IF( .NOT. XOR( Solid1, Solid2 ) ) CYCLE 18121 18122 ! Check that the normal points outward of the solid 18123 IF( Solid1 ) THEN 18124 Normal = NormalVector(Element,Nodes,Parent=Parent1) 18125 ELSE 18126 Normal = NormalVector(Element,Nodes,Parent=Parent2) 18127 END IF 18128 18129 n = Element % TYPE % NumberOfNodes 18130 DO i=1,n 18131 j = CouplingPerm( Element % NodeIndexes(i) ) 18132 IF( j == 0 ) CYCLE 18133 18134 ! Note that we assume that normals are consistent in a way that they can be summed up 18135 ! and do not cancel each other 18136 WallNormal => CouplingNormals(j,:) 18137 WallNormal = WallNormal + Normal 18138 END DO 18139 END DO 18140 18141 ! Remove the shell normal from the wall normal 18142 DO t=1, nbulk+nbound 18143 Element => Mesh % Elements(t) 18144 18145 ! If there a node for which we need normal? 18146 IF( COUNT( CouplingPerm( Element % NodeIndexes ) > 0 ) < 2 ) CYCLE 18147 18148 ! Shell must be active for all nodes 18149 IF( ANY( FVar % Perm( Element % NodeIndexes ) == 0 ) ) CYCLE 18150 18151 ! This needs to be an element where shell can be solved 18152 !IF( GetElementDim(Element) /= 2 ) CYCLE 18153 IF( Element % TYPE % ElementCode > 500 ) CYCLE 18154 IF( Element % TYPE % ElementCode < 300 ) CYCLE 18155 18156 n = Element % TYPE % NumberOfNodes 18157 18158 !CALL GetElementNodes(Nodes,Element) 18159 Nodes % x(1:n) = Mesh % Nodes % x(Element % NodeIndexes) 18160 Nodes % y(1:n) = Mesh % Nodes % y(Element % NodeIndexes) 18161 Nodes % z(1:n) = Mesh % Nodes % z(Element % NodeIndexes) 18162 18163 ! Normal vector for shell, no need check the sign 18164 Normal = NormalVector(Element,Nodes) 18165 18166 DO i=1,n 18167 j = CouplingPerm( Element % NodeIndexes(i) ) 18168 IF( j == 0 ) CYCLE 18169 WallNormal => CouplingNormals(j,:) 18170 WallNormal = WallNormal - SUM( WallNormal * Normal ) * Normal 18171 END DO 18172 END DO 18173 18174 ! Finally normalize the normals such that their length is one 18175 j = 0 18176 DO i=1,CouplingNodes 18177 WallNormal => CouplingNormals(i,:) 18178 sNormal = SQRT( SUM( WallNormal**2) ) 18179 IF( sNormal > 1.0d-3 ) THEN 18180 WallNormal = WallNormal / sNormal 18181 PRINT *,'WallNormal:',WallNormal 18182 ELSE 18183 j = j + 1 18184 END IF 18185 END DO 18186 18187 IF( j > 0 ) THEN 18188 CALL Fatal('DetermineCouplingNormals','Could not define normals count: '//TRIM(I2S(j))) 18189 END IF 18190 18191 18192 END SUBROUTINE DetermineCouplingNormals 18193 18194 18195 END SUBROUTINE StructureCouplingAssembly 18196 18197 18198!--------------------------------------------------------------------------------- 18199!> Multiply a linear system by a constant or a given scalar field. 18200! 18201!> There are three multiplication modes: 18202!> 1) Multiply matrix or rhs with a constant factor 18203!> 2) Multiply matrix or rhs with a constant factor but only blockwise 18204!> 3) Multiply matrix or rhs with a vector retrieved by a field variable 18205! 18206!> And also three things to multiply: 18207!> a) The right-hand-side of the linear system 18208!> b) The matrix part of the linear system 18209!> c) The diagonal entries of the matrix 18210! 18211!> Possible uses of the routine include cases where the user wants to introduce diagonal 18212!> implicit relaxation to the linear system, or to eliminate some coupling terms in 18213!> monolithic systems that make the solution of the linear problems more difficult. 18214!---------------------------------------------------------------------------------- 18215 SUBROUTINE LinearSystemMultiply( Solver ) 18216!---------------------------------------------------------------------------------- 18217 TYPE(Solver_t) :: Solver 18218 !------------------------------------------------------------------------------ 18219 INTEGER, POINTER :: Perm(:),Rows(:),Cols(:) 18220 REAL(KIND=dp), POINTER :: Values(:),Rhs(:) 18221 TYPE(Variable_t), POINTER :: ThisVar,CoeffVar 18222 TYPE(Matrix_t), POINTER :: A 18223 TYPE(Mesh_t), POINTER :: Mesh 18224 REAL(KIND=dp) :: Coeff,Coeff2 18225 INTEGER :: i,j,j2,k,l,jk,n,Mode,Dofs 18226 LOGICAL :: Found, UpdateRhs, Symmetric 18227 TYPE(ValueList_t), POINTER :: Params 18228 CHARACTER(LEN=MAX_NAME_LEN) :: str, VarName 18229 18230 Params => Solver % Values 18231 Mesh => Solver % Mesh 18232 IF(.NOT. ASSOCIATED( Mesh ) ) THEN 18233 CALL Fatal('LinearSystemMultiply','Subroutine requires a Mesh!') 18234 END IF 18235 A => Solver % Matrix 18236 IF(.NOT. ASSOCIATED( A ) ) THEN 18237 CALL Fatal('LinearSystemMultiply','Subroutine requires a matrix equation!') 18238 END IF 18239 ThisVar => Solver % Variable 18240 IF(.NOT. ASSOCIATED( ThisVar ) ) THEN 18241 CALL Fatal('LinearSystemMultiply','Subroutine requires a default variable to exist!') 18242 END IF 18243 18244 Perm => ThisVar % Perm 18245 Dofs = ThisVar % Dofs 18246 n = A % NumberOfRows 18247 Cols => A % Cols 18248 Rows => A % Rows 18249 Rhs => A % Rhs 18250 Values => A % Values 18251 18252 UpdateRhs = ListGetLogical( Params,'Linear System Multiply Consistent',Found) 18253 Symmetric = ListGetLogical( Params,'Linear System Multiply Symmetric',Found) 18254 18255 ! First, Multiply the k:th piece of the r.h.s. vector if requested 18256 !----------------------------------------------------------- 18257 DO k=1,Dofs 18258 Mode = 0 18259 18260 WRITE( str,'(A)') 'Linear System Rhs Factor' 18261 Coeff = ListGetCReal( Params, str, Found ) 18262 IF( Found ) THEN 18263 Mode = 1 18264 WRITE( Message,'(A,ES12.3)') 'Multiplying the rhs with ',Coeff 18265 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18266 ELSE 18267 WRITE( str,'(A,I0)') TRIM(str)//' ',k 18268 Coeff = ListGetCReal( Params, str, Found ) 18269 IF( Found ) THEN 18270 Mode = 2 18271 WRITE( Message,'(A,I0,A,ES12.3)') 'Multiplying component ',k,' of the rhs with ',Coeff 18272 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18273 END IF 18274 END IF 18275 IF( Mode == 0 ) THEN 18276 str = 'Linear System Rhs Variable' 18277 VarName = ListGetString( Params,str,Found ) 18278 NULLIFY( CoeffVar ) 18279 IF( Found ) THEN 18280 CoeffVar => VariableGet( Mesh % Variables, VarName ) 18281 ELSE 18282 WRITE( str,'(A,I0)') TRIM(str)//' ',k 18283 VarName = ListGetString( Params,str,Found ) 18284 IF( Found ) CoeffVar => VariableGet( Mesh % Variables, VarName ) 18285 END IF 18286 IF( ASSOCIATED( CoeffVar ) ) THEN 18287 IF( ANY( CoeffVar % Perm /= Perm ) ) THEN 18288 CALL Fatal('LinearSystemMultiply','Permutations should be the same') 18289 END IF 18290 Mode = 3 18291 WRITE( Message,'(A,I0,A)') 'Multiplying component ',k,' of the rhs with > '//TRIM(VarName)//' <' 18292 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18293 18294 !PRINT *,'Range:',Mode,MINVAL(CoeffVar % Values),MAXVAL(CoeffVar % Values) 18295 END IF 18296 END IF 18297 IF( Mode == 0 ) CYCLE 18298 18299 IF( Mode == 1 ) THEN 18300 IF( ABS( Coeff - 1.0_dp ) > EPSILON( Coeff ) ) THEN 18301 Rhs = Coeff * Rhs 18302 END IF 18303 EXIT 18304 ELSE 18305 DO j=1,SIZE( Perm ) 18306 jk = Dofs*(j-1)+k 18307 IF( Mode == 3 ) Coeff = CoeffVar % Values(j) 18308 Rhs( jk ) = Coeff * Rhs( jk ) 18309 END DO 18310 END IF 18311 END DO 18312 ! End of r.h.s. multiplication 18313 18314 ! Secondly, Multiply the kl block of the matrix 18315 !------------------------------------------------ 18316 DO k=1,Dofs 18317 DO l=1,Dofs 18318 Mode = 0 18319 str = 'Linear System Matrix Factor' 18320 Coeff = ListGetCReal( Params, str, Found ) 18321 IF( Found ) THEN 18322 Mode = 1 18323 WRITE( Message,'(A,ES12.3)') 'Multiplying the matrix with ',Coeff 18324 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18325 ELSE 18326 WRITE( str,'(A,I0,I0)') TRIM(str)//' ',k,l 18327 Coeff = ListGetCReal( Params, str, Found ) 18328 IF( Found ) THEN 18329 Mode = 2 18330 WRITE( Message,'(A,I0,I0,A,ES12.3)') 'Multiplying block (',k,l,') of the matrix with ',Coeff 18331 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18332 END IF 18333 END IF 18334 IF( Mode == 0 ) THEN 18335 str = 'Linear System Matrix Variable' 18336 VarName = ListGetString( Params,str,Found ) 18337 NULLIFY( CoeffVar ) 18338 IF( Found ) THEN 18339 CoeffVar => VariableGet( Mesh % Variables, str ) 18340 ELSE 18341 WRITE( str,'(A,I0,I0)') TRIM(str)//' ',k,l 18342 VarName = ListGetString( Params,str,Found ) 18343 IF( Found ) CoeffVar => VariableGet( Mesh % Variables, VarName ) 18344 END IF 18345 IF( ASSOCIATED( CoeffVar ) ) THEN 18346 IF( ANY( CoeffVar % Perm /= Perm ) ) THEN 18347 CALL Fatal('LinearSystemMultiply','Permutations should be the same') 18348 END IF 18349 Mode = 3 18350 WRITE( Message,'(A,I0,I0,A)') 'Multiplying block (',k,l,') of the matrix with > '//TRIM(VarName)//' <' 18351 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18352 END IF 18353 END IF 18354 18355 IF( Mode == 0 ) CYCLE 18356 18357 IF( Mode == 1 ) THEN 18358 IF( ABS( Coeff - 1.0_dp ) > EPSILON( Coeff ) ) THEN 18359 Values = Coeff * Values 18360 END IF 18361 ELSE 18362 DO j=1,SIZE( Perm ) 18363 jk = Dofs*(j-1)+k 18364 IF( Mode == 3 ) Coeff = CoeffVar % Values(j) 18365 DO i=Rows(jk),Rows(jk+1)-1 18366 IF( MODULO( Cols(i), Dofs ) == MODULO( l, Dofs ) ) THEN 18367 IF( Mode == 3 .AND. Symmetric ) THEN 18368 j2 = (Cols(i)-1)/Dofs + 1 18369 Coeff2 = CoeffVar % Values(j2) 18370 Values( i ) = SQRT( Coeff * Coeff2 ) * Values( i ) 18371 ELSE 18372 Values( i ) = Coeff * Values( i ) 18373 END IF 18374 END IF 18375 END DO 18376 END DO 18377 END IF 18378 END DO 18379 IF( Mode == 1 ) EXIT 18380 END DO 18381 ! end of matrix multiplication 18382 18383 18384 ! Finally, Multiply the diagonal of the matrix 18385 !------------------------------------------------ 18386 DO k=1,Dofs 18387 Mode = 0 18388 18389 str = 'Linear System Diagonal Factor' 18390 Coeff = ListGetCReal( Params, str, Found ) 18391 IF( Found ) THEN 18392 Mode = 1 18393 WRITE( Message,'(A,ES12.3)') 'Multiplying the diagonal with ',Coeff 18394 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18395 ELSE 18396 WRITE( str,'(A,I0)') TRIM(str)//' ',k 18397 Coeff = ListGetCReal( Params, str, Found ) 18398 IF( Found ) THEN 18399 Mode = 2 18400 WRITE( Message,'(A,I0,A,ES12.3)') 'Multiplying component ',k,' of the matrix diagonal with ',Coeff 18401 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18402 END IF 18403 END IF 18404 18405 IF( Mode == 0 ) THEN 18406 str = 'Linear System Diagonal Variable' 18407 VarName = ListGetString( Params,str,Found ) 18408 NULLIFY( CoeffVar ) 18409 IF( Found ) THEN 18410 CoeffVar => VariableGet( Mesh % Variables, VarName ) 18411 ELSE 18412 WRITE( str,'(A,I0)') TRIM(str)//' ',k 18413 VarName = ListGetString( Params,str,Found ) 18414 IF( Found ) CoeffVar => VariableGet( Mesh % Variables, VarName ) 18415 END IF 18416 IF( ASSOCIATED( CoeffVar ) ) THEN 18417 IF( ANY( CoeffVar % Perm /= Perm ) ) THEN 18418 CALL Fatal('LinearSystemMultiply','Permutations should be the same') 18419 END IF 18420 Mode = 3 18421 WRITE( Message,'(A,I0,A)') 'Multiplying component ',k,' of the diagonal with > '//TRIM(VarName)//' <' 18422 CALL Info('LinearSystemMultiply',Message, Level=6 ) 18423 END IF 18424 END IF 18425 18426 IF( Mode == 0 ) CYCLE 18427 18428 IF( Mode == 1 ) THEN 18429 IF( ABS( Coeff - 1.0_dp ) > EPSILON( Coeff ) ) THEN 18430 IF( UpdateRhs ) Rhs = Rhs + ( Coeff - 1 ) * Values( A % Diag ) * ThisVar % Values 18431 Values( A % Diag ) = Coeff * Values( A % Diag ) 18432 END IF 18433 EXIT 18434 ELSE 18435 DO j=1,SIZE( Perm ) 18436 jk = Dofs*(j-1)+k 18437 IF( Mode == 3 ) Coeff = CoeffVar % Values(j) 18438 18439 IF( UpdateRhs ) Rhs( jk ) = Rhs( jk ) + (Coeff - 1) * Values(A % Diag(jk)) * ThisVar % Values(jk) 18440 Values( A % Diag(jk) ) = Coeff * Values( A % Diag(jk) ) 18441 END DO 18442 END IF 18443 END DO 18444 ! end of diagonal multiplication 18445 18446 18447 END SUBROUTINE LinearSystemMultiply 18448 18449 18450 18451 18452 18453 18454!--------------------------------------------------------------------------------- 18455!> Set the diagonal entry to given minimum. 18456!---------------------------------------------------------------------------------- 18457 SUBROUTINE LinearSystemMinDiagonal( Solver ) 18458!---------------------------------------------------------------------------------- 18459 TYPE(Solver_t) :: Solver 18460 !------------------------------------------------------------------------------ 18461 INTEGER, POINTER :: Perm(:),Rows(:),Cols(:) 18462 REAL(KIND=dp), POINTER :: Values(:),Rhs(:) 18463 TYPE(Variable_t), POINTER :: ThisVar 18464 TYPE(Matrix_t), POINTER :: A 18465 TYPE(Mesh_t), POINTER :: Mesh 18466 REAL(KIND=dp) :: Coeff 18467 INTEGER :: i,j,j2,k,l,jk,n,Mode,Dofs 18468 LOGICAL :: Found, UpdateRhs, Symmetric 18469 TYPE(ValueList_t), POINTER :: Params 18470 CHARACTER(LEN=MAX_NAME_LEN) :: str 18471 INTEGER :: NoSet 18472 REAL(KIND=dp) :: DiagSum, val, DiagMax 18473 18474 Params => Solver % Values 18475 Mesh => Solver % Mesh 18476 IF(.NOT. ASSOCIATED( Mesh ) ) THEN 18477 CALL Fatal('LinearSystemMinDiagonal','Subroutine requires a Mesh!') 18478 END IF 18479 A => Solver % Matrix 18480 IF(.NOT. ASSOCIATED( A ) ) THEN 18481 CALL Fatal('LinearSystemMinDiagonal','Subroutine requires a matrix equation!') 18482 END IF 18483 ThisVar => Solver % Variable 18484 IF(.NOT. ASSOCIATED( ThisVar ) ) THEN 18485 CALL Fatal('LinearSystemMinDiagonal','Subroutine requires a default variable to exist!') 18486 END IF 18487 18488 Perm => ThisVar % Perm 18489 Dofs = ThisVar % Dofs 18490 n = A % NumberOfRows 18491 Cols => A % Cols 18492 Rows => A % Rows 18493 Rhs => A % Rhs 18494 Values => A % Values 18495 18496 ! Set the minimum value for each component, only nodel dofs considered 18497 !--------------------------------------------------------------------- 18498 NoSet = 0 18499 DiagMax = 0.0_dp 18500 DiagSum = 0.0_dp 18501 n = MAXVAL( Perm ( 1:Mesh % NumberOfNodes ) ) 18502 18503 DO k=1,Dofs 18504 Mode = 0 18505 18506 str = 'Linear System Diagonal Min' 18507 Coeff = ListGetCReal( Params, str, Found ) 18508 IF( Found ) THEN 18509 Mode = 1 18510 WRITE( Message,'(A,ES12.3)') 'Setting minimum of the diagonal to ',Coeff 18511 CALL Info('LinearSystemMinDiagonal',Message, Level=6 ) 18512 ELSE 18513 WRITE( str,'(A,I0)') TRIM(str)//' ',k 18514 Coeff = ListGetCReal( Params, str, Found ) 18515 IF( Found ) THEN 18516 Mode = 2 18517 WRITE( Message,'(A,I0,A,ES12.3)') 'Setting minimum of diagonal component ',k,' to ',Coeff 18518 CALL Info('LinearSystemMinDiagonal',Message, Level=6 ) 18519 END IF 18520 END IF 18521 18522 IF( Mode == 0 ) CYCLE 18523 18524 DO j=1,n 18525 jk = Dofs*(j-1)+k 18526 l = A % Diag(jk) 18527 IF( l == 0 ) CYCLE 18528 18529 ! Only add the diagonal to the owned dof 18530 IF( ParEnv % PEs > 1 ) THEN 18531 IF( A % ParallelInfo % NeighbourList(j) % Neighbours(1) /= ParEnv % MyPE ) CYCLE 18532 END IF 18533 18534 val = ABS( Values( l ) ) 18535 DiagSum = DiagSum + val 18536 DiagMax = MAX( DiagMax, val ) 18537 IF( val < Coeff ) THEN 18538 Values( A % Diag(jk) ) = Coeff 18539 NoSet = NoSet + 1 18540 END IF 18541 END DO 18542 END DO 18543 18544 CALL Info('LinearSystemMinDiagonal',& 18545 'Number of diagonal values set to minimum: '//TRIM(I2S(NoSet)),Level=5) 18546 WRITE( Message,'(A,ES12.3)') 'Average abs(diagonal) entry: ',DiagSum / n 18547 CALL Info('LinearSystemMinDiagonal',Message, Level=6 ) 18548 18549 WRITE( Message,'(A,ES12.3)') 'Maximum abs(diagonal) entry: ',DiagMax 18550 CALL Info('LinearSystemMinDiagonal',Message, Level=6 ) 18551 18552 18553 END SUBROUTINE LinearSystemMinDiagonal 18554 18555 18556 18557 18558 18559 !---------------------------------------------------------------------- 18560 !> Make the high-order flux corrected transport (FCT) correction after 18561 !> the low order approximation has been solved. 18562 ! 18563 !> For more information see, for example, 18564 !> Dmitri Kuzmin (2008): "Explicit and implicit FEM-FCT algorithms with flux linearization" 18565 !---------------------------------------------------------------------- 18566 SUBROUTINE FCT_Correction( Solver ) 18567 18568 TYPE(Solver_t), POINTER :: Solver 18569 18570 TYPE(Valuelist_t), POINTER :: Params 18571 TYPE(Mesh_t), POINTER :: Mesh 18572 INTEGER :: n,i,j,k,k2 18573 INTEGER, POINTER :: Rows(:),Cols(:),Perm(:) 18574 TYPE(Matrix_t), POINTER :: A 18575 REAL(KIND=dp), POINTER :: BulkValues(:),u(:),M_L(:),udot(:), & 18576 pp(:),pm(:),qp(:),qm(:),corr(:),ku(:),ulow(:) 18577 REAL(KIND=dp), ALLOCATABLE :: mc_udot(:), fct_u(:) 18578 REAL(KIND=dp), POINTER CONTIG :: M_C(:), SaveValues(:) 18579 REAL(KIND=dp) :: rsum, Norm,m_ij,k_ij,du,d_ij,f_ij,c_ij,Ceps,CorrCoeff,& 18580 rmi,rmj,rpi,rpj,dt 18581 TYPE(Variable_t), POINTER :: Var, Variables 18582 LOGICAL :: Found, Symmetric, SaveFields, SkipCorrection 18583 CHARACTER(LEN=MAX_NAME_LEN) :: VarName, TmpVarName 18584 18585 REAL(KIND=dp), POINTER :: mmc(:), mmc_h(:), fct_d(:) 18586 TYPE(Element_t), POINTER :: Element 18587 LOGICAL, ALLOCATABLE :: ActiveNodes(:) 18588 18589 Params => Solver % Values 18590 18591 SkipCorrection = ListGetLogical( Params,'FCT Correction Skip',Found ) 18592 Symmetric = ListGetLogical( Params,'FCT Correction Symmetric',Found ) 18593 SaveFields = ListGetLogical( Params,'FCT Correction Save',Found ) 18594 18595 IF( SkipCorrection .AND. .NOT. SaveFields ) THEN 18596 CALL Info('FCT_Correction','Skipping the computation of FCT correction',Level=5) 18597 END IF 18598 18599 CALL Info('FCT_Correction','Computing corrector for the low order solution',Level=5) 18600 18601 ! PRINT *,'FCT Norm Before Correction:',SQRT( SUM( Solver % Variable % Values**2) ) 18602 18603 Mesh => Solver % Mesh 18604 Variables => Solver % Mesh % Variables 18605 18606 ! Set pointers 18607 A => Solver % Matrix 18608 n = A % NumberOfRows 18609 Rows => A % Rows 18610 Cols => A % Cols 18611 18612 BulkValues => A % BulkValues 18613 M_C => A % MassValues 18614 Perm => Solver % Variable % Perm 18615 18616 M_L => A % MassValuesLumped 18617 IF (ParEnv % PEs>1) CALL ParallelSumVector(A,M_L) 18618 18619 Var => VariableGet( Variables,'timestep size') 18620 dt = Var % Values(1) 18621 18622 ! low order solution at the start, high order in the end 18623 u => Solver % Variable % Values 18624 VarName = GetVarName(Solver % Variable) 18625 18626 ! Here a bunch of vectors are stored for visualization and debugging purposes 18627 !---------------------------------------------------------------------------- 18628 18629 ! low order solution is the solution without corrections 18630 ! This is created and saved only if requested 18631 !--------------------------------------------------------------------------- 18632 IF( SaveFields ) THEN 18633 TmpVarName = TRIM( VarName )//' fctlow' 18634 Var => VariableGet( Variables, TmpVarName ) 18635 IF( .NOT. ASSOCIATED(Var) ) THEN 18636 CALL VariableAddVector( Variables, Mesh, Solver,& 18637 TmpVarName, Perm = Perm, Output = SaveFields ) 18638 Var => VariableGet( Variables, TmpVarName ) 18639 END IF 18640 ulow => Var % Values 18641 ulow = u 18642 END IF 18643 18644 ! Create auxiliary vectors for the fct algorithm 18645 !--------------------------------------------------------------------------- 18646 18647 ! r.h.s. term 18648 TmpVarName = TRIM( VarName )//' fctku' 18649 Var => VariableGet( Variables, TmpVarName ) 18650 IF( .NOT. ASSOCIATED(Var) ) THEN 18651 CALL VariableAddVector( Variables, Mesh, Solver,& 18652 TmpVarName, Perm = Perm, Output = SaveFields ) 18653 Var => VariableGet( Variables, TmpVarName ) 18654 END IF 18655 ku => Var % Values 18656 18657 ! time derivative from lower order analysis 18658 TmpVarName = TRIM( VarName )//' fctudot' 18659 Var => VariableGet( Variables, TmpVarName ) 18660 IF( .NOT. ASSOCIATED(Var) ) THEN 18661 CALL VariableAddVector( Variables, Mesh, Solver,& 18662 TmpVarName, Perm = Perm, Output = SaveFields ) 18663 Var => VariableGet( Variables, TmpVarName ) 18664 END IF 18665 udot => Var % Values 18666 18667 ! Fields related to flux limiters 18668 TmpVarName = TRIM( VarName )//' fctpp' 18669 Var => VariableGet( Variables, TmpVarName ) 18670 IF( .NOT. ASSOCIATED(Var) ) THEN 18671 CALL VariableAddVector( Variables, Mesh, Solver,& 18672 TmpVarName, Perm = Perm, Output = SaveFields ) 18673 Var => VariableGet( Variables, TmpVarName ) 18674 END IF 18675 pp => Var % Values 18676 18677 TmpVarName = TRIM( VarName )//' fctpm' 18678 Var => VariableGet( Variables, TmpVarName ) 18679 IF( .NOT. ASSOCIATED(Var) ) THEN 18680 CALL VariableAddVector( Variables, Mesh, Solver,& 18681 TmpVarName, Perm = Perm, Output = SaveFields ) 18682 Var => VariableGet( Variables, TmpVarName ) 18683 END IF 18684 pm => Var % Values 18685 18686 TmpVarName = TRIM( VarName )//' fctqp' 18687 Var => VariableGet( Variables, TmpVarName ) 18688 IF( .NOT. ASSOCIATED(Var) ) THEN 18689 CALL VariableAddVector( Variables, Mesh, Solver,& 18690 TmpVarName, Perm = Perm, Output = SaveFields ) 18691 Var => VariableGet( Variables, TmpVarName ) 18692 END IF 18693 qp => Var % Values 18694 18695 TmpVarName = TRIM( VarName )//' fctqm' 18696 Var => VariableGet( Variables, TmpVarName ) 18697 IF( .NOT. ASSOCIATED(Var) ) THEN 18698 CALL VariableAddVector( Variables, Mesh, Solver,& 18699 TmpVarName, Perm = Perm, Output = SaveFields ) 18700 Var => VariableGet( Variables, TmpVarName ) 18701 END IF 18702 qm => Var % Values 18703 18704 TmpVarName = TRIM( VarName )//' fctmm' 18705 Var => VariableGet( Variables, TmpVarName ) 18706 IF( .NOT. ASSOCIATED(Var) ) THEN 18707 CALL VariableAddVector( Variables, Mesh, Solver,& 18708 TmpVarName, Perm = Perm, Output = SaveFields ) 18709 Var => VariableGet( Variables, TmpVarName ) 18710 END IF 18711 Var % Values = M_L 18712 18713 ! higher order correction 18714 TmpVarName = TRIM( VarName )//' fctcorr' 18715 Var => VariableGet( Variables, TmpVarName ) 18716 IF( .NOT. ASSOCIATED(Var) ) THEN 18717 CALL VariableAddVector( Variables, Mesh, Solver,& 18718 TmpVarName, Perm = Perm, Output = SaveFields ) 18719 Var => VariableGet( Variables, TmpVarName ) 18720 END IF 18721 corr => Var % Values 18722 18723 18724 ! 1) Compute the nodal time derivatives 18725 ! M_C*udot=K*ulow (M_C is the consistent mass matrix) 18726 !---------------------------------------------------------------------- 18727 CALL Info('FCT_Correction','Compute nodal time derivatives',Level=10) 18728 ! Compute: ku = K*ulow 18729#if 0 18730 DO i=1,n 18731 rsum = 0.0_dp 18732 DO k=Rows(i),Rows(i+1)-1 18733 j = Cols(k) 18734 K_ij = BulkValues(k) 18735 rsum = rsum + K_ij * u(j) 18736 END DO 18737 ku(i) = rsum 18738 END DO 18739 ! Solve the linear system for udot 18740 ! The stiffness matrix is momentarily replaced by the consistent mass matrix M_C 18741 ! Also the namespace is replaced to 'fct:' so that different strategies may 18742 ! be applied to the mass matrix solution. 18743 CALL ListPushNameSpace('fct:') 18744 CALL ListAddLogical( Params,'fct: Skip Compute Nonlinear Change',.TRUE.) 18745 CALL ListAddLogical( Params,'fct: Skip Advance Nonlinear iter',.TRUE.) 18746 SaveValues => A % Values 18747 A % Values => M_C 18748 CALL SolveLinearSystem( A, ku, udot, Norm, 1, Solver ) 18749 A % Values => SaveValues 18750 CALL ListPopNamespace() 18751#else 18752 18753 BLOCK 18754 REAL(KIND=dp), ALLOCATABLE :: TmpRhsVec(:), TmpXVec(:) 18755 18756 SaveValues => A % Values 18757 18758 IF (Parenv % PEs>1) THEN 18759 ALLOCATE(TmpRHSVec(n), TmpXVec(n)) 18760 TmpxVec = 0._dp; tmpRHSVec = 0._dp 18761 18762 A % Values => BulkValues 18763 CALL ParallelInitSolve(A,TmpXVec,TmpRhsVec,u) 18764 CALL ParallelVector(A,TmpRhsvec,u) 18765 18766 CALL ParallelMatrixVector(A,TmpRhsvec,TmpXVec) 18767 18768 CALL PartitionVector(A,Ku,TmpXVec) 18769 DEALLOCATE(TmpRhsVec, TmpXVec) 18770 ELSE 18771 DO i=1,n 18772 rsum = 0._dp 18773 DO k=Rows(i),Rows(i+1)-1 18774 j = Cols(k) 18775 K_ij = BulkValues(k) 18776 rsum = rsum + K_ij * u(j) 18777 END DO 18778 ku(i) = rsum 18779 END DO 18780 END IF 18781 18782 CALL ListPushNameSpace('fct:') 18783 CALL ListAddLogical( Params,'fct: Skip Compute Nonlinear Change',.TRUE.) 18784 CALL ListAddLogical( Params,'fct: Skip Advance Nonlinear iter',.TRUE.) 18785 18786 A % Values => M_C 18787 udot = 0._dp 18788 CALL SolveLinearSystem(A,Ku,Udot,Norm,1,Solver) 18789 CALL ListPopNamespace() 18790 18791 A % Values => SaveValues 18792 END BLOCK 18793#endif 18794 18795 ! Computation of correction factors (Zalesak's limiter) 18796 ! Code derived initially from Kuzmin's subroutine 18797 !--------------------------------------------------------- 18798 CALL Info('FCT_Correction','Compute correction factors',Level=10) 18799 pp = 0 18800 pm = 0 18801 qp = 0 18802 qm = 0 18803 18804 IF(ParEnv % PEs>1) THEN 18805 fct_d => A % FCT_D 18806 mmc => A % MassValues 18807 mmc_h => A % HaloMassValues 18808 18809 ALLOCATE(ActiveNodes(n)); activeNodes=.FALSE. 18810 DO i=1,Solver % NumberOfActiveElements 18811 Element => Solver % Mesh % Elements(Solver % ActiveElements(i)) 18812 IF ( Element % PartIndex /= ParEnv % MyPE ) CYCLE 18813 Activenodes(Solver % Variable % Perm(Element % NodeIndexes)) = .TRUE. 18814 END DO 18815 ELSE 18816 fct_d => A % FCT_D 18817 mmc => A % MassValues 18818 END IF 18819 DO i=1,n 18820 IF (ParEnv % PEs > 1 ) THEN 18821 IF ( .NOT. ActiveNodes(i) ) CYCLE 18822 end if 18823 18824 DO k=Rows(i),Rows(i+1)-1 18825 j = Cols(k) 18826 18827 IF (ParEnv % PEs>1) THEN 18828 IF ( .NOT.ActiveNodes(j) ) CYCLE 18829 END IF 18830 18831 ! Compute the raw antidiffusive fluxes 18832 ! f_ij=m_ij*[udot(i)-udot(j)]+d_ij*[ulow(i)-ulow(j)] 18833 !----------------------------------------------------- 18834 ! d_ij and m_ij are both symmetric 18835 ! Hence F_ji = -F_ij 18836 18837 f_ij = mmc(k)*(udot(i)-udot(j)) + fct_d(k)*(u(i)-u(j)) 18838 IF ( ParEnv % PEs>1 ) f_ij=f_ij+mmc_h(k)*(udot(i)-udot(j)) 18839 ! Compared to Kuzmin's paper F_ij=-F_ij since d_ij and 18840 ! udot have different signs. 18841 f_ij = -f_ij 18842 18843 ! Antidiffusive fluxes to be limited 18844 du = u(j)-u(i) 18845 18846 ! Prelimiting of antidiffusive fluxes i.e. du and the flux have different signs 18847 IF (f_ij*du >= TINY(du)) THEN 18848 f_ij = 0._dp 18849 ELSE 18850 ! Positive/negative edge contributions 18851 pp(i) = pp(i) + MAX(0._dp,f_ij) 18852 pm(i) = pm(i) + MIN(0._dp,f_ij) 18853 END IF 18854 18855 ! Maximum/minimum solution increments 18856 qp(i) = MAX(qp(i),du) 18857 qm(i) = MIN(qm(i),du) 18858 END DO 18859 END DO 18860 18861 ! Computation of nodal correction factors 18862 ! DO i=1,n 18863 ! IF( pp(i) > Ceps ) THEN 18864 ! rp(i) = MIN( 1.0_dp, M_L(i)*qp(i)/pp(i) ) 18865 ! END IF 18866 ! IF( pm(i) < -Ceps ) THEN 18867 ! rm(i) = MIN( 1.0_dp, M_L(i)*qm(i)/pm(i) ) 18868 ! END IF 18869 ! END DO 18870 18871 ! Correct the low-order solution 18872 ! (M_L*ufct)_i=(M_L*ulow)_i+dt*sum(alpha_ij*f_ij) 18873 !------------------------------------------------- 18874 ! Symmetric flux limiting 18875 ! Correction of the right-hand side 18876 18877 18878 ! IF (ParEnv % PEs>1) THEN 18879 ! CALL ParallelSumVector(A,pm) 18880 ! CALL ParallelSumVector(A,pp) 18881 ! CALL ParallelSumVector(A,qm) 18882 ! CALL ParallelSumVector(A,qp) 18883 ! END IF 18884 18885 CorrCoeff = ListGetCReal( Params,'FCT Correction Coefficient',Found ) 18886 IF( .NOT. Found ) CorrCoeff = 1._dp 18887 18888 Ceps = ListGetCReal( Params,'FCT Correction Epsilon',Found ) 18889 IF(.NOT. Found ) Ceps = EPSILON( Ceps ) 18890 corr = 0._dp 18891 DO i=1,n 18892 IF (ParEnv % PEs>1) THEN 18893 IF( .NOT. ActiveNodes(i)) CYCLE 18894 END IF 18895 18896 IF( pp(i) > Ceps ) THEN 18897 rpi = MIN( 1._dp, M_L(i)*qp(i)/pp(i) ) 18898 ELSE 18899 rpi = 0._dp 18900 END IF 18901 18902 IF( pm(i) < -Ceps ) THEN 18903 rmi = MIN( 1._dp, M_L(i)*qm(i)/pm(i) ) 18904 ELSE 18905 rmi = 0._dp 18906 END IF 18907 18908 DO k=Rows(i),Rows(i+1)-1 18909 j = Cols(k) 18910 IF(ParEnv % PEs>1) THEN 18911 IF(.NOT.ActiveNodes(j)) CYCLE 18912 END IF 18913 18914 f_ij = mmc(k)*(udot(i)-udot(j)) + fct_d(k)*(u(i)-u(j)) 18915 IF (ParEnv % PEs>1) f_ij = f_ij + mmc_h(k)*(udot(i)-udot(j)) 18916 f_ij = -f_ij 18917 18918 IF (f_ij > 0) THEN 18919 IF( pm(j) < -Ceps ) THEN 18920 rmj = MIN( 1.0_dp, M_L(j)*qm(j)/pm(j) ) 18921 ELSE 18922 rmj = 0._dp 18923 END IF 18924 c_ij = MIN(rpi,rmj) 18925 ELSE 18926 IF( pp(j) > Ceps ) THEN 18927 rpj = MIN( 1._dp, M_L(j)*qp(j)/pp(j) ) 18928 ELSE 18929 rpj = 0._dp 18930 END IF 18931 c_ij = MIN(rmi,rpj) 18932 END IF 18933 corr(i) = corr(i) + c_ij * f_ij 18934 END DO 18935 corr(i) = CorrCoeff * corr(i) / M_L(i) 18936 END DO 18937 18938 IF (ParEnv % PEs>1) THEN 18939! CALL ParallelSumVector(A,corr) 18940 DEALLOCATE(A % HaloValues, A % HaloMassValues) 18941 A % HaloValues => Null(); A % HaloMassValues => Null() 18942 END IF 18943 18944 ! Optionally skip applying the correction, just for debugging purposes 18945 IF( SkipCorrection ) THEN 18946 CALL Info('FCT_Correction','Skipping Applying corrector',Level=6) 18947 ELSE 18948 CALL Info('FCT_Correction','Applying corrector for the low order solution',Level=10) 18949 18950 u = u + corr 18951 18952 ! PRINT *,'FCT Norm After Correction:',SQRT( SUM( Solver % Variable % Values**2) ) 18953 END IF 18954 18955 END SUBROUTINE FCT_Correction 18956 18957 18958 18959 ! Create Linear constraints from mortar BCs: 18960 ! ------------------------------------------- 18961 SUBROUTINE GenerateProjectors(Model,Solver,Nonlinear,SteadyState) 18962 18963 TYPE(Model_t) :: Model 18964 TYPE(Solver_t) :: Solver 18965 LOGICAL, OPTIONAL :: Nonlinear, SteadyState 18966 18967 LOGICAL :: IsNonlinear,IsSteadyState,Timing, RequireNonlinear, ContactBC 18968 LOGICAL :: ApplyMortar, ApplyContact, Found 18969 INTEGER :: i,j,k,l,n,dsize,size0,col,row,dim 18970 TYPE(ValueList_t), POINTER :: BC 18971 TYPE(Matrix_t), POINTER :: CM, CMP, CM0, CM1 18972 TYPE(Variable_t), POINTER :: DispVar 18973 REAL(KIND=dp) :: t0,rt0,rst,st,ct 18974 CHARACTER(*), PARAMETER :: Caller = 'GenerateProjectors' 18975 18976 ApplyMortar = ListGetLogical(Solver % Values,'Apply Mortar BCs',Found) 18977 ApplyContact = ListGetLogical(Solver % Values,'Apply Contact BCs',Found) 18978 18979 IF( .NOT. ( ApplyMortar .OR. ApplyContact) ) RETURN 18980 18981 i = ListGetInteger( Solver % Values,'Mortar BC Master Solver',Found ) 18982 IF( Found ) THEN 18983 Solver % MortarBCs => CurrentModel % Solvers(i) % MortarBCs 18984 IF( .NOT. ASSOCIATED( Solver % MortarBCs ) ) THEN 18985 CALL Fatal(Caller,'Could not reuse projectors from solver: '//TRIM(I2S(i))) 18986 END IF 18987 CALL Info(Caller,'Reusing projectors from solver: '//TRIM(I2S(i)),Level=8) 18988 RETURN 18989 END IF 18990 18991 CALL Info(Caller,'Generating mortar projectors',Level=8) 18992 18993 Timing = ListCheckPrefix(Solver % Values,'Projector Timing') 18994 IF( Timing ) THEN 18995 t0 = CPUTime(); rt0 = RealTime() 18996 END IF 18997 18998 IsNonlinear = .FALSE. 18999 IF( PRESENT( Nonlinear ) ) IsNonlinear = Nonlinear 19000 IsSteadyState = .NOT. IsNonlinear 19001 19002 IF( .NOT. ASSOCIATED( Solver % MortarBCs ) ) THEN 19003 ALLOCATE( Solver % MortarBCs( Model % NumberOfBCs ) ) 19004 DO i=1, Model % NumberOfBCs 19005 Solver % MortarBCs(i) % Projector => NULL() 19006 END DO 19007 END IF 19008 19009 dim = CoordinateSystemDimension() 19010 19011 DO i=1,Model % NumberOFBCs 19012 BC => Model % BCs(i) % Values 19013 19014 ContactBC = .FALSE. 19015 j = ListGetInteger( BC,'Mortar BC',Found) 19016 IF( .NOT. Found ) THEN 19017 j = ListGetInteger( BC,'Contact BC',Found) 19018 ContactBC = Found 19019 END IF 19020 IF( .NOT. Found ) CYCLE 19021 19022 RequireNonlinear = ListGetLogical( BC,'Mortar BC Nonlinear',Found) 19023 IF( .NOT. Found ) THEN 19024 RequireNonlinear = ContactBC .AND. .NOT. ListGetLogical( BC,'Tie Contact',Found ) 19025 END IF 19026 19027 IF( IsNonlinear ) THEN 19028 IF( .NOT. RequireNonlinear ) CYCLE 19029 ELSE 19030 IF( RequireNonlinear ) CYCLE 19031 END IF 19032 19033 IF( ASSOCIATED( Solver % MortarBCs(i) % Projector ) ) THEN 19034 IF( ListGetLogical( BC,'Mortar BC Static',Found) ) CYCLE 19035 19036 IF( ASSOCIATED( Solver % MortarBCs(i) % Projector % Ematrix ) ) THEN 19037 CALL FreeMatrix( Solver % MortarBCs(i) % Projector % Ematrix ) 19038 END IF 19039 CALL FreeMatrix( Solver % MortarBCs(i) % Projector ) 19040 END IF 19041 19042 Solver % MortarBCs(i) % Projector => & 19043 PeriodicProjector(Model,Solver % Mesh,i,j,dim,.TRUE.) 19044 19045 IF( ASSOCIATED( Solver % MortarBCs(i) % Projector ) ) THEN 19046 Solver % MortarBCsChanged = .TRUE. 19047 END IF 19048 19049 END DO 19050 19051 19052 IF( Timing ) THEN 19053 st = CPUTime() - t0; 19054 rst = RealTime() - rt0 19055 19056 WRITE(Message,'(a,f8.2,f8.2,a)') 'Projector creation time (CPU,REAL) for '& 19057 //GetVarName(Solver % Variable)//': ',st,rst,' (s)' 19058 CALL Info(Caller,Message,Level=6) 19059 19060 IF( ListGetLogical(Solver % Values,'Projector Timing',Found)) THEN 19061 CALL ListAddConstReal(CurrentModel % Simulation,'res: projector cpu time '& 19062 //GetVarName(Solver % Variable),st) 19063 CALL ListAddConstReal(CurrentModel % Simulation,'res: projector real time '& 19064 //GetVarName(Solver % Variable),rst) 19065 END IF 19066 19067 IF( ListGetLogical(Solver % Values,'Projector Timing Cumulative',Found)) THEN 19068 ct = ListGetConstReal(CurrentModel % Simulation,'res: cum projector cpu time '& 19069 //GetVarName(Solver % Variable),Found) 19070 st = st + ct 19071 ct = ListGetConstReal(CurrentModel % Simulation,'res: cum projector real time '& 19072 //GetVarName(Solver % Variable),Found) 19073 rst = rst + ct 19074 CALL ListAddConstReal(CurrentModel % Simulation,'res: cum projector cpu time '& 19075 //GetVarName(Solver % Variable),st) 19076 CALL ListAddConstReal(CurrentModel % Simulation,'res: cum projector real time '& 19077 //GetVarName(Solver % Variable),rst) 19078 END IF 19079 END IF 19080 19081 END SUBROUTINE GenerateProjectors 19082 19083 19084 19085 ! Generate constraint matrix from mortar projectors. 19086 ! This routine takes each boundary projector and applies it 19087 ! to the current field variable (scalar or vector) merging 19088 ! all into one single projector. 19089 !--------------------------------------------------------- 19090 SUBROUTINE GenerateConstraintMatrix( Model, Solver ) 19091 19092 TYPE(Model_t) :: Model 19093 TYPE(Solver_t) :: Solver 19094 19095 INTEGER, POINTER :: Perm(:) 19096 INTEGER :: i,j,j2,k,k2,l,l2,dofs,maxperm,permsize,bc_ind,constraint_ind,row,col,col2,mcount,bcount,kk 19097 TYPE(Matrix_t), POINTER :: Atmp,Btmp, Ctmp 19098 LOGICAL :: AllocationsDone, CreateSelf, ComplexMatrix, TransposePresent, Found, & 19099 SetDof, SomeSet, SomeSkip, SumProjectors, NewRow, SumThis 19100 INTEGER, ALLOCATABLE :: SumPerm(:),SumCount(:) 19101 LOGICAL, ALLOCATABLE :: ActiveComponents(:), SetDefined(:) 19102 TYPE(ValueList_t), POINTER :: BC 19103 TYPE(MortarBC_t), POINTER :: MortarBC 19104 REAL(KIND=dp) :: wsum, Scale 19105 INTEGER :: rowoffset, arows, sumrow, EliminatedRows, NeglectedRows, sumrow0, k20 19106 CHARACTER(LEN=MAX_NAME_LEN) :: Str 19107 LOGICAL :: ThisIsMortar, Reorder 19108 LOGICAL :: AnyPriority 19109 INTEGER :: Priority, PrevPriority 19110 INTEGER, ALLOCATABLE :: BCOrdering(:), BCPriority(:) 19111 LOGICAL :: NeedToGenerate, ComplexSumRow 19112 19113 LOGICAL :: HaveMortarDiag, LumpedDiag, PerFlipActive 19114 REAL(KIND=dp) :: MortarDiag, val, valsum, EpsVal 19115 LOGICAL, POINTER :: PerFlip(:) 19116 CHARACTER(*), PARAMETER :: Caller = 'GenerateConstraintMatrix' 19117 19118 19119 ! Should we genarete the matrix 19120 NeedToGenerate = Solver % MortarBCsChanged 19121 19122 PerFlipActive = Solver % PeriodicFlipActive 19123 IF( PerFlipActive ) THEN 19124 CALL Info(Caller,'Periodic flip is active',Level=8) 19125 PerFlip => Solver % Mesh % PeriodicFlip 19126 END IF 19127 19128 ! Set pointers to save the initial constraint matrix 19129 ! We assume that the given ConstraintMatrix is constant but we have consider it the 1st time 19130 IF(.NOT. Solver % ConstraintMatrixVisited ) THEN 19131 IF( ASSOCIATED( Solver % Matrix % ConstraintMatrix ) ) THEN 19132 CALL Info(Caller,'Saving initial constraint matrix to Solver',Level=12) 19133 Solver % ConstraintMatrix => Solver % Matrix % ConstraintMatrix 19134 Solver % Matrix % ConstraintMatrix => NULL() 19135 NeedToGenerate = .TRUE. 19136 END IF 19137 Solver % ConstraintMatrixVisited = .TRUE. 19138 END IF 19139 19140 IF( NeedToGenerate ) THEN 19141 CALL Info(Caller,'Building constraint matrix',Level=12) 19142 ELSE 19143 CALL Info(Caller,'Nothing to do for now',Level=12) 19144 RETURN 19145 END IF 19146 19147 19148 ! Compute the number and size of initial constraint matrices 19149 !----------------------------------------------------------- 19150 row = 0 19151 mcount = 0 19152 bcount = 0 19153 Ctmp => Solver % ConstraintMatrix 19154 IF( ASSOCIATED( Ctmp ) ) THEN 19155 DO WHILE(ASSOCIATED(Ctmp)) 19156 mcount = mcount + 1 19157 row = row + Ctmp % NumberOfRows 19158 Ctmp => Ctmp % ConstraintMatrix 19159 END DO 19160 CALL Info(Caller,'Number of initial constraint matrices: '//TRIM(I2S(mcount)),Level=12) 19161 END IF 19162 19163 19164 ! Compute the number and size of mortar matrices 19165 !----------------------------------------------- 19166 IF( ASSOCIATED( Solver % MortarBCs ) ) THEN 19167 DO bc_ind=1,Model % NumberOFBCs 19168 Atmp => Solver % MortarBCs(bc_ind) % Projector 19169 IF( .NOT. ASSOCIATED( Atmp ) ) CYCLE 19170 bcount = bcount + 1 19171 row = row + Atmp % NumberOfRows 19172 END DO 19173 CALL Info(Caller,'Number of mortar matrices: '//TRIM(I2S(bcount)),Level=12) 19174 END IF 19175 19176 IF( row==0 ) THEN 19177 CALL Info(Caller,'Nothing to do since there are no constrained dofs!',Level=12) 19178 RETURN 19179 END IF 19180 19181 MortarDiag = ListGetCReal( Solver % Values,'Mortar Diag',HaveMortarDiag ) 19182 LumpedDiag = ListGetLogical( Solver % Values,'Lumped Diag',Found ) 19183 19184 IF( HaveMortarDiag ) THEN 19185 CALL Info(Caller,& 19186 'Adding diagonal entry to mortar constraint!',Level=12) 19187 END IF 19188 19189 IF( mcount == 1 .AND. bcount == 0 .AND. .NOT. HaveMortarDiag ) THEN 19190 CALL Info(Caller,'Using initial constraint matrix',Level=12) 19191 Solver % Matrix % ConstraintMatrix => Solver % ConstraintMatrix 19192 RETURN 19193 END IF 19194 19195 ! Now we are generating something more complex and different than last time 19196 IF( ASSOCIATED( Solver % Matrix % ConstraintMatrix ) ) THEN 19197 CALL Info(Caller,'Releasing previous constraint matrix',Level=12) 19198 CALL FreeMatrix(Solver % Matrix % ConstraintMatrix) 19199 Solver % Matrix % ConstraintMatrix => NULL() 19200 END IF 19201 19202 EpsVal = ListGetConstReal( Solver % Values,& 19203 'Minimum Projector Value', Found ) 19204 IF(.NOT. Found ) EpsVal = 1.0d-8 19205 19206 19207 SumProjectors = ListGetLogical( Solver % Values,& 19208 'Mortar BCs Additive', Found ) 19209 IF( .NOT. Found ) THEN 19210 IF( bcount > 1 .AND. ListGetLogical( Solver % Values, & 19211 'Eliminate Linear Constraints',Found ) ) THEN 19212 CALL Info(Caller,& 19213 'Enforcing > Mortar BCs Additive < to True to enable elimination',Level=8) 19214 SumProjectors = .TRUE. 19215 END IF 19216 IF( .NOT. SumProjectors .AND. ListGetLogical( Solver % Values, & 19217 'Apply Conforming BCs',Found ) ) THEN 19218 CALL Info(Caller,& 19219 'Enforcing > Mortar BCs Additive < to True because of conforming BCs',Level=8) 19220 SumProjectors = .TRUE. 19221 END IF 19222 END IF 19223 EliminatedRows = 0 19224 19225 CALL Info(Caller,'There are '& 19226 //TRIM(I2S(row))//' initial rows in constraint matrices',Level=10) 19227 19228 dofs = Solver % Variable % DOFs 19229 Perm => Solver % Variable % Perm 19230 permsize = SIZE( Perm ) 19231 maxperm = MAXVAL( Perm ) 19232 AllocationsDone = .FALSE. 19233 arows = Solver % Matrix % NumberOfRows 19234 19235 ALLOCATE( ActiveComponents(dofs), SetDefined(dofs) ) 19236 19237 IF( SumProjectors ) THEN 19238 ALLOCATE( SumPerm( dofs * permsize ) ) 19239 SumPerm = 0 19240 ALLOCATE( SumCount( arows ) ) 19241 SumCount = 0 19242 END IF 19243 19244 ComplexMatrix = Solver % Matrix % Complex 19245 ComplexSumRow = .FALSE. 19246 19247 IF( ComplexMatrix ) THEN 19248 IF( MODULO( Dofs,2 ) /= 0 ) CALL Fatal(Caller,& 19249 'Complex matrix should have even number of components!') 19250 ELSE 19251 ! Currently complex matrix is enforced if there is an even number of 19252 ! entries since it seems that we cannot rely on the flag to be set. 19253 ComplexMatrix = ListGetLogical( Solver % Values,'Linear System Complex',Found ) 19254 IF( .NOT. Found ) ComplexMatrix = ( MODULO( Dofs,2 ) == 0 ) 19255 END IF 19256 19257 19258 AnyPriority = ListCheckPresentAnyBC( Model,'Projector Priority') 19259 IF( AnyPriority ) THEN 19260 IF(.NOT. SumProjectors ) THEN 19261 CALL Warn(Caller,'Priority has effect only in additive mode!') 19262 AnyPriority = .FALSE. 19263 ELSE 19264 CALL Info(Caller,'Using priority for projector entries',Level=7) 19265 ALLOCATE( BCPriority(Model % NumberOfBCs), BCOrdering( Model % NumberOfBCs) ) 19266 BCPriority = 0; BCOrdering = 0 19267 DO bc_ind=1, Model % NumberOFBCs 19268 Priority = ListGetInteger( Model % BCs(bc_ind) % Values,'Projector Priority',Found) 19269 BCPriority(bc_ind) = -bc_ind + Priority * Model % NumberOfBCs 19270 BCOrdering(bc_ind) = bc_ind 19271 END DO 19272 CALL SortI( Model % NumberOfBCs, BCPriority, BCOrdering ) 19273 END IF 19274 END IF 19275 NeglectedRows = 0 19276 19277 19278100 sumrow = 0 19279 k2 = 0 19280 rowoffset = 0 19281 Priority = -1 19282 PrevPriority = -1 19283 sumrow0 = 0 19284 k20 = 0 19285 19286 TransposePresent = .FALSE. 19287 Ctmp => Solver % ConstraintMatrix 19288 19289 DO constraint_ind = Model % NumberOFBCs+mcount,1,-1 19290 19291 ! This is the default i.e. all components are applied mortar BCs 19292 ActiveComponents = .TRUE. 19293 19294 IF(constraint_ind > Model % NumberOfBCs) THEN 19295 ThisIsMortar = .FALSE. 19296 SumThis = .FALSE. 19297 Atmp => Ctmp 19298 IF( .NOT. ASSOCIATED( Atmp ) ) CYCLE 19299 Ctmp => Ctmp % ConstraintMatrix 19300 IF( .NOT. ASSOCIATED( Atmp % InvPerm ) ) THEN 19301 IF(.NOT. AllocationsDone ) THEN 19302 CALL Warn(Caller,'InvPerm is expected, using identity!') 19303 END IF 19304 END IF 19305 CALL Info(Caller,'Adding initial constraint matrix: '& 19306 //TRIM(I2S(constraint_ind - Model % NumberOfBCs)),Level=8) 19307 ELSE 19308 ThisIsMortar = .TRUE. 19309 SumThis = SumProjectors 19310 IF( AnyPriority ) THEN 19311 bc_ind = BCOrdering(constraint_ind) 19312 ELSE 19313 bc_ind = constraint_ind 19314 END IF 19315 19316 MortarBC => Solver % MortarBCs(bc_ind) 19317 Atmp => MortarBC % Projector 19318 19319 IF( .NOT. ASSOCIATED( Atmp ) ) CYCLE 19320 19321 IF(.NOT. AllocationsDone ) THEN 19322 CALL Info(Caller,'Adding projector for BC: '//TRIM(I2S(bc_ind)),Level=8) 19323 END IF 19324 19325 IF( .NOT. ASSOCIATED( Atmp % InvPerm ) ) THEN 19326 CALL Fatal(Caller,'InvPerm is required!') 19327 END IF 19328 19329 IF( AnyPriority ) THEN 19330 Priority = ListGetInteger( Model % BCs(bc_ind) % Values,'Projector Priority',Found) 19331 END IF 19332 19333 ! Enable that the user can for vector valued cases either set some 19334 ! or skip some field components. 19335 SomeSet = .FALSE. 19336 SomeSkip = .FALSE. 19337 DO i=1,Dofs 19338 IF( Dofs > 1 ) THEN 19339 str = ComponentName( Solver % Variable, i ) 19340 ELSE 19341 str = Solver % Variable % Name 19342 END IF 19343 19344 SetDof = ListGetLogical( Model % BCs(bc_ind) % Values,'Mortar BC '//TRIM(str),Found ) 19345 19346 SetDefined(i) = Found 19347 IF(Found) THEN 19348 ActiveComponents(i) = SetDof 19349 IF( SetDof ) THEN 19350 SomeSet = .TRUE. 19351 ELSE 19352 SomeSkip = .TRUE. 19353 END IF 19354 END IF 19355 END DO 19356 19357 ! By default all components are applied mortar BC and some are turned off. 19358 ! If the user does the opposite then the default for other components is True. 19359 IF( SomeSet .AND. .NOT. ALL(SetDefined) ) THEN 19360 IF( SomeSkip ) THEN 19361 CALL Fatal(Caller,'Do not know what to do with all components') 19362 ELSE 19363 CALL Info(Caller,'Unspecified components will not be set for BC '//TRIM(I2S(bc_ind)),Level=10) 19364 DO i=1,Dofs 19365 IF( .NOT. SetDefined(i) ) ActiveComponents(i) = .FALSE. 19366 END DO 19367 END IF 19368 END IF 19369 END IF 19370 19371 TransposePresent = TransposePresent .OR. ASSOCIATED(Atmp % Child) 19372 IF( TransposePresent ) THEN 19373 CALL Info(Caller,'Transpose matrix is present',Level=8) 19374 END IF 19375 19376 ! If the projector is of type x_s=P*x_m then generate a constraint matrix 19377 ! of type [D-P]x=0 where D is diagonal unit matrix. 19378 CreateSelf = ( Atmp % ProjectorType == PROJECTOR_TYPE_NODAL ) 19379 19380 IF( SumThis .AND. CreateSelf ) THEN 19381 CALL Fatal(Caller,'It is impossible to sum up nodal projectors!') 19382 END IF 19383 19384 ! Assume the mortar matrices refer to unordered mesh dofs 19385 ! and existing ConstraintMatrix to already ordered entities. 19386 Reorder = ThisIsMortar 19387 19388 ComplexSumRow = ListGetLogical( Solver % Values,'Complex Sum Row ', Found ) 19389 IF(.NOT. Found ) THEN 19390 ComplexSumRow = ( dofs == 2 .AND. ComplexMatrix .AND. .NOT. CreateSelf .AND. & 19391 SumThis .AND. .NOT. (ASSOCIATED( MortarBC % Diag ) .OR. HaveMortarDiag ) ) 19392 END IF 19393 19394 IF( Dofs == 1 ) THEN 19395 19396 IF( .NOT. ActiveComponents(1) ) THEN 19397 CALL Info(Caller,'Skipping component: '//TRIM(I2S(1)),Level=12) 19398 CYCLE 19399 END IF 19400 19401 ! Number the rows. 19402 IF( SumThis ) THEN 19403 DO i=1,Atmp % NumberOfRows 19404 ! Skip empty row 19405 IF( Atmp % Rows(i) >= Atmp % Rows(i+1) ) CYCLE 19406 19407 ! If the mortar boundary is not active at this round don't apply it 19408 IF( ThisIsMortar ) THEN 19409 IF( ASSOCIATED( MortarBC % Active ) ) THEN 19410 IF( .NOT. MortarBC % Active(i) ) CYCLE 19411 END IF 19412 END IF 19413 19414 ! Use InvPerm if it is present 19415 IF( ASSOCIATED( Atmp % InvPerm ) ) THEN 19416 k = Atmp % InvPerm(i) 19417 ! Node does not have an active dof to be constrained 19418 IF( k == 0 ) CYCLE 19419 ELSE 19420 k = i 19421 END IF 19422 19423 kk = k 19424 IF( Reorder ) THEN 19425 kk = Perm(k) 19426 IF( kk == 0 ) CYCLE 19427 END IF 19428 19429 NewRow = ( SumPerm(kk) == 0 ) 19430 IF( NewRow ) THEN 19431 sumrow = sumrow + 1 19432 SumPerm(kk) = sumrow 19433 ELSE IF(.NOT. AllocationsDone ) THEN 19434 IF( Priority /= PrevPriority .AND. SumPerm(kk) < 0 ) THEN 19435 NeglectedRows = NeglectedRows + 1 19436 ELSE 19437 EliminatedRows = EliminatedRows + 1 19438 END IF 19439 END IF 19440 END DO 19441 END IF 19442 19443 IF( ASSOCIATED( MortarBC % Diag ) .OR. HaveMortarDiag ) THEN 19444 IF( .NOT. ASSOCIATED( MortarBC % Perm ) ) THEN 19445 k = MAXVAL( Atmp % Cols ) 19446 ALLOCATE( MortarBC % Perm(k) ) 19447 MortarBC % Perm = 0 19448 DO k=1,SIZE(Atmp % InvPerm ) 19449 j = Atmp % InvPerm(k) 19450 MortarBC % Perm( j ) = k 19451 END DO 19452 END IF 19453 END IF 19454 19455 19456 DO i=1,Atmp % NumberOfRows 19457 19458 IF( Atmp % Rows(i) >= Atmp % Rows(i+1) ) CYCLE ! skip empty rows 19459 19460 ! If the mortar boundary is not active at this round don't apply it 19461 IF( ThisIsMortar ) THEN 19462 IF( ASSOCIATED( MortarBC % Active ) ) THEN 19463 IF( .NOT. MortarBC % Active(i) ) CYCLE 19464 END IF 19465 END IF 19466 19467 IF( ASSOCIATED( Atmp % InvPerm ) ) THEN 19468 k = Atmp % InvPerm(i) 19469 IF( k == 0 ) CYCLE 19470 ELSE 19471 k = i 19472 END IF 19473 19474 kk = k 19475 IF( Reorder ) THEN 19476 kk = Perm(k) 19477 IF( kk == 0 ) CYCLE 19478 END IF 19479 19480 IF( SumThis ) THEN 19481 row = SumPerm(kk) 19482 19483 ! Mark this for future contributions so we know this is already set 19484 ! and can skip this above. 19485 IF( AnyPriority ) THEN 19486 IF( row < 0 ) CYCLE 19487 IF( Priority /= PrevPriority ) SumPerm(kk) = -SumPerm(kk) 19488 END IF 19489 19490 IF( row <= 0 ) THEN 19491 CALL Fatal(Caller,'Invalid row index: '//TRIM(I2S(row))) 19492 END IF 19493 ELSE 19494 sumrow = sumrow + 1 19495 row = sumrow 19496 END IF 19497 19498 IF( AllocationsDone ) THEN 19499 Btmp % InvPerm(row) = rowoffset + kk 19500 END IF 19501 19502 19503 wsum = 0.0_dp 19504 19505 19506 valsum = 0.0_dp 19507 DO l=Atmp % Rows(i),Atmp % Rows(i+1)-1 19508 valsum = valsum + ABS( Atmp % Values(l) ) 19509 END DO 19510 19511 19512 DO l=Atmp % Rows(i),Atmp % Rows(i+1)-1 19513 19514 col = Atmp % Cols(l) 19515 val = Atmp % Values(l) 19516 19517 IF( ABS( val ) < EpsVal * valsum ) CYCLE 19518 19519 19520 IF( Reorder ) THEN 19521 IF( col <= permsize ) THEN 19522 col2 = Perm(col) 19523 IF( col2 == 0 ) CYCLE 19524 ELSE 19525 CALL Fatal(Caller,'col index too large: '//TRIM(I2S(col))) 19526 END IF 19527 ELSE 19528 col2 = col 19529 END IF 19530 19531 IF( AllocationsDone ) THEN 19532 ! By Default there is no scaling 19533 Scale = 1.0_dp 19534 IF( ThisIsMortar ) THEN 19535 IF( CreateSelf ) THEN 19536 ! We want to create [D-P] hence the negative sign 19537 Scale = MortarBC % MasterScale 19538 wsum = wsum + val 19539 ELSE IF( ASSOCIATED( MortarBC % Perm ) ) THEN 19540 ! Look if the component refers to the slave 19541 IF( MortarBC % Perm( col ) > 0 ) THEN 19542 Scale = MortarBC % SlaveScale 19543 wsum = wsum + val 19544 ELSE 19545 Scale = MortarBC % MasterScale 19546 END IF 19547 ELSE 19548 wsum = wsum + val 19549 END IF 19550 19551 ! If we sum up to anti-periodic dof then use different sign 19552 ! - except if the target is also antiperiodic. 19553 IF( PerFlipActive ) THEN 19554 IF( XOR( PerFlip(col),PerFlip(k) ) ) Scale = -Scale 19555 END IF 19556 19557 END IF 19558 19559 ! Add a new column index to the summed up row 19560 ! At the first sweep we need to find the first unset position 19561 IF( SumThis ) THEN 19562 k2 = Btmp % Rows(row) 19563 DO WHILE( Btmp % Cols(k2) > 0 ) 19564 k2 = k2 + 1 19565 END DO 19566 ELSE 19567 k2 = k2 + 1 19568 END IF 19569 19570 Btmp % Cols(k2) = col2 19571 Btmp % Values(k2) = Scale * val 19572 IF(ASSOCIATED(Btmp % TValues)) THEN 19573 IF(ASSOCIATED(Atmp % Child)) THEN 19574 Btmp % TValues(k2) = Scale * Atmp % Child % Values(l) 19575 ELSE 19576 Btmp % TValues(k2) = Scale * val 19577 END IF 19578 END IF 19579 ELSE 19580 k2 = k2 + 1 19581 IF( SumThis ) THEN 19582 SumCount(row) = SumCount(row) + 1 19583 END IF 19584 END IF 19585 END DO 19586 19587 ! Add the self entry as in 'D' 19588 IF( CreateSelf ) THEN 19589 k2 = k2 + 1 19590 IF( AllocationsDone ) THEN 19591 Btmp % Cols(k2) = Perm( Atmp % InvPerm(i) ) 19592 Btmp % Values(k2) = MortarBC % SlaveScale * wsum 19593 ELSE 19594 IF( SumThis) SumCount(row) = SumCount(row) + 1 19595 END IF 19596 END IF 19597 19598 ! Add a diagonal entry if requested. When this is done at the final stage 19599 ! all the hassle with the right column index is easier. 19600 IF( ThisIsMortar ) THEN 19601 diag: IF( ASSOCIATED( MortarBC % Diag ) .OR. HaveMortarDiag ) THEN 19602 IF( .NOT. HaveMortarDiag ) THEN 19603 MortarDiag = MortarBC % Diag(i) 19604 LumpedDiag = MortarBC % LumpedDiag 19605 END IF 19606 19607 IF( LumpedDiag ) THEN 19608 k2 = k2 + 1 19609 IF( AllocationsDone ) THEN 19610 Btmp % Cols(k2) = row + arows 19611 ! The factor 0.5 comes from the fact that the 19612 ! contribution is summed twice, 2nd time as transpose 19613 ! For Nodal projector the entry is 1/(weight*coeff) 19614 ! For Galerkin projector the is weight/coeff 19615 Btmp % Values(k2) = Btmp % Values(k2) - 0.5_dp * MortarDiag * wsum 19616 ELSE 19617 IF( SumThis) SumCount(row) = SumCount(row) + 1 19618 END IF 19619 ELSE 19620 IF( .NOT. ASSOCIATED( MortarBC % Perm ) ) THEN 19621 CALL Fatal(Caller,'MortarBC % Perm required, try lumped') 19622 END IF 19623 19624 DO l=Atmp % Rows(i),Atmp % Rows(i+1)-1 19625 col = Atmp % Cols(l) 19626 19627 IF( col > permsize ) THEN 19628 PRINT *,'col too large',col,permsize 19629 CYCLE 19630 END IF 19631 col2 = Perm(col) 19632 IF( col2 == 0 ) CYCLE 19633 19634 IF( CreateSelf ) THEN 19635 Scale = -MortarBC % MasterScale 19636 ELSE 19637 IF( MortarBC % Perm( col ) > 0 ) THEN 19638 Scale = MortarBC % SlaveScale 19639 ELSE 19640 CYCLE 19641 END IF 19642 END IF 19643 19644 k2 = k2 + 1 19645 IF( AllocationsDone ) THEN 19646 IF( SumThis ) THEN 19647 l2 = ABS( SumPerm( col2) ) 19648 ELSE 19649 l2 = MortarBC % Perm(col) 19650 END IF 19651 19652 Btmp % Cols(k2) = l2 + arows + rowoffset 19653 Btmp % Values(k2) = Btmp % Values(k2) - 0.5_dp * val * MortarDiag 19654 ELSE 19655 IF( SumThis) SumCount(row) = SumCount(row) + 1 19656 END IF 19657 END DO 19658 END IF 19659 END IF diag 19660 END IF 19661 19662 IF( AllocationsDone ) THEN 19663 IF( ThisIsMortar ) THEN 19664 IF( ASSOCIATED( MortarBC % Rhs ) ) THEN 19665 Btmp % Rhs(row) = Btmp % Rhs(row) + wsum * MortarBC % rhs(i) 19666 END IF 19667 END IF 19668 19669 ! If every component is uniquely summed we can compute the row indexes simply 19670 IF( .NOT. SumThis ) THEN 19671 Btmp % Rows(row+1) = k2 + 1 19672 END IF 19673 END IF 19674 END DO 19675 19676 ELSE IF( ComplexSumRow ) THEN 19677 19678 CALL Info(Caller,'Using simplified complex summing!',Level=8) 19679 ComplexSumRow = .TRUE. 19680 19681 ! In case of a vector valued problem create a projector that acts on all 19682 ! components of the vector. Otherwise follow the same logic. 19683 IF( SumThis ) THEN 19684 DO i=1,Atmp % NumberOfRows 19685 19686 IF( ASSOCIATED( Atmp % InvPerm ) ) THEN 19687 k = Atmp % InvPerm(i) 19688 IF( k == 0 ) CYCLE 19689 ELSE 19690 k = i 19691 END IF 19692 19693 kk = k 19694 IF( Reorder ) THEN 19695 kk = Perm(k) 19696 IF( kk == 0 ) CYCLE 19697 END IF 19698 19699 NewRow = ( SumPerm(kk) == 0 ) 19700 IF( NewRow ) THEN 19701 sumrow = sumrow + 1 19702 SumPerm(kk) = sumrow 19703 ELSE IF(.NOT. AllocationsDone ) THEN 19704 EliminatedRows = EliminatedRows + 1 19705 END IF 19706 END DO 19707 END IF 19708 19709 19710 DO i=1,Atmp % NumberOfRows 19711 19712 IF( ASSOCIATED( Atmp % InvPerm ) ) THEN 19713 k = Atmp % InvPerm(i) 19714 IF( k == 0 ) CYCLE 19715 ELSE 19716 k = i 19717 END IF 19718 19719 kk = k 19720 IF( Reorder ) THEN 19721 kk = Perm(k) 19722 IF( kk == 0 ) CYCLE 19723 END IF 19724 19725 IF( SumThis ) THEN 19726 row = SumPerm(kk) 19727 ELSE 19728 sumrow = sumrow + 1 19729 row = sumrow 19730 END IF 19731 19732 ! For complex matrices 19733 IF( AllocationsDone ) THEN 19734 Btmp % InvPerm(2*row-1) = rowoffset + 2*(kk-1)+1 19735 Btmp % InvPerm(2*row) = rowoffset + 2*kk 19736 END IF 19737 19738 wsum = 0.0_dp 19739 19740 19741 DO l=Atmp % Rows(i),Atmp % Rows(i+1)-1 19742 19743 col = Atmp % Cols(l) 19744 val = Atmp % Values(l) 19745 19746 IF( Reorder ) THEN 19747 col2 = Perm(col) 19748 IF( col2 == 0 ) CYCLE 19749 ELSE 19750 col2 = col 19751 END IF 19752 19753 IF( AllocationsDone ) THEN 19754 ! By Default there is no scaling 19755 Scale = 1.0_dp 19756 IF( ThisIsMortar ) THEN 19757 IF( ASSOCIATED( MortarBC % Perm ) ) THEN 19758 ! Look if the component refers to the slave 19759 IF( MortarBC % Perm( col ) > 0 ) THEN 19760 Scale = MortarBC % SlaveScale 19761 wsum = wsum + val 19762 ELSE 19763 Scale = MortarBC % MasterScale 19764 END IF 19765 ELSE 19766 wsum = wsum + val 19767 END IF 19768 19769 ! If we sum up to anti-periodic dof then use different sign 19770 ! - except if the target is also antiperiodic. 19771 IF( PerFlipActive ) THEN 19772 IF( XOR( PerFlip(col),PerFlip(k) ) ) Scale = -Scale 19773 END IF 19774 19775 END IF 19776 19777 ! Add a new column index to the summed up row 19778 ! At the first sweep we need to find the first unset position 19779 ! Real part 19780 IF( SumThis ) THEN 19781 k2 = Btmp % Rows(2*row-1) 19782 DO WHILE( Btmp % Cols(k2) > 0 ) 19783 k2 = k2 + 1 19784 END DO 19785 ELSE 19786 k2 = k2 + 1 19787 END IF 19788 19789 Btmp % Cols(k2) = 2 * col2 - 1 19790 Btmp % Values(k2) = Scale * val 19791 19792 k2 = k2 + 1 19793 Btmp % Cols(k2) = 2 * col2 19794 Btmp % Values(k2) = 0.0 19795 19796 ! Complex part 19797 IF( SumThis ) THEN 19798 k2 = Btmp % Rows(2*row) 19799 DO WHILE( Btmp % Cols(k2) > 0 ) 19800 k2 = k2 + 1 19801 END DO 19802 ELSE 19803 k2 = k2 + 1 19804 END IF 19805 19806 Btmp % Cols(k2) = 2 * col2 - 1 19807 Btmp % Values(k2) = 0.0 19808 19809 k2 = k2 + 1 19810 Btmp % Cols(k2) = 2 * col2 19811 Btmp % Values(k2) = Scale * val 19812 ELSE 19813 k2 = k2 + 4 19814 IF( SumThis ) THEN 19815 SumCount(2*row-1) = SumCount(2*row-1) + 2 19816 SumCount(2*row) = SumCount(2*row) + 2 19817 END IF 19818 END IF 19819 END DO 19820 19821 IF( AllocationsDone ) THEN 19822 IF( ThisIsMortar ) THEN 19823 IF( ASSOCIATED( MortarBC % Rhs ) ) THEN 19824 Btmp % Rhs(2*row-1) = Btmp % Rhs(2*row-1) + wsum * MortarBC % rhs(i) 19825 END IF 19826 END IF 19827 END IF 19828 END DO 19829 19830 ELSE 19831 19832 ! dofs > 1 19833 ! In case of a vector valued problem create a projector that acts on all 19834 ! components of the vector. Otherwise follow the same logic. 19835 DO i=1,Atmp % NumberOfRows 19836 DO j=1,Dofs 19837 19838 IF( .NOT. ActiveComponents(j) ) THEN 19839 CALL Info(Caller,'Skipping component: '//TRIM(I2S(j)),Level=12) 19840 CYCLE 19841 END IF 19842 19843 ! For complex matrices both entries mist be created 19844 ! since preconditioning benefits from 19845 IF( ComplexMatrix ) THEN 19846 IF( MODULO( j, 2 ) == 0 ) THEN 19847 j2 = j-1 19848 ELSE 19849 j2 = j+1 19850 END IF 19851 ELSE 19852 j2 = 0 19853 END IF 19854 19855 IF( ThisIsMortar ) THEN 19856 IF( ASSOCIATED( MortarBC % Active ) ) THEN 19857 IF( .NOT. MortarBC % Active(Dofs*(i-1)+j) ) CYCLE 19858 END IF 19859 END IF 19860 19861 IF( ASSOCIATED( Atmp % InvPerm ) ) THEN 19862 k = Atmp % InvPerm(i) 19863 IF( k == 0 ) CYCLE 19864 ELSE 19865 k = i 19866 END IF 19867 19868 kk = k 19869 IF( Reorder ) THEN 19870 kk = Perm(k) 19871 IF( kk == 0 ) CYCLE 19872 END IF 19873 19874 IF( SumThis ) THEN 19875 IF( Dofs*(k-1)+j > SIZE(SumPerm) ) THEN 19876 CALL Fatal(Caller,'Index out of range') 19877 END IF 19878 NewRow = ( SumPerm(Dofs*(kk-1)+j) == 0 ) 19879 IF( NewRow ) THEN 19880 sumrow = sumrow + 1 19881 IF( Priority /= 0 ) THEN 19882 ! Use negative sign to show that this has already been set by priority 19883 SumPerm(Dofs*(kk-1)+j) = -sumrow 19884 ELSE 19885 SumPerm(Dofs*(kk-1)+j) = sumrow 19886 END IF 19887 ELSE IF( Priority /= PrevPriority .AND. SumPerm(Dofs*(kk-1)+j) < 0 ) THEN 19888 IF(.NOT. AllocationsDone ) THEN 19889 NeglectedRows = NeglectedRows + 1 19890 END IF 19891 CYCLE 19892 ELSE 19893 IF(.NOT. AllocationsDone ) THEN 19894 EliminatedRows = EliminatedRows + 1 19895 END IF 19896 END IF 19897 row = ABS( SumPerm(Dofs*(kk-1)+j) ) 19898 ELSE 19899 sumrow = sumrow + 1 19900 row = sumrow 19901 END IF 19902 19903 IF( AllocationsDone ) THEN 19904 Btmp % InvPerm(row) = rowoffset + Dofs * ( kk - 1 ) + j 19905 END IF 19906 19907 19908 wsum = 0.0_dp 19909 19910 DO k=Atmp % Rows(i),Atmp % Rows(i+1)-1 19911 19912 col = Atmp % Cols(k) 19913 19914 IF( Reorder ) THEN 19915 IF( col <= permsize ) THEN 19916 col2 = Perm(col) 19917 IF( col2 == 0 ) CYCLE 19918 ELSE 19919 PRINT *,'col too large',col,permsize 19920 CYCLE 19921 END IF 19922 ELSE 19923 col2 = col 19924 END IF 19925 19926 19927 k2 = k2 + 1 19928 19929 IF( AllocationsDone ) THEN 19930 Scale = 1.0_dp 19931 IF( ThisIsMortar ) THEN 19932 IF( CreateSelf ) THEN 19933 Scale = MortarBC % MasterScale 19934 wsum = wsum + Atmp % Values(k) 19935 ELSE IF( ASSOCIATED( MortarBC % Perm ) ) THEN 19936 IF( MortarBC % Perm(col) > 0 ) THEN 19937 Scale = MortarBC % SlaveScale 19938 wsum = wsum + Atmp % Values(k) 19939 ELSE 19940 Scale = MortarBC % MasterScale 19941 END IF 19942 END IF 19943 19944 ! If we sum up to anti-periodic dof then use different sign 19945 ! - except if the target is also antiperiodic. 19946 IF( PerFlipActive ) THEN 19947 IF( XOR( PerFlip(col),PerFlip(k) ) ) Scale = -Scale 19948 END IF 19949 19950 END IF 19951 19952 Btmp % Cols(k2) = Dofs * ( col2 - 1) + j 19953 Btmp % Values(k2) = Scale * Atmp % Values(k) 19954 IF(ASSOCIATED(Btmp % Tvalues)) THEN 19955 IF(ASSOCIATED(Atmp % Child)) THEN 19956 Btmp % TValues(k2) = Scale * Atmp % Child % Values(k) 19957 ELSE 19958 Btmp % TValues(k2) = Scale * Atmp % Values(k) 19959 END IF 19960 END IF 19961 ELSE 19962 IF( SumThis ) THEN 19963 SumCount(row) = SumCount(row) + 1 19964 END IF 19965 END IF 19966 END DO 19967 19968 ! Add the self entry as in 'D' 19969 IF( CreateSelf ) THEN 19970 k2 = k2 + 1 19971 IF( AllocationsDone ) THEN 19972 Btmp % Cols(k2) = Dofs * ( Perm( Atmp % InvPerm(i) ) -1 ) + j 19973 Btmp % Values(k2) = MortarBC % SlaveScale * wsum 19974 END IF 19975 END IF 19976 19977 ! Create the imaginary part (real part) corresponding to the 19978 ! real part (imaginary part) of the projector. 19979 IF( j2 /= 0 ) THEN 19980 DO k=Atmp % Rows(i),Atmp % Rows(i+1)-1 19981 19982 col = Atmp % Cols(k) 19983 19984 IF( Reorder ) THEN 19985 IF( col <= permsize ) THEN 19986 col2 = Perm(col) 19987 IF( col2 == 0 ) CYCLE 19988 END IF 19989 ELSE 19990 col2 = col 19991 END IF 19992 19993 k2 = k2 + 1 19994 IF( AllocationsDone ) THEN 19995 Btmp % Cols(k2) = Dofs * ( col2 - 1) + j2 19996 ELSE 19997 IF( SumThis ) THEN 19998 SumCount(row) = SumCount(row) + 1 19999 END IF 20000 END IF 20001 END DO 20002 20003 IF( CreateSelf ) THEN 20004 k2 = k2 + 1 20005 IF( AllocationsDone ) THEN 20006 Btmp % Cols(k2) = Dofs * ( Perm( Atmp % InvPerm(i) ) -1 ) + j2 20007 END IF 20008 END IF 20009 END IF 20010 20011 20012 IF( ThisIsMortar ) THEN 20013 IF( ASSOCIATED( MortarBC % Diag ) .OR. HaveMortarDiag ) THEN 20014 IF( .NOT. HaveMortarDiag ) THEN 20015 MortarDiag = MortarBC % Diag(Dofs*(i-1)+j) 20016 LumpedDiag = MortarBC % LumpedDiag 20017 END IF 20018 20019 IF( LumpedDiag ) THEN 20020 k2 = k2 + 1 20021 IF( AllocationsDone ) THEN 20022 Btmp % Cols(k2) = row + arows 20023 Btmp % Values(k2) = -0.5_dp * wsum * MortarDiag 20024 END IF 20025 ELSE 20026 DO k=Atmp % Rows(i),Atmp % Rows(i+1)-1 20027 col = Atmp % Cols(k) 20028 20029 IF( col > permsize ) CYCLE 20030 col2 = Perm(col) 20031 20032 IF( CreateSelf ) THEN 20033 Scale = -MortarBC % MasterScale 20034 ELSE 20035 IF( MortarBC % Perm( col ) > 0 ) THEN 20036 Scale = MortarBC % SlaveScale 20037 ELSE 20038 CYCLE 20039 END IF 20040 END IF 20041 20042 k2 = k2 + 1 20043 IF( AllocationsDone ) THEN 20044 Btmp % Cols(k2) = Dofs*(MortarBC % Perm( col )-1)+j + arows + rowoffset 20045 Btmp % Values(k2) = -0.5_dp * Atmp % Values(k) * MortarDiag 20046 END IF 20047 END DO 20048 END IF 20049 END IF 20050 END IF 20051 20052 20053 IF( AllocationsDone ) THEN 20054 IF( ThisIsMortar ) THEN 20055 IF( ASSOCIATED( MortarBC % Rhs ) ) THEN 20056 Btmp % Rhs(row) = wsum * MortarBC % rhs(Dofs*(i-1)+j) 20057 END IF 20058 END IF 20059 IF(.NOT. SumThis ) THEN 20060 Btmp % Rows(row+1) = k2 + 1 20061 END IF 20062 END IF 20063 20064 END DO 20065 END DO 20066 END IF ! dofs > 1 20067 20068 IF( .NOT. SumThis ) THEN 20069 rowoffset = rowoffset + Arows 20070 IF( SumProjectors ) THEN 20071 CALL Info(Caller,'Not summed up size is ' & 20072 //TRIM(I2S(sumrow))//' rows and '//TRIM(I2S(k2))//' nonzeros',Level=8) 20073 sumrow0 = sumrow 20074 k20 = k2 20075 END IF 20076 END IF 20077 20078 PrevPriority = Priority 20079 END DO ! constrain_ind 20080 20081 IF( k2 == 0 ) THEN 20082 CALL Info(Caller,'No entries in constraint matrix!',Level=8) 20083! Solver % Matrix % ConstraintMatrix => NULL() 20084 RETURN 20085 END IF 20086 20087 ! Allocate the united matrix of all the boundary matrices 20088 !------------------------------------------------------- 20089 IF( .NOT. AllocationsDone ) THEN 20090 CALL Info(Caller,'Allocating '//& 20091 TRIM(I2S(sumrow))//' rows and '//TRIM(I2S(k2))//' nonzeros',& 20092 Level=8) 20093 20094 IF( ComplexSumRow ) THEN 20095 sumrow = 2 * sumrow 20096 END IF 20097 20098 Btmp => AllocateMatrix() 20099 ALLOCATE( Btmp % RHS(sumrow), Btmp % Rows(sumrow+1), & 20100 Btmp % Cols(k2), Btmp % Values(k2), & 20101 Btmp % InvPerm(sumrow) ) 20102 20103 Btmp % Rhs = 0.0_dp 20104 Btmp % Rows = 0 20105 Btmp % Cols = 0 20106 Btmp % Values = 0.0_dp 20107 Btmp % NumberOFRows = sumrow 20108 Btmp % InvPerm = 0 20109 Btmp % Rows(1) = 1 20110 20111 IF(TransposePresent) THEN 20112 ALLOCATE(Btmp % TValues(k2)) 20113 Btmp % Tvalues = 0._dp 20114 END IF 20115 20116 IF( SumProjectors ) THEN 20117 Btmp % Rows(sumrow0+1) = k20+1 20118 DO i=sumrow0+2,sumrow+1 20119 Btmp % Rows(i) = Btmp % Rows(i-1) + SumCount(i-1) 20120 END DO 20121 SumPerm = 0 20122 DEALLOCATE( SumCount ) 20123 END IF 20124 20125 AllocationsDone = .TRUE. 20126 20127 GOTO 100 20128 END IF 20129 20130 CALL Info(Caller,'Used '//TRIM(I2S(sumrow))//& 20131 ' rows and '//TRIM(I2S(k2))//' nonzeros',Level=7) 20132 20133 ! Eliminate entries 20134 IF( SumProjectors ) THEN 20135 CALL Info(Caller,'Number of eliminated rows: '//TRIM(I2S(EliminatedRows)),Level=6) 20136 IF( EliminatedRows > 0 ) CALL CRS_PackMatrix( Btmp ) 20137 END IF 20138 20139 IF( NeglectedRows > 0 ) THEN 20140 CALL Info(Caller,'Number of neglected rows: '//TRIM(I2S(NeglectedRows)),Level=6) 20141 END IF 20142 20143 Solver % Matrix % ConstraintMatrix => Btmp 20144 Solver % MortarBCsChanged = .FALSE. 20145 20146 CALL Info(Caller,'Finished creating constraint matrix',Level=12) 20147 20148 END SUBROUTINE GenerateConstraintMatrix 20149 20150 20151 SUBROUTINE ReleaseConstraintMatrix(Solver) 20152 TYPE(Solver_t) :: Solver 20153 20154 CALL FreeMatrix(Solver % Matrix % ConstraintMatrix) 20155 Solver % Matrix % ConstraintMatrix => NULL() 20156 20157 END SUBROUTINE ReleaseConstraintMatrix 20158 20159 20160 SUBROUTINE ReleaseProjectors(Model, Solver) 20161 20162 TYPE(Model_t) :: Model 20163 TYPE(Solver_t) :: Solver 20164 20165 TYPE(ValueList_t), POINTER :: BC 20166 TYPE(Matrix_t), POINTER :: Projector 20167 INTEGER :: i 20168 20169 20170 IF( .NOT. ASSOCIATED( Solver % MortarBCs ) ) RETURN 20171 20172 DO i=1,Model % NumberOFBCs 20173 BC => Model % BCs(i) % Values 20174 Projector => Solver % MortarBCs(i) % Projector 20175 IF( ASSOCIATED( Projector ) ) THEN 20176 IF( ASSOCIATED( Projector % EMatrix ) ) THEN 20177 CALL FreeMatrix( Projector % Ematrix ) 20178 END IF 20179 CALL FreeMatrix( Projector ) 20180 Solver % MortarBCs(i) % Projector => NULL() 20181 END IF 20182 END DO 20183 20184 END SUBROUTINE ReleaseProjectors 20185 20186 20187 !> Defines and potentially creates output directory. 20188 !> The output directory may given in different ways, and even be part of the 20189 !> filename, or be relative to home directory. We try to parse every possible 20190 !> scenario here that user might have in mind. 20191 !----------------------------------------------------------------------------- 20192 SUBROUTINE SolverOutputDirectory( Solver, Filename, OutputDirectory, & 20193 MakeDir, UseMeshDir ) 20194 20195 TYPE(Solver_t) :: Solver 20196 CHARACTER(LEN=MAX_NAME_LEN) :: Filename, OutputDirectory 20197 LOGICAL, OPTIONAL :: MakeDir, UseMeshDir 20198 20199 LOGICAL :: Found, AbsPathInName, DoDir, PartitioningSubDir 20200 INTEGER :: nd, nf, n 20201 CHARACTER(LEN=MAX_NAME_LEN) :: Str 20202 20203 IF( PRESENT( MakeDir ) ) THEN 20204 DoDir = MakeDir 20205 ELSE 20206 DoDir = ( Solver % TimesVisited == 0 ) .AND. ( ParEnv % MyPe == 0 ) 20207 END IF 20208 20209 ! Output directory is obtained in order 20210 ! 1) solver section 20211 ! 2) simulation section 20212 ! 3) header section 20213 OutputDirectory = ListGetString( Solver % Values,'Output Directory',Found) 20214 IF(.NOT. Found) OutputDirectory = ListGetString( CurrentModel % Simulation,& 20215 'Output Directory',Found) 20216 IF(.NOT. Found) OutputDirectory = TRIM(OutputPath) 20217 nd = LEN_TRIM(OutputDirectory) 20218 20219 ! If the path is just working directory then that is not an excude 20220 ! to not use the mesh name, or directory that comes with the filename 20221 IF(.NOT. Found .AND. nd == 1 .AND. OutputDirectory(1:1)=='.') nd = 0 20222 20223 ! If requested by the optional parameter use the mesh directory when 20224 ! no results directory given. This is an old convection used in some solvers. 20225 IF( nd == 0 .AND. PRESENT( UseMeshDir ) ) THEN 20226 IF( UseMeshDir ) THEN 20227 OutputDirectory = TRIM(CurrentModel % Mesh % Name) 20228 nd = LEN_TRIM(OutputDirectory) 20229 END IF 20230 END IF 20231 20232 ! Use may have given part or all of the path in the filename. 20233 ! This is not preferred, but we cannot trust the user. 20234 nf = LEN_TRIM(Filename) 20235 n = INDEX(Filename(1:nf),'/') 20236 AbsPathInName = INDEX(FileName,':')>0 .OR. (Filename(1:1)=='/') & 20237 .OR. (Filename(1:1)==Backslash) 20238 20239 IF( nd > 0 .AND. .NOT. AbsPathInName ) THEN 20240 ! Check that we have not given the path relative to home directory 20241 ! because the code does not understand the meaning of tilde. 20242 IF( OutputDirectory(1:2) == '~/') THEN 20243 CALL GETENV('HOME',Str) 20244 OutputDirectory = TRIM(Str)//'/'//OutputDirectory(3:nd) 20245 nd = LEN_TRIM(OutputDirectory) 20246 END IF 20247 ! To be on the safe side create the directory. If it already exists no harm done. 20248 ! Note that only one direcory may be created. Hence if there is a path with many subdirectories 20249 ! that will be a problem. Fortran does not have a standard ENQUIRE for directories hence 20250 ! we just try to make it. 20251 IF( DoDir ) THEN 20252 CALL Info('SolverOutputDirectory','Creating directory: '//TRIM(OutputDirectory(1:nd)),Level=8) 20253 CALL MakeDirectory( OutputDirectory(1:nd) // CHAR(0) ) 20254 END IF 20255 END IF 20256 20257 ! In this case the filename includes also path and we remove it from there and 20258 ! add it to the directory. 20259 IF( n > 2 ) THEN 20260 CALL Info('SolverOutputDirectory','Parcing path from filename: '//TRIM(Filename(1:n)),Level=10) 20261 IF( AbsPathInName .OR. nd == 0) THEN 20262 ! If the path is absolute then it overruns the given path! 20263 OutputDirectory = Filename(1:n-1) 20264 nd = n-1 20265 ELSE 20266 ! If path is relative we add it to the OutputDirectory and take it away from Filename 20267 OutputDirectory = OutputDirectory(1:nd)//'/'//Filename(1:n-1) 20268 nd = nd + n 20269 END IF 20270 Filename = Filename(n+1:nf) 20271 20272 IF( DoDir ) THEN 20273 CALL Info('SolverOutputDirectory','Creating directory: '//TRIM(OutputDirectory(1:nd)),Level=8) 20274 CALL MakeDirectory( OutputDirectory(1:nd) // CHAR(0) ) 20275 END IF 20276 END IF 20277 20278 ! Finally, on request save each partitioning to different directory. 20279 PartitioningSubDir = ListGetLogical( Solver % Values,'Output Partitioning Directory',Found) 20280 IF(.NOT. Found ) THEN 20281 PartitioningSubDir = ListGetLogical( CurrentModel % Simulation,'Output Partitioning Directory',Found) 20282 END IF 20283 IF( PartitioningSubDir ) THEN 20284 OutputDirectory = TRIM(OutputDirectory)//'/np'//TRIM(I2S(ParEnv % PEs)) 20285 nd = LEN_TRIM(OutputDirectory) 20286 IF( DoDir ) THEN 20287 CALL Info('SolverOutputDirectory','Creating directory: '//TRIM(OutputDirectory(1:nd)),Level=8) 20288 CALL MakeDirectory( OutputDirectory(1:nd) // CHAR(0) ) 20289 END IF 20290 END IF 20291 20292 END SUBROUTINE SolverOutputDirectory 20293 !----------------------------------------------------------------------------- 20294 20295 20296END MODULE SolverUtils 20297 20298!> \} 20299