1!/*****************************************************************************/ 2! * 3! * Elmer, A Finite Element Software for Multiphysical Problems 4! * 5! * Copyright 1st April 1995 - , CSC - IT Center for Science Ltd., Finland 6! * 7! * This library is free software; you can redistribute it and/or 8! * modify it under the terms of the GNU Lesser General Public 9! * License as published by the Free Software Foundation; either 10! * version 2.1 of the License, or (at your option) any later version. 11! * 12! * This library is distributed in the hope that it will be useful, 13! * but WITHOUT ANY WARRANTY; without even the implied warranty of 14! * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15! * Lesser General Public License for more details. 16! * 17! * You should have received a copy of the GNU Lesser General Public 18! * License along with this library (in file ../LGPL-2.1); if not, write 19! * to the Free Software Foundation, Inc., 51 Franklin Street, 20! * Fifth Floor, Boston, MA 02110-1301 USA 21! * 22! *****************************************************************************/ 23! 24!/****************************************************************************** 25! * 26! * Authors: Juha Ruokolainen 27! * Email: Juha.Ruokolainen@csc.fi 28! * Web: http://www.csc.fi/elmer 29! * Address: CSC - IT Center for Science Ltd. 30! * Keilaranta 14 31! * 02101 Espoo, Finland 32! * 33! * Original Date: 01 Oct 1996 34! * 35! ******************************************************************************/ 36 37!-------------------------------------------------------------------------------- 38!> Module defining element type and operations. The most basic FEM routines 39!> are here, handling the basis functions, global derivatives, etc... 40!-------------------------------------------------------------------------------- 41!> \ingroup ElmerLib 42!> \{ 43 44#include "../config.h" 45 46MODULE ElementDescription 47 USE Integration 48 USE GeneralUtils 49 USE LinearAlgebra 50 USE CoordinateSystems 51 ! Use module P element basis functions 52 USE PElementMaps 53 USE PElementBase 54 ! Vectorized P element basis functions 55 USE H1Basis 56 USE Lists 57 58 IMPLICIT NONE 59 60 INTEGER, PARAMETER,PRIVATE :: MaxDeg = 4, MaxDeg3 = MaxDeg**3, & 61 MaxDeg2 = MaxDeg**2 62 63 INTEGER, PARAMETER :: MAX_ELEMENT_NODES = 256 64 65 ! 66 ! Module global variables 67 ! 68 LOGICAL, PRIVATE :: TypeListInitialized = .FALSE. 69 TYPE(ElementType_t), PRIVATE, POINTER :: ElementTypeList 70 71 ! Local workspace for basis function values and mapping 72! REAL(KIND=dp), ALLOCATABLE, PRIVATE :: BasisWrk(:,:), dBasisdxWrk(:,:,:), & 73! LtoGMapsWrk(:,:,:), DetJWrk(:), uWrk(:), vWrk(:), wWrk(:) 74! !$OMP THREADPRIVATE(BasisWrk, dBasisdxWrk, LtoGMapsWrk, DetJWrk, uWrk, vWrk, wWrk) 75! !DIR$ ATTRIBUTES ALIGN:64::BasisWrk, dBasisdxWrk 76! !DIR$ ATTRIBUTES ALIGN:64::LtoGMapsWrk 77! !DIR$ ATTRIBUTES ALIGN:64::DetJWrk 78! !DIR$ ATTRIBUTES ALIGN:64::uWrk, vWrk, wWrk 79 80CONTAINS 81 82!------------------------------------------------------------------------------ 83 SUBROUTINE SwapRefElemNodes(p) 84!------------------------------------------------------------------------------ 85 USE PelementMaps 86!------------------------------------------------------------------------------ 87 LOGICAL :: p 88!------------------------------------------------------------------------------ 89 INTEGER :: n 90 TYPE(ElementType_t), POINTER :: et 91!------------------------------------------------------------------------------ 92 93 et => ElementTypeList 94 DO WHILE(ASSOCIATED(et)) 95 n = et % NumberOfNodes 96 97 ! Single node does not really have much options here... 98 IF( et % ElementCode < 200 ) THEN 99 CONTINUE 100 ELSE IF( p .AND. ALLOCATED(et % NodeU) ) THEN 101 IF ( .NOT.ALLOCATED(et % P_NodeU) ) THEN 102 ALLOCATE(et % P_NodeU(n), et % P_NodeV(n), et % P_NodeW(n)) 103 CALL GetRefPElementNodes( et, et % P_NodeU, et % P_NodeV, et % P_NodeW ) 104 END IF 105 et % NodeU = et % P_NodeU 106 et % NodeV = et % P_NodeV 107 et % NodeW = et % P_NodeW 108 ELSE IF ( ALLOCATED(et % N_NodeU) ) THEN 109 et % NodeU = et % N_NodeU 110 et % NodeV = et % N_NodeV 111 et % NodeW = et % N_NodeW 112 END IF 113 et => et % NextElementType 114 END DO 115!------------------------------------------------------------------------------ 116 END SUBROUTINE SwapRefElemNodes 117!------------------------------------------------------------------------------ 118 119!------------------------------------------------------------------------------ 120!> Add an element description to global list of element types. 121!------------------------------------------------------------------------------ 122 SUBROUTINE AddElementDescription( element,BasisTerms ) 123!------------------------------------------------------------------------------ 124 INTEGER, DIMENSION(:) :: BasisTerms !< List of terms in the basis function that should be included for this element type. 125 ! BasisTerms(i) is an integer from 1-27 according to the list below. 126 TYPE(ElementType_t), TARGET :: element !< Structure holding element type description 127!------------------------------------------------------------------------------ 128! Local variables 129!------------------------------------------------------------------------------ 130 TYPE(ElementType_t), POINTER :: temp 131 132 INTEGER, DIMENSION(MaxDeg3) :: s 133 INTEGER :: i,j,k,l,m,n,upow,vpow,wpow,i1,i2,ii(9),jj 134 135 REAL(KIND=dp) :: u,v,w,r 136 REAL(KIND=dp), DIMENSION(:,:), ALLOCATABLE :: A, B 137!------------------------------------------------------------------------------ 138 139! PRINT*,'Adding element type: ', element % ElementCode 140 141 n = element % NumberOfNodes 142 element % NumberOfEdges = 0 143 element % NumberOfFaces = 0 144 element % BasisFunctionDegree = 0 145 NULLIFY( element % BasisFunctions ) 146 147 IF ( element % ElementCode >= 200 ) THEN 148 149 ALLOCATE( A(n,n) ) 150 151!------------------------------------------------------------------------------ 152! 1D bar elements 153!------------------------------------------------------------------------------ 154 IF ( element % DIMENSION == 1 ) THEN 155 156 DO i = 1,n 157 u = element % NodeU(i) 158 DO j = 1,n 159 k = BasisTerms(j) - 1 160 upow = k 161 IF ( u==0 .AND. upow == 0 ) THEN 162 A(i,j) = 1 163 ELSE 164 A(i,j) = u**upow 165 END IF 166 element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,upow) 167 END DO 168 END DO 169 170! ALLOCATE( element % BasisFunctions(MaxDeg,MaxDeg) ) 171 172!------------------------------------------------------------------------------ 173! 2D surface elements 174!------------------------------------------------------------------------------ 175 ELSE IF ( element % DIMENSION == 2 ) THEN 176 177 DO i = 1,n 178 u = element % NodeU(i) 179 v = element % NodeV(i) 180 DO j = 1,n 181 k = BasisTerms(j) - 1 182 vpow = k / MaxDeg 183 upow = MOD(k,MaxDeg) 184 185 IF ( upow == 0 ) THEN 186 A(i,j) = 1 187 ELSE 188 A(i,j) = u**upow 189 END IF 190 191 IF ( vpow /= 0 ) THEN 192 A(i,j) = A(i,j) * v**vpow 193 END IF 194 195 element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,upow) 196 element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,vpow) 197 END DO 198 END DO 199 200! ALLOCATE( element % BasisFunctions(MaxDeg2,MaxDeg2) ) 201 202!------------------------------------------------------------------------------ 203! 3D volume elements 204!------------------------------------------------------------------------------ 205 ELSE 206 207 DO i = 1,n 208 u = element % NodeU(i) 209 v = element % NodeV(i) 210 w = element % NodeW(i) 211 DO j = 1,n 212 k = BasisTerms(j) - 1 213 upow = MOD( k,MaxDeg ) 214 wpow = k / MaxDeg2 215 vpow = MOD( k / MaxDeg, MaxDeg ) 216 217 IF ( upow == 0 ) THEN 218 A(i,j) = 1 219 ELSE 220 A(i,j) = u**upow 221 END IF 222 223 IF ( vpow /= 0 ) THEN 224 A(i,j) = A(i,j) * v**vpow 225 END IF 226 227 IF ( wpow /= 0 ) THEN 228 A(i,j) = A(i,j) * w**wpow 229 END IF 230 231 element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,upow) 232 element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,vpow) 233 element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,wpow) 234 END DO 235 END DO 236 237! ALLOCATE( element % BasisFunctions(MaxDeg3,MaxDeg3) ) 238 END IF 239 240!------------------------------------------------------------------------------ 241! Compute the coefficients of the basis function terms 242!------------------------------------------------------------------------------ 243 CALL InvertMatrix( A,n ) 244 245 IF ( Element % ElementCode == 202 ) THEN 246 ALLOCATE( Element % BasisFunctions(14) ) 247 ELSE 248 ALLOCATE( Element % BasisFunctions(n) ) 249 END IF 250 251 upow = 0 252 vpow = 0 253 wpow = 0 254 255 DO i = 1,n 256 Element % BasisFunctions(i) % n = n 257 ALLOCATE( Element % BasisFunctions(i) % p(n) ) 258 ALLOCATE( Element % BasisFunctions(i) % q(n) ) 259 ALLOCATE( Element % BasisFunctions(i) % r(n) ) 260 ALLOCATE( Element % BasisFunctions(i) % Coeff(n) ) 261 262 DO j = 1,n 263 k = BasisTerms(j) - 1 264 265 SELECT CASE( Element % DIMENSION ) 266 CASE(1) 267 upow = k 268 CASE(2) 269 vpow = k / MaxDeg 270 upow = MOD(k,MaxDeg) 271 CASE(3) 272 upow = MOD( k,MaxDeg ) 273 wpow = k / MaxDeg2 274 vpow = MOD( k / MaxDeg, MaxDeg ) 275 END SELECT 276 277 Element % BasisFunctions(i) % p(j) = upow 278 Element % BasisFunctions(i) % q(j) = vpow 279 Element % BasisFunctions(i) % r(j) = wpow 280 Element % BasisFunctions(i) % Coeff(j) = A(j,i) 281 END DO 282 END DO 283 284 DEALLOCATE( A ) 285 286 IF ( Element % ElementCode == 202 ) THEN 287 ALLOCATE( A(14,14) ) 288 A = 0 289 CALL Compute1DPBasis( A,14 ) 290 291 DO i=3,14 292 ALLOCATE( Element % BasisFunctions(i) % p(i) ) 293 ALLOCATE( Element % BasisFunctions(i) % q(i) ) 294 ALLOCATE( Element % BasisFunctions(i) % r(i) ) 295 ALLOCATE( Element % BasisFunctions(i) % Coeff(i) ) 296 297 k = 0 298 DO j=1,i 299 IF ( A(i,j) /= 0.0d0 ) THEN 300 k = k + 1 301 Element % BasisFunctions(i) % p(k) = j-1 302 Element % BasisFunctions(i) % q(k) = 0 303 Element % BasisFunctions(i) % r(k) = 0 304 Element % BasisFunctions(i) % Coeff(k) = A(i,j) 305 END IF 306 END DO 307 Element % BasisFunctions(i) % n = k 308 END DO 309 DEALLOCATE( A ) 310 END IF 311 312!------------------------------------------------------------------------------ 313 314 SELECT CASE( Element % ElementCode / 100 ) 315 CASE(3) 316 Element % NumberOfEdges = 3 317 CASE(4) 318 Element % NumberOfEdges = 4 319 CASE(5) 320 Element % NumberOfFaces = 4 321 Element % NumberOfEdges = 6 322 CASE(6) 323 Element % NumberOfFaces = 5 324 Element % NumberOfEdges = 8 325 CASE(7) 326 Element % NumberOfFaces = 5 327 Element % NumberOfEdges = 9 328 CASE(8) 329 Element % NumberOfFaces = 6 330 Element % NumberOfEdges = 12 331 END SELECT 332 333 END IF ! type >= 200 334 335!------------------------------------------------------------------------------ 336! And finally add the element description to the global list of types 337!------------------------------------------------------------------------------ 338 IF ( .NOT.TypeListInitialized ) THEN 339 ALLOCATE( ElementTypeList ) 340 ElementTypeList = element 341 TypeListInitialized = .TRUE. 342 NULLIFY( ElementTypeList % NextElementType ) 343 ELSE 344 ALLOCATE( temp ) 345 temp = element 346 temp % NextElementType => ElementTypeList 347 ElementTypeList => temp 348 END IF 349 350!------------------------------------------------------------------------------ 351 352CONTAINS 353 354 355!------------------------------------------------------------------------------ 356!> Subroutine to compute 1D P-basis from Legendre polynomials. 357!------------------------------------------------------------------------------ 358 SUBROUTINE Compute1DPBasis( Basis,n ) 359!------------------------------------------------------------------------------ 360 INTEGER :: n 361 REAL(KIND=dp) :: Basis(:,:) 362!------------------------------------------------------------------------------ 363 REAL(KIND=dp) :: s,P(n+1),Q(n),P0(n),P1(n+1) 364 INTEGER :: i,j,k,np,info 365 366!------------------------------------------------------------------------------ 367 368 IF ( n <= 1 ) THEN 369 Basis(1,1) = 1.0d0 370 RETURN 371 END IF 372!------------------------------------------------------------------------------ 373! Compute coefficients of n:th Legendre polynomial from the recurrence: 374! 375! (i+1)P_{i+1}(x) = (2i+1)*x*P_i(x) - i*P_{i-1}(x), P_{0} = 1; P_{1} = x; 376! 377! CAVEAT: Computed coefficients inaccurate for n > ~15 378!------------------------------------------------------------------------------ 379 P = 0 380 P0 = 0 381 P1 = 0 382 P0(1) = 1 383 P1(1) = 1 384 P1(2) = 0 385 386 Basis(1,1) = 0.5d0 387 Basis(1,2) = -0.5d0 388 389 Basis(2,1) = 0.5d0 390 Basis(2,2) = 0.5d0 391 392 DO k=2,n 393 IF ( k > 2 ) THEN 394 s = SQRT( (2.0d0*(k-1)-1) / 2.0d0 ) 395 DO j=1,k-1 396 Basis(k,k-j+1) = s * P0(j) / (k-j) 397 Basis(k,1) = Basis(k,1) - s * P0(j)*(-1)**(j+1) / (k-j) 398 END DO 399 END IF 400 401 i = k - 1 402 P(1:i+1) = (2*i+1) * P1(1:i+1) / (i+1) 403 P(3:i+2) = P(3:i+2) - i*P0(1:i) / (i+1) 404 P0(1:i+1) = P1(1:i+1) 405 P1(1:i+2) = P(1:i+2) 406 END DO 407!-------------------------------------------------------------------------- 408 END SUBROUTINE Compute1DPBasis 409!-------------------------------------------------------------------------- 410 411 END SUBROUTINE AddElementDescription 412!------------------------------------------------------------------------------ 413 414 415 416!------------------------------------------------------------------------------ 417!> Read the element description input file and add the element types to a 418!> global list. The file is assumed to be found under the name 419!> $ELMER_HOME/lib/elements.def 420!> This is the first routine the user of the element utilities should call 421!> in his/her code. 422!------------------------------------------------------------------------------ 423 SUBROUTINE InitializeElementDescriptions() 424!------------------------------------------------------------------------------ 425! Local variables 426!------------------------------------------------------------------------------ 427 CHARACTER(LEN=:), ALLOCATABLE :: str 428 CHARACTER(LEN=MAX_STRING_LEN) :: tstr,elmer_home 429 430 INTEGER :: k, n 431 INTEGER, DIMENSION(MaxDeg3) :: BasisTerms 432 433 TYPE(ElementType_t) :: element 434 435 LOGICAL :: gotit, fexist 436!------------------------------------------------------------------------------ 437! PRINT*,' ' 438! PRINT*,'----------------------------------------------' 439! PRINT*,'Reading element definition file: elements.def' 440! PRINT*,'----------------------------------------------' 441 442 ! 443 ! Add connectivity element types: 444 ! ------------------------------- 445 BasisTerms = 0 446 element % GaussPoints = 0 447 element % GaussPoints0 = 0 448 element % GaussPoints2 = 0 449 element % StabilizationMK = 0 450 DO k=3,64 451 element % NumberOfNodes = k 452 element % ElementCode = 100 + k 453 CALL AddElementDescription( element,BasisTerms ) 454 END DO 455 456 ! then the rest of them.... 457 !-------------------------- 458 tstr = 'ELMER_LIB' 459 CALL envir( tstr,elmer_home,k ) 460 461 fexist = .FALSE. 462 IF ( k > 0 ) THEN 463 WRITE( tstr, '(a,a)' ) elmer_home(1:k),'/elements.def' 464 INQUIRE(FILE=TRIM(tstr), EXIST=fexist) 465 END IF 466 IF (.NOT. fexist) THEN 467 tstr = 'ELMER_HOME' 468 CALL envir( tstr,elmer_home,k ) 469 IF ( k > 0 ) THEN 470 WRITE( tstr, '(a,a)' ) elmer_home(1:k),& 471'/share/elmersolver/lib/elements.def' 472 INQUIRE(FILE=TRIM(tstr), EXIST=fexist) 473 END IF 474 IF ((.NOT. fexist) .AND. k > 0) THEN 475 WRITE( tstr, '(a,a)' ) elmer_home(1:k),& 476 '/elements.def' 477 INQUIRE(FILE=TRIM(tstr), EXIST=fexist) 478 END IF 479 END IF 480 IF (.NOT. fexist) THEN 481 CALL GetSolverHome(elmer_home, n) 482 WRITE(tstr, '(a,a)') elmer_home(1:n), & 483 '/lib/elements.def' 484 INQUIRE(FILE=TRIM(tstr), EXIST=fexist) 485 END IF 486 IF (.NOT. fexist) THEN 487 CALL Fatal('InitializeElementDescriptions', & 488 'elements.def not found') 489 END IF 490 491 OPEN( 1,FILE=TRIM(tstr), STATUS='OLD' ) 492 493 ALLOCATE(CHARACTER(MAX_STRING_LEN)::str) 494 DO WHILE( ReadAndTrim(1,str) ) 495 496 IF ( SEQL(str, 'element') ) THEN 497 498 BasisTerms = 0 499 500 gotit = .FALSE. 501 DO WHILE( ReadAndTrim(1,str) ) 502 503 IF ( SEQL(str, 'dimension') ) THEN 504 READ( str(10:), * ) element % DIMENSION 505 506 ELSE IF ( SEQL(str, 'code') ) THEN 507 READ( str(5:), * ) element % ElementCode 508 509 ELSE IF ( SEQL(str, 'nodes') ) THEN 510 READ( str(6:), * ) element % NumberOfNodes 511 512 ELSE IF ( SEQL(str, 'node u') ) THEN 513 ALLOCATE( element % NodeU(element % NumberOfNodes) ) 514 READ( str(7:), * ) (element % NodeU(k),k=1,element % NumberOfNodes) 515 516 ELSE IF ( SEQL(str, 'node v') ) THEN 517 ALLOCATE( element % NodeV(element % NumberOfNodes) ) 518 READ( str(7:), * ) (element % NodeV(k),k=1,element % NumberOfNodes) 519 520 ELSE IF ( SEQL(str, 'node w') ) THEN 521 ALLOCATE( element % NodeW(element % NumberOfNodes ) ) 522 READ( str(7:), * ) (element % NodeW(k),k=1,element % NumberOfNodes) 523 524 ELSE IF ( SEQL(str, 'basis') ) THEN 525 READ( str(6:), * ) (BasisTerms(k),k=1,element % NumberOfNodes) 526 527 ELSE IF ( SEQL(str, 'stabilization') ) THEN 528 READ( str(14:), * ) element % StabilizationMK 529 530 ELSE IF ( SEQL(str, 'gauss points') ) THEN 531 532 Element % GaussPoints2 = 0 533 READ( str(13:), *,END=10 ) element % GaussPoints,& 534 element % GaussPoints2, element % GaussPoints0 535 53610 CONTINUE 537 538 IF ( Element % GaussPoints2 <= 0 ) & 539 Element % GaussPoints2 = Element % GaussPoints 540 541 IF ( Element % GaussPoints0 <= 0 ) & 542 Element % GaussPoints0 = Element % GaussPoints 543 544 ELSE IF ( str == 'end element' ) THEN 545 gotit = .TRUE. 546 EXIT 547 END IF 548 END DO 549 550 IF ( gotit ) THEN 551 Element % StabilizationMK = 0.0d0 552 IF ( .NOT.ALLOCATED( element % NodeV ) ) THEN 553 ALLOCATE( element % NodeV(element % NumberOfNodes) ) 554 element % NodeV = 0.0d0 555 END IF 556 557 IF ( .NOT.ALLOCATED( element % NodeW ) ) THEN 558 ALLOCATE( element % NodeW(element % NumberOfNodes) ) 559 element % NodeW = 0.0d0 560 END IF 561 562 CALL AddElementDescription( element,BasisTerms ) 563 IF ( ALLOCATED( element % NodeU ) ) DEALLOCATE( element % NodeU ) 564 IF ( ALLOCATED( element % NodeV ) ) DEALLOCATE( element % NodeV ) 565 IF ( ALLOCATED( element % NodeW ) ) DEALLOCATE( element % NodeW ) 566 ELSE 567 IF ( ALLOCATED( element % NodeU ) ) DEALLOCATE( element % NodeU ) 568 IF ( ALLOCATED( element % NodeV ) ) DEALLOCATE( element % NodeV ) 569 IF ( ALLOCATED( element % NodeW ) ) DEALLOCATE( element % NodeW ) 570 END IF 571 END IF 572 END DO 573 574 CLOSE(1) 575!------------------------------------------------------------------------------ 576 END SUBROUTINE InitializeElementDescriptions 577!------------------------------------------------------------------------------ 578 579 580 581!------------------------------------------------------------------------------ 582!> Given element type code return pointer to the corresponding element type 583!> structure. 584!------------------------------------------------------------------------------ 585 FUNCTION GetElementType( code,CompStabFlag ) RESULT(element) 586!------------------------------------------------------------------------------ 587 INTEGER :: code 588 LOGICAL, OPTIONAL :: CompStabFlag 589 TYPE(ElementType_t), POINTER :: element 590!------------------------------------------------------------------------------ 591! Local variables 592!------------------------------------------------------------------------------ 593 TYPE(Nodes_t) :: Nodes 594 INTEGER :: sdim 595 TYPE(Element_t), POINTER :: Elm 596!------------------------------------------------------------------------------ 597 element => ElementTypeList 598 599 DO WHILE( ASSOCIATED(element) ) 600 IF ( code == element % ElementCode ) EXIT 601 element => element % NextElementType 602 END DO 603 604 IF ( .NOT. ASSOCIATED( element ) ) THEN 605 WRITE( message, * ) & 606 'Element type code ',code,' not found. Ignoring element.' 607 CALL Warn( 'GetElementType', message ) 608 RETURN 609 END IF 610 611 IF ( PRESENT( CompStabFlag ) ) THEN 612 IF ( .NOT. CompStabFlag ) RETURN 613 END IF 614 615 IF ( Element % StabilizationMK == 0.0d0 ) THEN 616 ALLOCATE( Elm ) 617 Elm % TYPE => element 618 Elm % BDOFs = 0 619 Elm % DGDOFs = 0 620 NULLIFY( Elm % PDefs ) 621 NULLIFY( Elm % DGIndexes ) 622 NULLIFY( Elm % EdgeIndexes ) 623 NULLIFY( Elm % FaceIndexes ) 624 NULLIFY( Elm % BubbleIndexes ) 625 Nodes % x => Element % NodeU 626 Nodes % y => Element % NodeV 627 Nodes % z => Element % NodeW 628 629 sdim = CurrentModel % Dimension 630 CurrentModel % Dimension = Element % Dimension 631 CALL StabParam( Elm, Nodes, Element % NumberOfNodes, & 632 Element % StabilizationMK ) 633 CurrentModel % Dimension = sdim 634 635 DEALLOCATE(Elm) 636 END IF 637 638 END FUNCTION GetElementType 639!------------------------------------------------------------------------------ 640 641 642!------------------------------------------------------------------------------ 643!> Compute convection diffusion equation stab. parameter for each and every 644!> element of the model by solving the largest eigenvalue of 645! 646!> Lu = \lambda Gu, 647! 648!> L = (\nablda^2 u,\nabla^ w), G = (\nabla u,\nabla w) 649!------------------------------------------------------------------------------ 650 SUBROUTINE StabParam(Element,Nodes,n,mK,hK,UseLongEdge) 651!------------------------------------------------------------------------------ 652 IMPLICIT NONE 653 654 TYPE(Element_t), POINTER :: Element 655 INTEGER :: n 656 TYPE(Nodes_t) :: Nodes 657 REAL(KIND=dp) :: mK 658 REAL(KIND=dp), OPTIONAL :: hK 659 LOGICAL, OPTIONAL :: UseLongEdge 660!------------------------------------------------------------------------------ 661 INTEGER :: info,p,q,i,j,t,dim 662 REAL(KIND=dp) :: EIGR(n),EIGI(n),Beta(n),s,ddp(3),ddq(3),dNodalBasisdx(n,n,3) 663 REAL(KIND=dp) :: u,v,w,L(n-1,n-1),G(n-1,n-1),Work(16*n) 664 REAL(KIND=dp) :: Basis(n),dBasisdx(n,3),ddBasisddx(n,3,3),detJ 665 666 LOGICAL :: stat 667 TYPE(GaussIntegrationPoints_t) :: IntegStuff 668 669 IF ( Element % TYPE % BasisFunctionDegree <= 1 ) THEN 670 SELECT CASE( Element % TYPE % ElementCode ) 671 CASE( 202, 303, 404, 504, 605, 706 ) 672 mK = 1.0d0 / 3.0d0 673 CASE( 808 ) 674 mK = 1.0d0 / 6.0d0 675 END SELECT 676 IF ( PRESENT( hK ) ) hK = ElementDiameter( Element, Nodes, UseLongEdge) 677 RETURN 678 END IF 679 680 dNodalBasisdx = 0._dp 681 DO p=1,n 682 u = Element % TYPE % NodeU(p) 683 v = Element % TYPE % NodeV(p) 684 w = Element % TYPE % NodeW(p) 685 stat = ElementInfo( Element, Nodes, u,v,w, detJ, Basis, dBasisdx ) 686 dNodalBasisdx(1:n,p,:) = dBasisdx(1:n,:) 687 END DO 688 689 dim = CoordinateSystemDimension() 690 IntegStuff = GaussPoints( Element ) 691 L = 0.0d0 692 G = 0.0d0 693 DO t=1,IntegStuff % n 694 u = IntegStuff % u(t) 695 v = IntegStuff % v(t) 696 w = IntegStuff % w(t) 697 698 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis, & 699 dBasisdx ) 700 701 s = detJ * IntegStuff % s(t) 702 703 DO p=2,n 704 DO q=2,n 705 ddp = 0.0d0 706 ddq = 0.0d0 707 DO i=1,dim 708 G(p-1,q-1) = G(p-1,q-1) + s * dBasisdx(p,i) * dBasisdx(q,i) 709 ddp(i) = ddp(i) + SUM( dNodalBasisdx(p,1:n,i) * dBasisdx(1:n,i) ) 710 ddq(i) = ddq(i) + SUM( dNodalBasisdx(q,1:n,i) * dBasisdx(1:n,i) ) 711 END DO 712 L(p-1,q-1) = L(p-1,q-1) + s * SUM(ddp) * SUM(ddq) 713 END DO 714 END DO 715 END DO 716 717 IF ( ALL(ABS(L) < AEPS) ) THEN 718 mK = 1.0d0 / 3.0d0 719 IF ( PRESENT(hK) ) THEN 720 hK = ElementDiameter( Element,Nodes,UseLongEdge) 721 END IF 722 RETURN 723 END IF 724 725 726 CALL DSYGV( 1,'N','U',n-1,L,n-1,G,n-1,EIGR,Work,12*n,info ) 727 mK = EIGR(n-1) 728 729 IF ( mK < 10*AEPS ) THEN 730 mK = 1.0d0 / 3.0d0 731 IF ( PRESENT(hK) ) THEN 732 hK = ElementDiameter( Element,Nodes,UseLongEdge ) 733 END IF 734 RETURN 735 END IF 736 737 IF ( PRESENT( hK ) ) THEN 738 hK = SQRT( 2.0d0 / (mK * Element % TYPE % StabilizationMK) ) 739 mK = MIN( 1.0d0 / 3.0d0, Element % TYPE % StabilizationMK ) 740 ELSE 741 SELECT CASE(Element % TYPE % ElementCode / 100) 742 CASE(2,4,8) 743 mK = 4 * mK 744 END SELECT 745 mK = MIN( 1.0d0/3.0d0, 2/mK ) 746 END IF 747 748!------------------------------------------------------------------------------ 749 END SUBROUTINE StabParam 750!------------------------------------------------------------------------------ 751 752 753!------------------------------------------------------------------------------ 754!> Given element structure return value of a quantity x given at element nodes 755!> at local coordinate point u inside the element. Element basis functions are 756!> used to compute the value. This is for 1D elements, and shouldn't probably 757!> be called directly by the user but through the wrapper routine 758!> InterpolateInElement. 759!------------------------------------------------------------------------------ 760 FUNCTION InterpolateInElement1D( element,x,u ) RESULT(y) 761!------------------------------------------------------------------------------ 762 TYPE(Element_t) :: element !< element structure 763 REAL(KIND=dp) :: u !< Point at which to evaluate the value 764 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity whose value we want to know 765 REAL(KIND=dp) :: y !< value of the quantity y = x(u) 766!------------------------------------------------------------------------------ 767! Local variables 768!------------------------------------------------------------------------------ 769 REAL(KIND=dp) :: s 770 INTEGER :: i,j,k,n 771 TYPE(ElementType_t), POINTER :: elt 772 REAL(KIND=dp), POINTER :: Coeff(:) 773 INTEGER, POINTER :: p(:) 774 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 775!------------------------------------------------------------------------------ 776 777 elt => element % TYPE 778 k = Elt % NumberOfNodes 779 BasisFunctions => elt % BasisFunctions 780 781 y = 0.0d0 782 DO n=1,k 783 IF ( x(n) /= 0.0d0 ) THEN 784 p => BasisFunctions(n) % p 785 Coeff => BasisFunctions(n) % Coeff 786 787 s = 0.0d0 788 DO i=1,BasisFunctions(n) % n 789 IF (p(i)==0) THEN 790 s = s + Coeff(i) 791 ELSE 792 s = s + Coeff(i) * u**p(i) 793 END if 794 END DO 795 y = y + s * x(n) 796 END IF 797 END DO 798 END FUNCTION InterpolateInElement1D 799!------------------------------------------------------------------------------ 800 801 802!------------------------------------------------------------------------------ 803 SUBROUTINE NodalBasisFunctions1D( y,element,u ) 804!------------------------------------------------------------------------------ 805 TYPE(Element_t) :: element !< element structure 806 REAL(KIND=dp) :: u !< Point at which to evaluate the value 807 REAL(KIND=dp) :: y(:) !< value of the quantity y = x(u) 808 809!------------------------------------------------------------------------------ 810! Local variables 811!------------------------------------------------------------------------------ 812 REAL(KIND=dp) :: s 813 INTEGER :: i,n 814 TYPE(ElementType_t), POINTER :: elt 815 REAL(KIND=dp), POINTER :: Coeff(:) 816 INTEGER, POINTER :: p(:) 817 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 818!------------------------------------------------------------------------------ 819 820 elt => element % TYPE 821 BasisFunctions => elt % BasisFunctions 822 823 DO n=1,Elt % NumberOfNodes 824 p => BasisFunctions(n) % p 825 Coeff => BasisFunctions(n) % Coeff 826 827 s = 0.0d0 828 DO i=1,BasisFunctions(n) % n 829 IF (p(i)==0) THEN 830 s = s + Coeff(i) 831 ELSE 832 s = s + Coeff(i) * u**p(i) 833 END if 834 END DO 835 y(n) = s 836 END DO 837 END SUBROUTINE NodalBasisFunctions1D 838!------------------------------------------------------------------------------ 839 840 841 842!------------------------------------------------------------------------------ 843!> Given element structure return value of the first partial derivative with 844!> respect to local coordinate of a quantity x given at element nodes at local 845!> coordinate point u inside the element. Element basis functions are used to 846!> compute the value. 847!------------------------------------------------------------------------------ 848 FUNCTION FirstDerivative1D( element,x,u ) RESULT(y) 849!------------------------------------------------------------------------------ 850 TYPE(Element_t) :: element !< element structure 851 REAL(KIND=dp) :: u !< Point at which to evaluate the partial derivative 852 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity whose partial derivative we want to know 853 REAL(KIND=dp) :: y !< value of the quantity y = @x/@u 854!------------------------------------------------------------------------------ 855! Local variables 856!------------------------------------------------------------------------------ 857 INTEGER :: i,j,k,n,l 858 TYPE(ElementType_t), POINTER :: elt 859 REAL(KIND=dp) :: s 860 REAL(KIND=dp), POINTER :: Coeff(:) 861 INTEGER, POINTER :: p(:) 862 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 863 864 elt => element % TYPE 865 k = Elt % NumberOfNodes 866 BasisFunctions => elt % BasisFunctions 867 868 y = 0.0d0 869 DO n=1,k 870 IF ( x(n) /= 0.0d0 ) THEN 871 p => BasisFunctions(n) % p 872 Coeff => BasisFunctions(n) % Coeff 873 874 s = 0.0d0 875 DO i=1,BasisFunctions(n) % n 876 IF ( p(i) >= 1 ) THEN 877 s = s + p(i) * Coeff(i) * u**(p(i)-1) 878 END IF 879 END DO 880 y = y + s * x(n) 881 END IF 882 END DO 883 END FUNCTION FirstDerivative1D 884!------------------------------------------------------------------------------ 885 886 887!------------------------------------------------------------------------------ 888 SUBROUTINE NodalFirstDerivatives1D( y,element,u ) 889!------------------------------------------------------------------------------ 890 REAL(KIND=dp) :: u !< Point at which to evaluate the partial derivative 891 REAL(KIND=dp) :: y(:,:) !< value of the quantity y = @x/@u 892 TYPE(Element_t) :: element !< element structure 893!------------------------------------------------------------------------------ 894! Local variables 895!------------------------------------------------------------------------------ 896 TYPE(ElementType_t), POINTER :: elt 897 INTEGER :: i,n 898 REAL(KIND=dp) :: s 899 900 REAL(KIND=dp), POINTER :: Coeff(:) 901 INTEGER, POINTER :: p(:) 902 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 903 904 elt => element % TYPE 905 BasisFunctions => elt % BasisFunctions 906 907 DO n=1, Elt % NumberOfNodes 908 p => BasisFunctions(n) % p 909 Coeff => BasisFunctions(n) % Coeff 910 911 s = 0.0d0 912 DO i=1,BasisFunctions(n) % n 913 IF (p(i)>=1) s = s + p(i)*Coeff(i)*u**(p(i)-1) 914 END DO 915 y(n,1) = s 916 END DO 917 END SUBROUTINE NodalFirstDerivatives1D 918!------------------------------------------------------------------------------ 919 920 921 922!------------------------------------------------------------------------------ 923!> Given element structure return value of the second partial derivative with 924!> respect to local coordinate of a quantity x given at element nodes at local 925!> coordinate point u inside the element. Element basis functions are used to 926!> compute the value. 927!------------------------------------------------------------------------------ 928 FUNCTION SecondDerivatives1D( element,x,u ) RESULT(y) 929!------------------------------------------------------------------------------ 930 TYPE(Element_t) :: element !< element structure 931 REAL(KIND=dp) :: u !< Point at which to evaluate the partial derivative 932 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity whose partial derivative we want to know 933 REAL(KIND=dp) :: y !< value of the quantity y = @x/@u 934!------------------------------------------------------------------------------ 935! Local variables 936!------------------------------------------------------------------------------ 937 REAL(KIND=dp) :: usum 938 INTEGER :: i,j,k,n 939 TYPE(ElementType_t), POINTER :: elt 940 INTEGER, POINTER :: p(:),q(:) 941 REAL(KIND=dp), POINTER :: Coeff(:) 942 REAL(KIND=dp) :: s 943 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 944 945 elt => element % TYPE 946 k = Elt % NumberOfNodes 947 BasisFunctions => elt % BasisFunctions 948 949 y = 0.0d0 950 DO n=1,k 951 IF ( x(n) /= 0.0d0 ) THEN 952 p => BasisFunctions(n) % p 953 Coeff => BasisFunctions(n) % Coeff 954 955 s = 0.0d0 956 DO i=1,BasisFunctions(n) % n 957 IF ( p(i) >= 2 ) THEN 958 s = s + p(i) * (p(i)-1) * Coeff(i) * u**(p(i)-2) 959 END IF 960 END DO 961 y = y + s * x(n) 962 END IF 963 END DO 964 END FUNCTION SecondDerivatives1D 965!------------------------------------------------------------------------------ 966 967 968 969!------------------------------------------------------------------------------ 970!> Given element structure return the value of a quantity x known at element nodes 971!> at local coordinate point (u,v) inside the element. Element basis functions 972!> are used to compute the value. This is for 2D elements, and shouldn't probably 973!> be called directly by the user but through the wrapper routine 974!> InterpolateInElement. 975!------------------------------------------------------------------------------ 976 FUNCTION InterpolateInElement2D( element,x,u,v ) RESULT(y) 977!------------------------------------------------------------------------------ 978 TYPE(Element_t) :: element !< element structure 979 REAL(KIND=dp) :: u !< u at the point where the quantity is evaluated 980 REAL(KIND=dp) :: v !< v at the point where the quantity is evaluated 981 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity 982 REAL(KIND=dp) :: y !< The value of the quantity y = x(u,v) 983!------------------------------------------------------------------------------ 984! Local variables 985!------------------------------------------------------------------------------ 986 REAL(KIND=dp) :: s,t 987 988 INTEGER :: i,j,k,m,n 989 990 TYPE(ElementType_t),POINTER :: elt 991 REAL(KIND=dp), POINTER :: Coeff(:) 992 INTEGER, POINTER :: p(:),q(:) 993 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 994!------------------------------------------------------------------------------ 995 996 elt => element % TYPE 997 BasisFunctions => elt % BasisFunctions 998 999 y = 0.0d0 1000 DO n = 1,elt % NumberOfNodes 1001 IF ( x(n) /= 0.0d0 ) THEN 1002 p => BasisFunctions(n) % p 1003 q => BasisFunctions(n) % q 1004 Coeff => BasisFunctions(n) % Coeff 1005 1006 s = 0.0d0 1007 DO i = 1,BasisFunctions(n) % n 1008 s = s + Coeff(i) * u**p(i) * v**q(i) 1009 END DO 1010 y = y + s*x(n) 1011 END IF 1012 END DO 1013 1014 END FUNCTION InterpolateInElement2D 1015!------------------------------------------------------------------------------ 1016 1017 1018!------------------------------------------------------------------------------ 1019 SUBROUTINE NodalBasisFunctions2D( y,element,u,v ) 1020!------------------------------------------------------------------------------ 1021 REAL(KIND=dp) :: y(:) !< The values of the reference element basis 1022 TYPE(Element_t) :: element !< element structure 1023 REAL(KIND=dp) :: u !< Point at which to evaluate the value 1024 REAL(KIND=dp) :: v !< Point at which to evaluate the value 1025!------------------------------------------------------------------------------ 1026! Local variables 1027!------------------------------------------------------------------------------ 1028 REAL(KIND=dp) :: s 1029 INTEGER :: i,n 1030 TYPE(ElementType_t), POINTER :: elt 1031 REAL(KIND=dp), POINTER :: Coeff(:) 1032 INTEGER, POINTER :: p(:),q(:) 1033 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1034!------------------------------------------------------------------------------ 1035 REAL(KIND=dp) :: ult(0:6), vlt(0:6) 1036 1037 elt => element % TYPE 1038 BasisFunctions => elt % BasisFunctions 1039 1040 ult(0) = 1 1041 ult(1) = u 1042 1043 vlt(0) = 1 1044 vlt(1) = v 1045 1046 DO i=2,elt % BasisFunctionDegree 1047 ult(i) = u**i 1048 vlt(i) = v**i 1049 END DO 1050 1051 DO n=1,Elt % NumberOfNodes 1052 p => BasisFunctions(n) % p 1053 q => BasisFunctions(n) % q 1054 Coeff => BasisFunctions(n) % Coeff 1055 1056 s = 0.0d0 1057 DO i=1,BasisFunctions(n) % n 1058 s = s + Coeff(i)*ult(p(i))*vlt(q(i)) 1059 END DO 1060 y(n) = s 1061 END DO 1062 END SUBROUTINE NodalBasisFunctions2D 1063!------------------------------------------------------------------------------ 1064 1065 1066 1067!------------------------------------------------------------------------------ 1068!> Given element structure return the value of the first partial derivative with 1069!> respect to local coordinate u of a quantity x given at element nodes at local 1070!> coordinate point u,v inside the element. Element basis functions are used to 1071!> compute the value. 1072!------------------------------------------------------------------------------ 1073 FUNCTION FirstDerivativeInU2D( element,x,u,v ) RESULT(y) 1074!------------------------------------------------------------------------------ 1075 TYPE(Element_t) :: element !< element structure 1076 REAL(KIND=dp) :: u,v !< Point at which to evaluate the partial derivative 1077 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to derivate 1078 REAL(KIND=dp) :: y !< value of the quantity y = @x(u,v)/@u 1079!------------------------------------------------------------------------------ 1080! Local variables 1081!------------------------------------------------------------------------------ 1082 REAL(KIND=dp) :: s,t 1083 TYPE(ElementType_t),POINTER :: elt 1084 REAL(KIND=dp), POINTER :: Coeff(:) 1085 INTEGER, POINTER :: p(:),q(:) 1086 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1087 INTEGER :: i,j,k,m,n 1088 1089 elt => element % TYPE 1090 BasisFunctions => elt % BasisFunctions 1091 1092 y = 0.0d0 1093 DO n = 1,elt % NumberOfNodes 1094 IF ( x(n) /= 0.0d0 ) THEN 1095 p => BasisFunctions(n) % p 1096 q => BasisFunctions(n) % q 1097 Coeff => BasisFunctions(n) % Coeff 1098 1099 s = 0.0d0 1100 DO i = 1,BasisFunctions(n) % n 1101 IF ( p(i) >= 1 ) THEN 1102 s = s + p(i) * Coeff(i) * u**(p(i)-1) * v**q(i) 1103 END IF 1104 END DO 1105 y = y + s*x(n) 1106 END IF 1107 END DO 1108 1109 END FUNCTION FirstDerivativeInU2D 1110!------------------------------------------------------------------------------ 1111 1112 1113 1114!------------------------------------------------------------------------------ 1115!> Given element structure return value of the first partial derivative with 1116!> respect to local coordinate v of i quantity x given at element nodes at local 1117!> coordinate point u,v inside the element. Element basis functions are used to 1118!> compute the value. 1119!------------------------------------------------------------------------------ 1120 FUNCTION FirstDerivativeInV2D( element,x,u,v ) RESULT(y) 1121!------------------------------------------------------------------------------ 1122 TYPE(Element_t) :: element !< element structure 1123 REAL(KIND=dp) :: u,v !< Point at which to evaluate the partial derivative 1124 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to derivate 1125 REAL(KIND=dp) :: y !< value of the quantity y = @x(u,v)/@u 1126!------------------------------------------------------------------------------ 1127! Local variables 1128!------------------------------------------------------------------------------ 1129 REAL(KIND=dp) :: s,t 1130 TYPE(ElementType_t),POINTER :: elt 1131 REAL(KIND=dp), POINTER :: Coeff(:) 1132 INTEGER, POINTER :: p(:),q(:) 1133 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1134 1135 INTEGER :: i,j,k,m,n 1136 1137 elt => element % TYPE 1138 BasisFunctions => elt % BasisFunctions 1139 1140 y = 0.0d0 1141 DO n = 1,elt % NumberOfNodes 1142 IF ( x(n) /= 0.0d0 ) THEN 1143 p => BasisFunctions(n) % p 1144 q => BasisFunctions(n) % q 1145 Coeff => BasisFunctions(n) % Coeff 1146 1147 s = 0.0d0 1148 DO i = 1,BasisFunctions(n) % n 1149 IF ( q(i) >= 1 ) THEN 1150 s = s + q(i) * Coeff(i) * u**p(i) * v**(q(i)-1) 1151 END IF 1152 END DO 1153 y = y + s*x(n) 1154 END IF 1155 END DO 1156 1157 END FUNCTION FirstDerivativeInV2D 1158!------------------------------------------------------------------------------ 1159 1160 1161!------------------------------------------------------------------------------ 1162 SUBROUTINE NodalFirstDerivatives2D( y,element,u,v ) 1163!------------------------------------------------------------------------------ 1164 TYPE(Element_t) :: element !< element structure 1165 REAL(KIND=dp) :: u,v !< Point at which to evaluate the partial derivative 1166 REAL(KIND=dp) :: y(:,:) !< value of the quantity y = @x(u,v)/@u 1167!------------------------------------------------------------------------------ 1168! Local variables 1169!------------------------------------------------------------------------------ 1170 REAL(KIND=dp) :: s,t 1171 TYPE(ElementType_t),POINTER :: elt 1172 REAL(KIND=dp), POINTER :: Coeff(:) 1173 INTEGER, POINTER :: p(:),q(:) 1174 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1175 1176 INTEGER :: i,n 1177 1178 REAL(KIND=dp) :: ult(0:6), vlt(0:6) 1179 1180 elt => element % TYPE 1181 BasisFunctions => elt % BasisFunctions 1182 1183 ult(0) = 1 1184 ult(1) = u 1185 1186 vlt(0) = 1 1187 vlt(1) = v 1188 1189 DO i=2,elt % BasisFunctionDegree 1190 ult(i) = u**i 1191 vlt(i) = v**i 1192 END DO 1193 1194 1195 DO n = 1,elt % NumberOfNodes 1196 p => BasisFunctions(n) % p 1197 q => BasisFunctions(n) % q 1198 Coeff => BasisFunctions(n) % Coeff 1199 1200 s = 0.0d0 1201 t = 0.0d0 1202 DO i = 1,BasisFunctions(n) % n 1203 IF (p(i)>=1) s = s + p(i)*Coeff(i)*ult(p(i)-1)*vlt(q(i)) 1204 IF (q(i)>=1) t = t + q(i)*Coeff(i)*ult(p(i))*vlt(q(i)-1) 1205 END DO 1206 y(n,1) = s 1207 y(n,2) = t 1208 END DO 1209 1210 END SUBROUTINE NodalFirstDerivatives2D 1211!------------------------------------------------------------------------------ 1212 1213 1214 1215!------------------------------------------------------------------------------ 1216!> Given element structure return value of the second partial derivatives with 1217!> respect to local coordinates of a quantity x given at element nodes at local 1218!> coordinate point u,v inside the element. Element basis functions are used to 1219!> compute the value. 1220!------------------------------------------------------------------------------ 1221 FUNCTION SecondDerivatives2D( element,x,u,v ) RESULT(ddx) 1222!------------------------------------------------------------------------------ 1223 TYPE(Element_t) :: element !< element structure 1224 REAL(KIND=dp) :: u,v !< Point at which to evaluate the partial derivative 1225 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to derivate 1226 REAL(KIND=dp), DIMENSION (2,2) :: ddx !< value of the quantity ddx = @^2x(u,v)/@v^2 1227!------------------------------------------------------------------------------ 1228! Local variables 1229!------------------------------------------------------------------------------ 1230 TYPE(ElementType_t),POINTER :: elt 1231 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1232 REAL(KIND=dp) :: s,t 1233 INTEGER, POINTER :: p(:),q(:) 1234 REAL(KIND=dp), POINTER :: Coeff(:) 1235 INTEGER :: i,j,k,n,m 1236 1237!------------------------------------------------------------------------------ 1238 elt => element % TYPE 1239 k = elt % NumberOfNodes 1240 BasisFunctions => elt % BasisFunctions 1241 1242 ddx = 0.0d0 1243 1244 DO n = 1,k 1245 IF ( x(n) /= 0.0d0 ) THEN 1246 p => BasisFunctions(n) % p 1247 q => BasisFunctions(n) % q 1248 Coeff => BasisFunctions(n) % Coeff 1249!------------------------------------------------------------------------------ 1250! @^2x/@u^2 1251!------------------------------------------------------------------------------ 1252 s = 0.0d0 1253 DO i = 1, BasisFunctions(n) % n 1254 IF ( p(i) >= 2 ) THEN 1255 s = s + p(i) * (p(i)-1) * Coeff(i) * u**(p(i)-2) * v**q(i) 1256 END IF 1257 END DO 1258 ddx(1,1) = ddx(1,1) + s*x(n) 1259 1260!------------------------------------------------------------------------------ 1261! @^2x/@u@v 1262!------------------------------------------------------------------------------ 1263 s = 0.0d0 1264 DO i = 1, BasisFunctions(n) % n 1265 IF ( p(i) >= 1 .AND. q(i) >= 1 ) THEN 1266 s = s + p(i) * q(i) * Coeff(i) * u**(p(i)-1) * v**(q(i)-1) 1267 END IF 1268 END DO 1269 ddx(1,2) = ddx(1,2) + s*x(n) 1270 1271!------------------------------------------------------------------------------ 1272! @^2x/@v^2 1273!------------------------------------------------------------------------------ 1274 s = 0.0d0 1275 DO i = 1, BasisFunctions(n) % n 1276 IF ( q(i) >= 2 ) THEN 1277 s = s + q(i) * (q(i)-1) * Coeff(i) * u**p(i) * v**(q(i)-2) 1278 END IF 1279 END DO 1280 ddx(2,2) = ddx(2,2) + s*x(n) 1281 END IF 1282 END DO 1283 1284 ddx(2,1) = ddx(1,2) 1285 1286 END FUNCTION SecondDerivatives2D 1287!------------------------------------------------------------------------------ 1288 1289 1290 1291!------------------------------------------------------------------------------ 1292!> Given element structure return value of a quantity x given at element nodes 1293!> at local coordinate point (u,v,w) inside the element. Element basis functions 1294!> are used to compute the value. This is for 3D elements, and shouldn't probably 1295!> be called directly by the user but through the wrapper routine 1296!> InterpolateInElement. 1297!------------------------------------------------------------------------------ 1298 FUNCTION InterpolateInElement3D( element,x,u,v,w ) RESULT(y) 1299!------------------------------------------------------------------------------ 1300 TYPE(Element_t) :: element !< element structure 1301 REAL(KIND=dp) :: u,v,w !< Point at which to evaluate the partial derivative 1302 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to derivate 1303 REAL(KIND=dp) :: y !< value of the quantity y = x(u,v,w) 1304!------------------------------------------------------------------------------ 1305! Local variables 1306!------------------------------------------------------------------------------ 1307 TYPE(ElementType_t),POINTER :: elt 1308 INTEGER :: i,j,k,l,n,m 1309 REAL(KIND=dp) :: s,t 1310 INTEGER, POINTER :: p(:),q(:), r(:) 1311 REAL(KIND=dp), POINTER :: Coeff(:) 1312 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1313!------------------------------------------------------------------------------ 1314 1315 elt => element % TYPE 1316 l = elt % BasisFunctionDegree 1317 BasisFunctions => elt % BasisFunctions 1318 1319 IF ( Elt % ElementCode == 605 ) THEN 1320 s = 0.0d0 1321 IF ( w == 1 ) w = 1.0d0-1.0d-12 1322 s = 1.0d0 / (1-w) 1323 1324 y = 0.0d0 1325 y = y + x(1) * ( (1-u) * (1-v) - w + u*v*w * s ) / 4 1326 y = y + x(2) * ( (1+u) * (1-v) - w - u*v*w * s ) / 4 1327 y = y + x(3) * ( (1+u) * (1+v) - w + u*v*w * s ) / 4 1328 y = y + x(4) * ( (1-u) * (1+v) - w - u*v*w * s ) / 4 1329 y = y + x(5) * w 1330 RETURN 1331 ELSE IF ( Elt % ElementCode == 613 ) THEN 1332 IF ( w == 1 ) w = 1.0d0-1.0d-12 1333 s = 1.0d0 / (1-w) 1334 1335 y = 0.0d0 1336 y = y + x(1) * (-u-v-1) * ( (1-u) * (1-v) - w + u*v*w * s ) / 4 1337 y = y + x(2) * ( u-v-1) * ( (1+u) * (1-v) - w - u*v*w * s ) / 4 1338 y = y + x(3) * ( u+v-1) * ( (1+u) * (1+v) - w + u*v*w * s ) / 4 1339 y = y + x(4) * (-u+v-1) * ( (1-u) * (1+v) - w - u*v*w * s ) / 4 1340 y = y + x(5) * w*(2*w-1) 1341 y = y + x(6) * (1+u-w)*(1-u-w)*(1-v-w) * s / 2 1342 y = y + x(7) * (1+v-w)*(1-v-w)*(1+u-w) * s / 2 1343 y = y + x(8) * (1+u-w)*(1-u-w)*(1+v-w) * s / 2 1344 y = y + x(9) * (1+v-w)*(1-v-w)*(1-u-w) * s / 2 1345 y = y + x(10) * w * (1-u-w) * (1-v-w) * s 1346 y = y + x(11) * w * (1+u-w) * (1-v-w) * s 1347 y = y + x(12) * w * (1+u-w) * (1+v-w) * s 1348 y = y + x(13) * w * (1-u-w) * (1+v-w) * s 1349 RETURN 1350 END IF 1351 1352 y = 0.0d0 1353 DO n = 1,elt % NumberOfNodes 1354 IF ( x(n) /= 0.0d0 ) THEN 1355 p => BasisFunctions(n) % p 1356 q => BasisFunctions(n) % q 1357 r => BasisFunctions(n) % r 1358 Coeff => BasisFunctions(n) % Coeff 1359 1360 s = 0.0d0 1361 DO i = 1,BasisFunctions(n) % n 1362 s = s + Coeff(i) * u**p(i) * v**q(i) * w**r(i) 1363 END DO 1364 y = y + s*x(n) 1365 END IF 1366 END DO 1367!------------------------------------------------------------------------------ 1368 END FUNCTION InterpolateInElement3D 1369!------------------------------------------------------------------------------ 1370 1371 1372!------------------------------------------------------------------------------ 1373 SUBROUTINE NodalBasisFunctions3D( y,element,u,v,w ) 1374!------------------------------------------------------------------------------ 1375 TYPE(Element_t) :: element !< element structure 1376 REAL(KIND=dp) :: u,v,w !< Point at which to evaluate the basis functions 1377 REAL(KIND=dp) :: y(:) !< The values of the basis functions 1378!------------------------------------------------------------------------------ 1379! Local variables 1380!------------------------------------------------------------------------------ 1381 REAL(KIND=dp) :: s 1382 1383 INTEGER :: i,n 1384 1385 TYPE(ElementType_t), POINTER :: elt 1386 1387 REAL(KIND=dp), POINTER :: Coeff(:) 1388 INTEGER, POINTER :: p(:),q(:),r(:) 1389 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1390!------------------------------------------------------------------------------ 1391 REAL(KIND=dp) :: ult(0:6), vlt(0:6), wlt(0:6) 1392 1393 elt => element % TYPE 1394 BasisFunctions => elt % BasisFunctions 1395 1396 ult(0) = 1 1397 ult(1) = u 1398 1399 vlt(0) = 1 1400 vlt(1) = v 1401 1402 wlt(0) = 1 1403 wlt(1) = w 1404 1405 DO i=2,elt % BasisFunctionDegree 1406 ult(i) = u**i 1407 vlt(i) = v**i 1408 wlt(i) = w**i 1409 END DO 1410 1411 DO n=1,Elt % NumberOfNodes 1412 p => BasisFunctions(n) % p 1413 q => BasisFunctions(n) % q 1414 r => BasisFunctions(n) % r 1415 Coeff => BasisFunctions(n) % Coeff 1416 1417 s = 0.0d0 1418 DO i=1,BasisFunctions(n) % n 1419 s = s + Coeff(i)*ult(p(i))*vlt(q(i))*wlt(r(i)) 1420 END DO 1421 y(n) = s 1422 END DO 1423 END SUBROUTINE NodalBasisFunctions3D 1424!------------------------------------------------------------------------------ 1425 1426 1427!------------------------------------------------------------------------------ 1428!> Given element structure return value of the first partial derivative with 1429!> respect to local coordinate u of a quantity x given at element nodes at 1430!> local coordinate point u,v,w inside the element. Element basis functions 1431!> are used to compute the value. 1432!------------------------------------------------------------------------------ 1433 FUNCTION FirstDerivativeInU3D( element,x,u,v,w ) RESULT(y) 1434!------------------------------------------------------------------------------ 1435 TYPE(Element_t) :: element !< element structure 1436 REAL(KIND=dp) :: u,v,w !< Point at which to evaluate the partial derivative 1437 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to be derivated 1438 REAL(KIND=dp) :: y !< value of the quantity y = @x(u,v,w)/@u 1439!------------------------------------------------------------------------------ 1440! Local variables 1441!------------------------------------------------------------------------------ 1442 TYPE(ElementType_t),POINTER :: elt 1443 INTEGER :: i,j,k,l,n,m 1444 REAL(KIND=dp) :: s,t 1445 INTEGER, POINTER :: p(:),q(:), r(:) 1446 REAL(KIND=dp), POINTER :: Coeff(:) 1447 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1448!------------------------------------------------------------------------------ 1449 elt => element % TYPE 1450 l = elt % BasisFunctionDegree 1451 BasisFunctions => elt % BasisFunctions 1452 1453 IF ( Elt % ElementCode == 605 ) THEN 1454 IF ( w == 1 ) w = 1.0d0-1.0d-12 1455 s = 1.0d0 / (1-w) 1456 1457 y = 0.0d0 1458 y = y + x(1) * ( -(1-v) + v*w * s ) / 4 1459 y = y + x(2) * ( (1-v) - v*w * s ) / 4 1460 y = y + x(3) * ( (1+v) + v*w * s ) / 4 1461 y = y + x(4) * ( -(1+v) - v*w * s ) / 4 1462 RETURN 1463 ELSE IF ( Elt % ElementCode == 613 ) THEN 1464 IF ( w == 1 ) w = 1.0d0-1.0d-12 1465 s = 1.0d0 / (1-w) 1466 1467 y = 0.0d0 1468 y = y + x(1) * ( -( (1-u) * (1-v) - w + u*v*w * s ) + & 1469 (-u-v-1) * ( -(1-v) + v*w * s ) ) / 4 1470 1471 y = y + x(2) * ( ( (1+u) * (1-v) - w - u*v*w * s ) + & 1472 ( u-v-1) * ( (1-v) - v*w * s ) ) / 4 1473 1474 y = y + x(3) * ( ( (1+u) * (1+v) - w + u*v*w * s ) + & 1475 ( u+v-1) * ( (1+v) + v*w * s ) ) / 4 1476 1477 y = y + x(4) * ( -( (1-u) * (1+v) - w - u*v*w * s ) + & 1478 (-u+v-1) * ( -(1+v) - v*w * s ) ) / 4 1479 1480 y = y + x(5) * 0.0d0 1481 1482 y = y + x(6) * ( (1-u-w)*(1-v-w) - (1+u-w)*(1-v-w) ) * s / 2 1483 y = y + x(7) * ( (1+v-w)*(1-v-w) ) * s / 2 1484 y = y + x(8) * ( (1-u-w)*(1+v-w) - (1+u-w)*(1+v-w) ) * s / 2 1485 y = y + x(9) * ( -(1+v-w)*(1-v-w) ) * s / 2 1486 1487 y = y - x(10) * w * (1-v-w) * s 1488 y = y + x(11) * w * (1-v-w) * s 1489 y = y + x(12) * w * (1+v-w) * s 1490 y = y - x(13) * w * (1+v-w) * s 1491 1492 RETURN 1493 END IF 1494 1495 y = 0.0d0 1496 DO n = 1,elt % NumberOfNodes 1497 IF ( x(n) /= 0.0d0 ) THEN 1498 p => BasisFunctions(n) % p 1499 q => BasisFunctions(n) % q 1500 r => BasisFunctions(n) % r 1501 Coeff => BasisFunctions(n) % Coeff 1502 1503 s = 0.0d0 1504 DO i = 1,BasisFunctions(n) % n 1505 IF ( p(i) >= 1 ) THEN 1506 s = s + p(i) * Coeff(i) * u**(p(i)-1) * v**q(i) * w**r(i) 1507 END IF 1508 END DO 1509 y = y + s*x(n) 1510 END IF 1511 END DO 1512!------------------------------------------------------------------------------ 1513 END FUNCTION FirstDerivativeInU3D 1514!------------------------------------------------------------------------------ 1515 1516 1517 1518!------------------------------------------------------------------------------ 1519!> Given element structure return value of the first partial derivative with 1520!> respect to local coordinate v of a quantity x given at element nodes at 1521!> local coordinate point u,v,w inside the element. Element basis functions 1522!> are used to compute the value. 1523!------------------------------------------------------------------------------ 1524 FUNCTION FirstDerivativeInV3D( element,x,u,v,w ) RESULT(y) 1525!------------------------------------------------------------------------------ 1526 TYPE(Element_t) :: element !< element structure 1527 REAL(KIND=dp) :: u,v,w !< Point at which to evaluate the partial derivative 1528 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to be derivated 1529 REAL(KIND=dp) :: y !< value of the quantity y = @x(u,v,w)/@v 1530!------------------------------------------------------------------------------ 1531! Local variables 1532!------------------------------------------------------------------------------ 1533 TYPE(ElementType_t),POINTER :: elt 1534 INTEGER :: i,j,k,l,n,m 1535 REAL(KIND=dp) :: s,t 1536 INTEGER, POINTER :: p(:),q(:), r(:) 1537 REAL(KIND=dp), POINTER :: Coeff(:) 1538 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1539!------------------------------------------------------------------------------ 1540 elt => element % TYPE 1541 l = elt % BasisFunctionDegree 1542 BasisFunctions => elt % BasisFunctions 1543 1544 IF ( Elt % ElementCode == 605 ) THEN 1545 IF ( w == 1 ) w = 1.0d0-1.0d-12 1546 s = 1.0d0 / (1-w) 1547 1548 y = 0.0d0 1549 y = y + x(1) * ( -(1-u) + u*w * s ) / 4 1550 y = y + x(2) * ( -(1+u) - u*w * s ) / 4 1551 y = y + x(3) * ( (1+u) + u*w * s ) / 4 1552 y = y + x(4) * ( (1-u) - u*w * s ) / 4 1553 1554 RETURN 1555 ELSE IF ( Elt % ElementCode == 613 ) THEN 1556 IF ( w == 1 ) w = 1.0d0-1.0d-12 1557 s = 1.0d0 / (1-w) 1558 1559 y = 0.0d0 1560 y = y + x(1) * ( -( (1-u) * (1-v) - w + u*v*w * s ) + & 1561 (-u-v-1) * ( -(1-u) + u*w * s ) ) / 4 1562 1563 y = y + x(2) * ( -( (1+u) * (1-v) - w - u*v*w * s ) + & 1564 ( u-v-1) * ( -(1+u) - u*w * s ) ) / 4 1565 1566 y = y + x(3) * ( ( (1+u) * (1+v) - w + u*v*w * s ) + & 1567 ( u+v-1) * ( (1+u) + u*w * s ) ) / 4 1568 1569 y = y + x(4) * ( ( (1-u) * (1+v) - w - u*v*w * s ) + & 1570 (-u+v-1) * ( (1-u) - u*w * s ) ) / 4 1571 1572 y = y + x(5) * 0.0d0 1573 1574 y = y - x(6) * (1+u-w)*(1-u-w) * s / 2 1575 y = y + x(7) * ( (1-v-w)*(1+u-w) - (1+v-w)*(1+u-w) ) * s / 2 1576 y = y + x(8) * (1+u-w)*(1-u-w) * s / 2 1577 y = y + x(9) * ( (1-v-w)*(1-u-w) - (1+v-w)*(1-u-w) ) * s / 2 1578 1579 y = y - x(10) * w * (1-u-w) * s 1580 y = y - x(11) * w * (1+u-w) * s 1581 y = y + x(12) * w * (1+u-w) * s 1582 y = y + x(13) * w * (1-u-w) * s 1583 RETURN 1584 END IF 1585 1586 y = 0.0d0 1587 DO n = 1,elt % NumberOfNodes 1588 IF ( x(n) /= 0.0d0 ) THEN 1589 p => BasisFunctions(n) % p 1590 q => BasisFunctions(n) % q 1591 r => BasisFunctions(n) % r 1592 Coeff => BasisFunctions(n) % Coeff 1593 1594 s = 0.0d0 1595 DO i = 1,BasisFunctions(n) % n 1596 IF ( q(i) >= 1 ) THEN 1597 s = s + q(i) * Coeff(i) * u**p(i) * v**(q(i)-1) * w**r(i) 1598 END IF 1599 END DO 1600 y = y + s*x(n) 1601 END IF 1602 END DO 1603 END FUNCTION FirstDerivativeInV3D 1604!------------------------------------------------------------------------------ 1605 1606 1607 1608!------------------------------------------------------------------------------ 1609!> Given element structure return value of the first partial derivatives with 1610!> respect to local coordinate w of a quantity x given at element nodes at 1611!> local coordinate point u,v,w inside the element. Element basis functions 1612!> are used to compute the value. 1613!------------------------------------------------------------------------------ 1614 FUNCTION FirstDerivativeInW3D( element,x,u,v,w ) RESULT(y) 1615!------------------------------------------------------------------------------ 1616 TYPE(Element_t) :: element !< element structure 1617 REAL(KIND=dp) :: u,v,w !< Point at which to evaluate the partial derivative 1618 REAL(KIND=dp), DIMENSION(:) :: x !< Nodal values of the quantity to be derivated 1619 REAL(KIND=dp) :: y !< value of the quantity y = @x(u,v,w)/@w 1620!------------------------------------------------------------------------------ 1621! Local variables 1622!------------------------------------------------------------------------------ 1623 TYPE(ElementType_t),POINTER :: elt 1624 INTEGER :: i,j,k,l,n,m 1625 REAL(KIND=dp) :: s,t 1626 INTEGER, POINTER :: p(:),q(:), r(:) 1627 REAL(KIND=dp), POINTER :: Coeff(:) 1628 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1629!------------------------------------------------------------------------------ 1630 elt => element % TYPE 1631 l = elt % BasisFunctionDegree 1632 BasisFunctions => elt % BasisFunctions 1633 1634 IF ( Elt % ElementCode == 605 ) THEN 1635 IF ( w == 1 ) w = 1.0d0-1.0d-12 1636 s = 1.0d0 / (1-w) 1637 1638 y = 0.0d0 1639 y = y + x(1) * ( -1 + u*v*s**2 ) / 4 1640 y = y + x(2) * ( -1 - u*v*s**2 ) / 4 1641 y = y + x(3) * ( -1 + u*v*s**2 ) / 4 1642 y = y + x(4) * ( -1 - u*v*s**2 ) / 4 1643 y = y + x(5) 1644 RETURN 1645 ELSE IF ( Elt % ElementCode == 613 ) THEN 1646 IF ( w == 1 ) w = 1.0d0-1.0d-12 1647 s = 1.0d0 / (1-w) 1648 1649 y = 0.0d0 1650 y = y + x(1) * (-u-v-1) * ( -1 + u*v*s**2 ) / 4 1651 y = y + x(2) * ( u-v-1) * ( -1 - u*v*s**2 ) / 4 1652 y = y + x(3) * ( u+v-1) * ( -1 + u*v*s**2 ) / 4 1653 y = y + x(4) * (-u+v-1) * ( -1 - u*v*s**2 ) / 4 1654 1655 y = y + x(5) * (4*w-1) 1656 1657 y = y + x(6) * ( ( -(1-u-w)*(1-v-w) - (1+u-w)*(1-v-w) - (1+u-w)*(1-u-w) ) * s + & 1658 ( 1+u-w)*(1-u-w)*(1-v-w) * s**2 ) / 2 1659 1660 y = y + x(7) * ( ( -(1-v-w)*(1+u-w) - (1+v-w)*(1+u-w) - (1+v-w)*(1-v-w) ) * s + & 1661 ( 1+v-w)*(1-v-w)*(1+u-w) * s**2 ) / 2 1662 1663 y = y + x(8) * ( ( -(1-u-w)*(1+v-w) - (1+u-w)*(1+v-w) - (1+u-w)*(1-u-w) ) * s + & 1664 ( 1+u-w)*(1-u-w)*(1+v-w) * s**2 ) / 2 1665 1666 y = y + x(9) * ( ( -(1-v-w)*(1-u-w) - (1+v-w)*(1-u-w) - (1+v-w)*(1-v-w) ) * s + & 1667 ( 1+v-w)*(1-v-w)*(1-u-w) * s**2 ) / 2 1668 1669 y = y + x(10) * ( ( (1-u-w) * (1-v-w) - w * (1-v-w) - w * (1-u-w) ) * s + & 1670 w * (1-u-w) * (1-v-w) * s**2 ) 1671 1672 y = y + x(11) * ( ( (1+u-w) * (1-v-w) - w * (1-v-w) - w * (1+u-w) ) * s + & 1673 w * (1+u-w) * (1-v-w) * s**2 ) 1674 1675 y = y + x(12) * ( ( (1+u-w) * (1+v-w) - w * (1+v-w) - w * (1+u-w) ) * s + & 1676 w * (1+u-w) * (1+v-w) * s**2 ) 1677 1678 y = y + x(13) * ( ( (1-u-w) * (1+v-w) - w * (1+v-w) - w * (1-u-w) ) * s + & 1679 w * (1-u-w) * (1+v-w) * s**2 ) 1680 RETURN 1681 END IF 1682 1683 y = 0.0d0 1684 DO n = 1,elt % NumberOfNodes 1685 IF ( x(n) /= 0.0d0 ) THEN 1686 p => BasisFunctions(n) % p 1687 q => BasisFunctions(n) % q 1688 r => BasisFunctions(n) % r 1689 Coeff => BasisFunctions(n) % Coeff 1690 1691 s = 0.0d0 1692 DO i = 1,BasisFunctions(n) % n 1693 IF ( r(i) >= 1 ) THEN 1694 s = s + r(i) * Coeff(i) * u**p(i) * v**q(i) * w**(r(i)-1) 1695 END IF 1696 END DO 1697 y = y + s*x(n) 1698 END IF 1699 END DO 1700!------------------------------------------------------------------------------ 1701 END FUNCTION FirstDerivativeInW3D 1702!------------------------------------------------------------------------------ 1703 1704 1705!------------------------------------------------------------------------------ 1706! Return first partial derivative in u of a quantity x at point (u,v,w) 1707!------------------------------------------------------------------------------ 1708 SUBROUTINE NodalFirstDerivatives3D( y,element,u,v,w ) 1709!------------------------------------------------------------------------------ 1710 TYPE(Element_t) :: element !< element structure 1711 REAL(KIND=dp) :: u,v,w !< Point at which to evaluate the partial derivative 1712 REAL(KIND=dp) :: y(:,:) !< value of the quantity y = @x(u,v,w)/@u 1713!------------------------------------------------------------------------------ 1714! Local variables 1715!------------------------------------------------------------------------------ 1716 REAL(KIND=dp) :: s,t,z 1717 TYPE(ElementType_t),POINTER :: elt 1718 REAL(KIND=dp), POINTER :: Coeff(:) 1719 INTEGER, POINTER :: p(:),q(:),r(:) 1720 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1721 INTEGER :: i,n 1722 REAL(KIND=dp) :: ult(0:6), vlt(0:6), wlt(0:6) 1723 1724 elt => element % TYPE 1725 BasisFunctions => elt % BasisFunctions 1726 1727 ult(0) = 1 1728 ult(1) = u 1729 1730 vlt(0) = 1 1731 vlt(1) = v 1732 1733 wlt(0) = 1 1734 wlt(1) = w 1735 1736 DO i=2,elt % BasisFunctionDegree 1737 ult(i) = u**i 1738 vlt(i) = v**i 1739 wlt(i) = w**i 1740 END DO 1741 1742 DO n = 1,elt % NumberOfNodes 1743 p => BasisFunctions(n) % p 1744 q => BasisFunctions(n) % q 1745 r => BasisFunctions(n) % r 1746 Coeff => BasisFunctions(n) % Coeff 1747 1748 s = 0.0d0 1749 t = 0.0d0 1750 z = 0.0d0 1751 DO i = 1,BasisFunctions(n) % n 1752 IF (p(i)>=1) s = s + p(i)*Coeff(i)*ult(p(i)-1)*vlt(q(i))*wlt(r(i)) 1753 IF (q(i)>=1) t = t + q(i)*Coeff(i)*ult(p(i))*vlt(q(i)-1)*wlt(r(i)) 1754 IF (r(i)>=1) z = z + r(i)*Coeff(i)*ult(p(i))*vlt(q(i))*wlt(r(i)-1) 1755 END DO 1756 y(n,1) = s 1757 y(n,2) = t 1758 y(n,3) = z 1759 END DO 1760 END SUBROUTINE NodalFirstDerivatives3D 1761!------------------------------------------------------------------------------ 1762 1763 1764 1765!------------------------------------------------------------------------------ 1766!> Given element structure return value of the second partial derivatives with 1767!> respect to local coordinates of i quantity x given at element nodes at local 1768!> coordinate point u,v inside the element. Element basis functions are used to 1769!> compute the value. 1770!------------------------------------------------------------------------------ 1771 FUNCTION SecondDerivatives3D( element,x,u,v,w ) RESULT(ddx) 1772!------------------------------------------------------------------------------ 1773! 1774! ARGUMENTS: 1775! Type(Element_t) :: element 1776! INPUT: element structure 1777! 1778! REAL(KIND=dp) :: x(:) 1779! INPUT: Nodal values of the quantity whose partial derivatives we want to know 1780! 1781! REAL(KIND=dp) :: u,v 1782! INPUT: Point at which to evaluate the partial derivative 1783! 1784! FUNCTION VALUE: 1785! REAL(KIND=dp) :: s 1786! value of the quantity s = @^2x(u,v)/@v^2 1787! 1788!------------------------------------------------------------------------------ 1789 ! 1790 ! Return matrix of second partial derivatives. 1791 ! 1792!------------------------------------------------------------------------------ 1793 1794 TYPE(Element_t) :: element 1795 1796 REAL(KIND=dp), DIMENSION(:) :: x 1797 REAL(KIND=dp) :: u,v,w 1798 1799!------------------------------------------------------------------------------ 1800! Local variables 1801!------------------------------------------------------------------------------ 1802 TYPE(ElementType_t),POINTER :: elt 1803 REAL(KIND=dp), DIMENSION (3,3) :: ddx 1804 TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:) 1805 1806 REAL(KIND=dp), POINTER :: Coeff(:) 1807 INTEGER, POINTER :: p(:), q(:), r(:) 1808 1809 REAL(KIND=dp) :: s 1810 INTEGER :: i,j,k,l,n,m 1811 1812!------------------------------------------------------------------------------ 1813 elt => element % TYPE 1814 k = elt % NumberOfNodes 1815 BasisFunctions => elt % BasisFunctions 1816 1817 ddx = 0.0d0 1818 1819 DO n = 1,k 1820 IF ( x(n) /= 0.0d0 ) THEN 1821 p => elt % BasisFunctions(n) % p 1822 q => elt % BasisFunctions(n) % q 1823 r => elt % BasisFunctions(n) % r 1824 Coeff => elt % BasisFunctions(n) % Coeff 1825!------------------------------------------------------------------------------ 1826! @^2x/@u^2 1827!------------------------------------------------------------------------------ 1828 s = 0.0d0 1829 DO i = 1,BasisFunctions(n) % n 1830 IF ( p(i) >= 2 ) THEN 1831 s = s + p(i) * (p(i)-1) * Coeff(i) * u**(p(i)-2) * v**q(i) * w**r(i) 1832 END IF 1833 END DO 1834 ddx(1,1) = ddx(1,1) + s*x(n) 1835 1836!------------------------------------------------------------------------------ 1837! @^2x/@u@v 1838!------------------------------------------------------------------------------ 1839 s = 0.0d0 1840 DO i = 1,BasisFunctions(n) % n 1841 IF ( p(i) >= 1 .AND. q(i) >= 1 ) THEN 1842 s = s + p(i) * q(i) * Coeff(i) * u**(p(i)-1) * v**(q(i)-1) * w**r(i) 1843 END IF 1844 END DO 1845 ddx(1,2) = ddx(1,2) + s*x(n) 1846 1847!------------------------------------------------------------------------------ 1848! @^2x/@u@w 1849!------------------------------------------------------------------------------ 1850 s = 0.0d0 1851 DO i = 2,k 1852 IF ( p(i) >= 1 .AND. r(i) >= 1 ) THEN 1853 s = s + p(i) * r(i) * Coeff(i) * u**(p(i)-1) * v**q(i) * w**(r(i)-1) 1854 END IF 1855 END DO 1856 ddx(1,3) = ddx(1,3) + s*x(n) 1857 1858!------------------------------------------------------------------------------ 1859! @^2x/@v^2 1860!------------------------------------------------------------------------------ 1861 s = 0.0d0 1862 DO i = 1,BasisFunctions(n) % n 1863 IF ( q(i) >= 2 ) THEN 1864 s = s + q(i) * (q(i)-1) * Coeff(i) * u**p(i) * v**(q(i)-2) * w**r(i) 1865 END IF 1866 END DO 1867 ddx(2,2) = ddx(2,2) + s*x(n) 1868 1869!------------------------------------------------------------------------------ 1870! @^2x/@v@w 1871!------------------------------------------------------------------------------ 1872 s = 0.0d0 1873 DO i = 1,BasisFunctions(n) % n 1874 IF ( q(i) >= 1 .AND. r(i) >= 1 ) THEN 1875 s = s + q(i) * r(i) * Coeff(i) * u**p(i) * v**(q(i)-1) * w**(r(i)-1) 1876 END IF 1877 END DO 1878 ddx(2,3) = ddx(2,3) + s*x(n) 1879 1880!------------------------------------------------------------------------------ 1881! @^2x/@w^2 1882!------------------------------------------------------------------------------ 1883 s = 0.0d0 1884 DO i = 1,BasisFunctions(n) % n 1885 IF ( r(i) >= 2 ) THEN 1886 s = s + r(i) * (r(i)-1) * Coeff(i) * u**p(i) * v**q(i) * w**(r(i)-2) 1887 END IF 1888 END DO 1889 ddx(3,3) = ddx(3,3) + s*x(n) 1890 1891 END IF 1892 END DO 1893 1894 ddx(2,1) = ddx(1,2) 1895 ddx(3,1) = ddx(1,3) 1896 ddx(3,2) = ddx(2,3) 1897 1898 END FUNCTION SecondDerivatives3D 1899!------------------------------------------------------------------------------ 1900 1901!------------------------------------------------------------------------------ 1902!> Return the values of the reference element basis functions. In the case of 1903!> p-element, the values of the lowest-order basis functions corresponding 1904!> to the background mesh are returned. 1905!------------------------------------------------------------------------------ 1906 SUBROUTINE NodalBasisFunctions( n, Basis, element, u, v, w) 1907!------------------------------------------------------------------------------ 1908 INTEGER :: n !< The number of (background) element nodes 1909 REAL(KIND=dp) :: Basis(:) !< The values of reference element basis 1910 TYPE(Element_t) :: element !< The element structure 1911 REAL(KIND=dp) :: u,v,w !< The coordinates of the reference element point 1912!------------------------------------------------------------------------------ 1913 INTEGER :: i, q, dim 1914 REAL(KIND=dp) :: NodalBasis(n) 1915 1916 dim = Element % TYPE % DIMENSION 1917 1918 IF ( isActivePElement(Element) ) THEN 1919 SELECT CASE(dim) 1920 CASE(1) 1921 CALL NodalBasisFunctions1D( Basis, element, u ) 1922 CASE(2) 1923 IF (isPTriangle(Element)) THEN 1924 DO q=1,n 1925 Basis(q) = TriangleNodalPBasis(q, u, v) 1926 END DO 1927 ELSE IF (isPQuad(Element)) THEN 1928 DO q=1,n 1929 Basis(q) = QuadNodalPBasis(q, u, v) 1930 END DO 1931 END IF 1932 CASE(3) 1933 IF (isPTetra( Element )) THEN 1934 DO q=1,n 1935 Basis(q) = TetraNodalPBasis(q, u, v, w) 1936 END DO 1937 ELSE IF (isPWedge( Element )) THEN 1938 DO q=1,n 1939 Basis(q) = WedgeNodalPBasis(q, u, v, w) 1940 END DO 1941 ELSE IF (isPPyramid( Element )) THEN 1942 DO q=1,n 1943 Basis(q) = PyramidNodalPBasis(q, u, v, w) 1944 END DO 1945 ELSE IF (isPBrick( Element )) THEN 1946 DO q=1,n 1947 Basis(q) = BrickNodalPBasis(q, u, v, w) 1948 END DO 1949 END IF 1950 END SELECT 1951 ELSE 1952 SELECT CASE( dim ) 1953 CASE(1) 1954 CALL NodalBasisFunctions1D( Basis, element, u ) 1955 CASE(2) 1956 CALL NodalBasisFunctions2D( Basis, element, u,v ) 1957 CASE(3) 1958 IF ( Element % TYPE % ElementCode/100==6 ) THEN 1959 NodalBasis=0 1960 DO q=1,n 1961 NodalBasis(q) = 1.0d0 1962 Basis(q) = InterpolateInElement3D( element, NodalBasis, u,v,w ) 1963 NodalBasis(q) = 0.0d0 1964 END DO 1965 ELSE 1966 CALL NodalBasisFunctions3D( Basis, element, u,v,w ) 1967 END IF 1968 END SELECT 1969 END IF 1970!------------------------------------------------------------------------------ 1971 END SUBROUTINE NodalBasisFunctions 1972!------------------------------------------------------------------------------ 1973 1974!------------------------------------------------------------------------------ 1975!> Return the gradient of the reference element basis functions, with the 1976!> gradient taken with respect to the reference element coordinates. In the case 1977!> of p-element, the gradients of the lowest-order basis functions corresponding 1978!> to the background mesh are returned. 1979!------------------------------------------------------------------------------ 1980 SUBROUTINE NodalFirstDerivatives( n, dLBasisdx, element, u, v, w) 1981!------------------------------------------------------------------------------ 1982 INTEGER :: n !< The number of (background) element nodes 1983 REAL(KIND=dp) :: dLBasisdx(:,:) !< The gradient of reference element basis functions 1984 TYPE(Element_t) :: element !< The element structure 1985 REAL(KIND=dp) :: u,v,w !< The coordinates of the reference element point 1986!------------------------------------------------------------------------------ 1987 INTEGER :: i, q, dim 1988 REAL(KIND=dp) :: NodalBasis(n) 1989!------------------------------------------------------------------------------ 1990 dim = Element % TYPE % DIMENSION 1991 1992 IF ( IsActivePElement(Element) ) THEN 1993 SELECT CASE(dim) 1994 CASE(1) 1995 CALL NodalFirstDerivatives1D( dLBasisdx, element, u ) 1996 CASE(2) 1997 IF (isPTriangle(Element)) THEN 1998 DO q=1,n 1999 dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 2000 END DO 2001 ELSE IF (isPQuad(Element)) THEN 2002 DO q=1,n 2003 dLBasisdx(q,1:2) = dQuadNodalPBasis(q, u, v) 2004 END DO 2005 END IF 2006 CASE(3) 2007 IF (isPTetra( Element )) THEN 2008 DO q=1,n 2009 dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w) 2010 END DO 2011 ELSE IF (isPWedge( Element )) THEN 2012 DO q=1,n 2013 dLBasisdx(q,1:3) = dWedgeNodalPBasis(q, u, v, w) 2014 END DO 2015 ELSE IF (isPPyramid( Element )) THEN 2016 DO q=1,n 2017 dLBasisdx(q,1:3) = dPyramidNodalPBasis(q, u, v, w) 2018 END DO 2019 ELSE IF (isPBrick( Element )) THEN 2020 DO q=1,n 2021 dLBasisdx(q,1:3) = dBrickNodalPBasis(q, u, v, w) 2022 END DO 2023 END IF 2024 END SELECT 2025 ELSE 2026 SELECT CASE(dim) 2027 CASE(1) 2028 CALL NodalFirstDerivatives1D( dLBasisdx, element, u ) 2029 CASE(2) 2030 CALL NodalFirstDerivatives2D( dLBasisdx, element, u,v ) 2031 CASE(3) 2032 IF ( Element % TYPE % ElementCode / 100 == 6 ) THEN 2033 NodalBasis=0 2034 DO q=1,n 2035 NodalBasis(q) = 1.0d0 2036 dLBasisdx(q,1) = FirstDerivativeInU3D(element,NodalBasis,u,v,w) 2037 dLBasisdx(q,2) = FirstDerivativeInV3D(element,NodalBasis,u,v,w) 2038 dLBasisdx(q,3) = FirstDerivativeInW3D(element,NodalBasis,u,v,w) 2039 NodalBasis(q) = 0.0d0 2040 END DO 2041 ELSE 2042 CALL NodalFirstDerivatives3D( dLBasisdx, element, u,v,w ) 2043 END IF 2044 END SELECT 2045 END IF 2046!------------------------------------------------------------------------------ 2047 END SUBROUTINE NodalFirstDerivatives 2048!------------------------------------------------------------------------------ 2049 2050 2051!------------------------------------------------------------------------------ 2052!> Return basis function degrees 2053!------------------------------------------------------------------------------ 2054 SUBROUTINE ElementBasisDegree( Element, BasisDegree ) 2055!------------------------------------------------------------------------------ 2056 IMPLICIT NONE 2057 2058 TYPE(Element_t), TARGET :: Element !< Element structure 2059 INTEGER :: BasisDegree(:) !< Degree of each basis function in Basis(:) vector. 2060!------------------------------------------------------------------------------ 2061! Local variables 2062!------------------------------------------------------------------------------ 2063 2064 REAL(KIND=dp) :: t,s 2065 LOGICAL :: invert, degrees 2066 INTEGER :: i, j, k, l, q, p, f, n, nb, dim, cdim, locali, localj, & 2067 tmp(4), direction(4) 2068 2069 TYPE(Element_t) :: Bubble 2070 TYPE(Element_t), POINTER :: Edge, Face 2071!------------------------------------------------------------------------------ 2072 2073 n = Element % TYPE % NumberOfNodes 2074 dim = Element % TYPE % DIMENSION 2075 cdim = CoordinateSystemDimension() 2076 2077 BasisDegree = 0 2078 BasisDegree(1:n) = Element % Type % BasisFunctionDegree 2079 2080 IF ( isActivePElement(element) ) THEN 2081 2082 ! Check for need of P basis degrees and set degree of 2083 ! linear basis if vector asked: 2084 ! --------------------------------------------------- 2085 BasisDegree(1:n) = 1 2086 q = n 2087 2088!------------------------------------------------------------------------------ 2089 SELECT CASE( Element % TYPE % ElementCode ) 2090!------------------------------------------------------------------------------ 2091 2092 ! P element code for line element: 2093 ! -------------------------------- 2094 CASE(202) 2095 ! Bubbles of line element 2096 IF (Element % BDOFs > 0) THEN 2097 ! For each bubble in line element get value of basis function 2098 DO i=1, Element % BDOFs 2099 IF (q >= SIZE(BasisDegree)) CYCLE 2100 q = q + 1 2101 BasisDegree(q) = 1+i 2102 END DO 2103 END IF 2104 2105!------------------------------------------------------------------------------ 2106! P element code for edges and bubbles of triangle 2107 CASE(303) 2108 ! Edges of triangle 2109 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2110 ! For each edge calculate the value of edge basis function 2111 DO i=1,3 2112 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2113 2114 ! For each dof in edge get value of p basis function 2115 DO k=1,Edge % BDOFs 2116 IF (q >= SIZE(BasisDegree)) CYCLE 2117 q = q + 1 2118 BasisDegree(q) = 1+k 2119 END DO 2120 END DO 2121 END IF 2122 2123 ! Bubbles of p triangle 2124 IF ( Element % BDOFs > 0 ) THEN 2125 ! Get element p 2126 p = Element % PDefs % P 2127 2128 nb = MAX( GetBubbleDOFs( Element, p ), Element % BDOFs ) 2129 p = CEILING( ( 3.0d0+SQRT(1.0d0+8.0d0*nb) ) / 2.0d0 - AEPS ) 2130 2131 DO i = 0,p-3 2132 DO j = 0,p-i-3 2133 IF ( q >= SIZE(BasisDegree) ) CYCLE 2134 q = q + 1 2135 BasisDegree(q) = 3+i+j 2136 END DO 2137 END DO 2138 END IF 2139!------------------------------------------------------------------------------ 2140! P element code for quadrilateral edges and bubbles 2141 CASE(404) 2142 ! Edges of p quadrilateral 2143 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2144 ! For each edge begin node calculate values of edge functions 2145 DO i=1,4 2146 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2147 ! For each DOF in edge calculate value of p basis function 2148 DO k=1,Edge % BDOFs 2149 IF ( q >= SIZE(BasisDegree) ) CYCLE 2150 q = q + 1 2151 BasisDegree(q) = 1+k 2152 END DO 2153 END DO 2154 END IF 2155 2156 ! Bubbles of p quadrilateral 2157 IF ( Element % BDOFs > 0 ) THEN 2158 ! Get element P 2159 p = Element % PDefs % P 2160 2161 nb = MAX( GetBubbleDOFs( Element, p ), Element % BDOFs ) 2162 p = CEILING( ( 5.0d0+SQRT(1.0d0+8.0d0*nb) ) / 2.0d0 - AEPS) 2163 2164 DO i=2,(p-2) 2165 DO j=2,(p-i) 2166 IF ( q >= SIZE(BasisDegree) ) CYCLE 2167 q = q + 1 2168 BasisDegree(q) = i+j 2169 END DO 2170 END DO 2171 END IF 2172!------------------------------------------------------------------------------ 2173! P element code for tetrahedron edges, faces and bubbles 2174 CASE(504) 2175 ! Edges of p tetrahedron 2176 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2177 ! For each edge calculate value of edge functions 2178 DO i=1,6 2179 Edge => CurrentModel % Solver % Mesh % Edges (Element % EdgeIndexes(i)) 2180 2181 ! Do not solve edge DOFS if there is not any 2182 IF (Edge % BDOFs <= 0) CYCLE 2183 2184 ! For each DOF in edge calculate value of edge functions 2185 ! and their derivatives for edge=i, i=k+1 2186 DO k=1, Edge % BDOFs 2187 IF (q >= SIZE(BasisDegree)) CYCLE 2188 q = q + 1 2189 BasisDegree(q) = 1+k 2190 END DO 2191 END DO 2192 END IF 2193 2194 ! Faces of p tetrahedron 2195 IF ( ASSOCIATED( Element % FaceIndexes )) THEN 2196 ! For each face calculate value of face functions 2197 DO F=1,4 2198 Face => CurrentModel % Solver % Mesh % Faces (Element % FaceIndexes(F)) 2199 2200 ! Do not solve face DOFs if there is not any 2201 IF (Face % BDOFs <= 0) CYCLE 2202 2203 ! Get face p 2204 p = Face % PDefs % P 2205 2206 ! For each DOF in face calculate value of face functions and 2207 ! their derivatives for face=F and index pairs 2208 ! i,j=0,..,p-3, i+j=0,..,p-3 2209 DO i=0,p-3 2210 DO j=0,p-i-3 2211 IF (q >= SIZE(BasisDegree)) CYCLE 2212 q = q + 1 2213 BasisDegree(q) = 3+i+j 2214 END DO 2215 END DO 2216 END DO 2217 END IF 2218 2219 ! Bubbles of p tetrahedron 2220 IF ( Element % BDOFs > 0 ) THEN 2221 p = Element % PDefs % P 2222 2223 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 2224 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 2225 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+2 - AEPS) 2226 2227 DO i=0,p-4 2228 DO j=0,p-i-4 2229 DO k=0,p-i-j-4 2230 IF (q >= SIZE(BasisDegree)) CYCLE 2231 q = q + 1 2232 BasisDegree(q) = 4+i+j+k 2233 END DO 2234 END DO 2235 END DO 2236 2237 END IF 2238!------------------------------------------------------------------------------ 2239! P element code for pyramid edges, faces and bubbles 2240 CASE(605) 2241 ! Edges of P Pyramid 2242 IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN 2243 ! For each edge in wedge, calculate values of edge functions 2244 DO i=1,8 2245 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2246 2247 ! Do not solve edge dofs, if there is not any 2248 IF (Edge % BDOFs <= 0) CYCLE 2249 2250 ! For each DOF in edge calculate values of edge functions 2251 ! and their derivatives for edge=i and i=k+1 2252 DO k=1,Edge % BDOFs 2253 IF ( q >= SIZE(BasisDegree) ) CYCLE 2254 q = q + 1 2255 BasisDegree(q) = 1+k 2256 END DO 2257 END DO 2258 END IF 2259 2260 ! Faces of P Pyramid 2261 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 2262 ! For each face in pyramid, calculate values of face functions 2263 DO F=1,5 2264 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 2265 2266 ! Do not solve face dofs, if there is not any 2267 IF ( Face % BDOFs <= 0) CYCLE 2268 2269 ! Get face p 2270 p = Face % PDefs % P 2271 2272 ! Handle triangle and square faces separately 2273 SELECT CASE(F) 2274 CASE (1) 2275 ! For each face calculate values of functions from index 2276 ! pairs i,j=2,..,p-2 i+j=4,..,p 2277 DO i=2,p-2 2278 DO j=2,p-i 2279 IF ( q >= SIZE(BasisDegree) ) CYCLE 2280 q = q + 1 2281 BasisDegree(q) = i+j 2282 END DO 2283 END DO 2284 2285 CASE (2,3,4,5) 2286 ! For each face calculate values of functions from index 2287 ! pairs i,j=0,..,p-3 i+j=0,..,p-3 2288 DO i=0,p-3 2289 DO j=0,p-i-3 2290 IF ( q >= SIZE(BasisDegree) ) CYCLE 2291 q = q + 1 2292 BasisDegree(q) = 3+i+j 2293 END DO 2294 END DO 2295 END SELECT 2296 END DO 2297 END IF 2298 2299 ! Bubbles of P Pyramid 2300 IF (Element % BDOFs > 0) THEN 2301 ! Get element p 2302 p = Element % PDefs % p 2303 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 2304 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 2305 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+2 - AEPS) 2306 2307 ! Calculate value of bubble functions from indexes 2308 ! i,j,k=0,..,p-4 i+j+k=0,..,p-4 2309 DO i=0,p-4 2310 DO j=0,p-i-4 2311 DO k=0,p-i-j-4 2312 IF ( q >= SIZE(BasisDegree)) CYCLE 2313 q = q + 1 2314 BasisDegree(q) = 4+i+j+k 2315 END DO 2316 END DO 2317 END DO 2318 END IF 2319 2320!------------------------------------------------------------------------------ 2321! P element code for wedge edges, faces and bubbles 2322 CASE(706) 2323 ! Edges of P Wedge 2324 IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN 2325 ! For each edge in wedge, calculate values of edge functions 2326 DO i=1,9 2327 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2328 2329 ! Do not solve edge dofs, if there is not any 2330 IF (Edge % BDOFs <= 0) CYCLE 2331 2332 ! For each DOF in edge calculate values of edge functions 2333 ! and their derivatives for edge=i and i=k+1 2334 DO k=1,Edge % BDOFs 2335 IF ( q >= SIZE(BasisDegree) ) CYCLE 2336 q = q + 1 2337 2338 ! Use basis compatible with pyramid if necessary 2339 ! @todo Correct this! 2340 IF (Edge % PDefs % pyramidQuadEdge) THEN 2341 CALL Fatal('ElementInfo','Pyramid compatible wedge edge basis NIY!') 2342 END IF 2343 BasisDegree(q) = 1+k 2344 END DO 2345 END DO 2346 END IF 2347 2348 ! Faces of P Wedge 2349 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 2350 ! For each face in wedge, calculate values of face functions 2351 DO F=1,5 2352 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 2353 2354 ! Do not solve face dofs, if there is not any 2355 IF ( Face % BDOFs <= 0) CYCLE 2356 2357 p = Face % PDefs % P 2358 2359 ! Handle triangle and square faces separately 2360 SELECT CASE(F) 2361 CASE (1,2) 2362 ! For each face calculate values of functions from index 2363 ! pairs i,j=0,..,p-3 i+j=0,..,p-3 2364 DO i=0,p-3 2365 DO j=0,p-i-3 2366 IF ( q >= SIZE(BasisDegree) ) CYCLE 2367 q = q + 1 2368 BasisDegree(q) = 3+i+j 2369 END DO 2370 END DO 2371 CASE (3,4,5) 2372 ! For each face calculate values of functions from index 2373 ! pairs i,j=2,..,p-2 i+j=4,..,p 2374 DO i=2,p-2 2375 DO j=2,p-i 2376 IF ( q >= SIZE(BasisDegree) ) CYCLE 2377 q = q + 1 2378 BasisDegree(q) = i+j 2379 END DO 2380 END DO 2381 END SELECT 2382 2383 END DO 2384 END IF 2385 2386 ! Bubbles of P Wedge 2387 IF ( Element % BDOFs > 0 ) THEN 2388 ! Get p from element 2389 p = Element % PDefs % P 2390 nb = MAX( GetBubbleDOFs( Element, p ), Element % BDOFs ) 2391 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 2392 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+3 - AEPS) 2393 2394 ! For each bubble calculate value of basis function and its derivative 2395 ! for index pairs i,j=0,..,p-5 k=2,..,p-3 i+j+k=2,..,p-3 2396 DO i=0,p-5 2397 DO j=0,p-5-i 2398 DO k=2,p-3-i-j 2399 IF ( q >= SIZE(BasisDegree) ) CYCLE 2400 q = q + 1 2401 BasisDegree(q) = 3+i+j+k 2402 END DO 2403 END DO 2404 END DO 2405 END IF 2406 2407!------------------------------------------------------------------------------ 2408! P element code for brick edges, faces and bubbles 2409 CASE(808) 2410 ! Edges of P brick 2411 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2412 ! For each edge in brick, calculate values of edge functions 2413 DO i=1,12 2414 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2415 2416 ! Do not solve edge dofs, if there is not any 2417 IF (Edge % BDOFs <= 0) CYCLE 2418 2419 ! For each DOF in edge calculate values of edge functions 2420 ! and their derivatives for edge=i and i=k+1 2421 DO k=1,Edge % BDOFs 2422 IF ( q >= SIZE(BasisDegree) ) CYCLE 2423 q = q + 1 2424 BasisDegree(q) = 1+k 2425 END DO 2426 END DO 2427 END IF 2428 2429 ! Faces of P brick 2430 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 2431 ! For each face in brick, calculate values of face functions 2432 DO F=1,6 2433 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 2434 2435 ! Do not calculate face values if no dofs 2436 IF (Face % BDOFs <= 0) CYCLE 2437 2438 ! Get p for face 2439 p = Face % PDefs % P 2440 2441 ! For each face calculate values of functions from index 2442 ! pairs i,j=2,..,p-2 i+j=4,..,p 2443 DO i=2,p-2 2444 DO j=2,p-i 2445 IF ( q >= SIZE(BasisDegree) ) CYCLE 2446 q = q + 1 2447 BasisDegree(q) = i+j 2448 END DO 2449 END DO 2450 END DO 2451 END IF 2452 2453 ! Bubbles of p brick 2454 IF ( Element % BDOFs > 0 ) THEN 2455 ! Get p from bubble DOFs 2456 p = Element % PDefs % P 2457 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 2458 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 2459 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+4 - AEPS) 2460 2461 ! For each bubble calculate value of basis function and its derivative 2462 ! for index pairs i,j,k=2,..,p-4, i+j+k=6,..,p 2463 DO i=2,p-4 2464 DO j=2,p-i-2 2465 DO k=2,p-i-j 2466 IF ( q >= SIZE(BasisDegree) ) CYCLE 2467 q = q + 1 2468 BasisDegree(q) = i+j+k 2469 END DO 2470 END DO 2471 END DO 2472 END IF 2473 2474 END SELECT 2475 END IF ! P element flag check 2476!------------------------------------------------------------------------------ 2477 END SUBROUTINE ElementBasisDegree 2478!------------------------------------------------------------------------------ 2479 2480 2481!------------------------------------------------------------------------------ 2482!> Return the referential description b(f(p)) of the basis function b(x), 2483!> with f mapping points p on a reference element to points x on a physical 2484!> element. The referential description of the spatial gradient field grad b 2485!> and, if requested, the second spatial derivatives may also be returned. 2486!> Also return the square root of the determinant of the metric tensor 2487!> (=sqrt(det(J^TJ))) related to the mapping f. 2488!------------------------------------------------------------------------------ 2489 RECURSIVE FUNCTION ElementInfo( Element, Nodes, u, v, w, detJ, & 2490 Basis, dBasisdx, ddBasisddx, SecondDerivatives, Bubbles, BasisDegree, & 2491 EdgeBasis, RotBasis, USolver ) RESULT(stat) 2492!------------------------------------------------------------------------------ 2493 IMPLICIT NONE 2494 2495 TYPE(Element_t), TARGET :: Element !< Element structure 2496 TYPE(Nodes_t) :: Nodes !< Element nodal coordinates. 2497 REAL(KIND=dp) :: u !< 1st local coordinate at which to calculate the basis function. 2498 REAL(KIND=dp) :: v !< 2nd local coordinate. 2499 REAL(KIND=dp) :: w !< 3rd local coordinate. 2500 REAL(KIND=dp) :: detJ !< Square root of determinant of element coordinate system metric 2501 REAL(KIND=dp) :: Basis(:) !< Basis function values at p=(u,v,w) 2502 REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:) !< Global first derivatives of basis functions at (u,v,w) 2503 REAL(KIND=dp), OPTIONAL :: ddBasisddx(:,:,:) !< Global second derivatives of basis functions at (u,v,w) if requested 2504 INTEGER, OPTIONAL :: BasisDegree(:) !< Degree of each basis function in Basis(:) vector. 2505 !! May be used with P element basis functions 2506 LOGICAL, OPTIONAL :: SecondDerivatives !< Are the second derivatives needed? (still present for historical reasons) 2507 TYPE(Solver_t), POINTER, OPTIONAL :: USolver !< The solver used to call the basis functions. 2508 LOGICAL, OPTIONAL :: Bubbles !< Are the bubbles to be evaluated. 2509 REAL(KIND=dp), OPTIONAL :: EdgeBasis(:,:) !< If present, the values of H(curl)-conforming basis functions B(f(p)) 2510 REAL(KIND=dp), OPTIONAL :: RotBasis(:,:) !< The referential description of the spatial curl of B 2511 LOGICAL :: Stat !< If .FALSE. element is degenerate. 2512!------------------------------------------------------------------------------ 2513! Local variables 2514!------------------------------------------------------------------------------ 2515 TYPE(Solver_t), POINTER :: PSolver => NULL() 2516 REAL(KIND=dp) :: BubbleValue, dBubbledx(3), t, s, LtoGMap(3,3) 2517 LOGICAL :: invert, degrees 2518 INTEGER :: i, j, k, l, q, p, f, n, nb, dim, cdim, locali, localj, & 2519 tmp(4), direction(4) 2520 REAL(KIND=dp) :: LinBasis(8), dLinBasisdx(8,3), ElmMetric(3,3) 2521 2522 REAL(KIND=dp) :: NodalBasis(Element % TYPE % NumberOfNodes), & 2523 dLBasisdx(MAX(SIZE(Nodes % x),SIZE(Basis)),3) 2524 2525 TYPE(Element_t) :: Bubble 2526 TYPE(Element_t), POINTER :: Edge, Face 2527 INTEGER :: EdgeBasisDegree 2528 LOGICAL :: PerformPiolaTransform, Found 2529 2530 SAVE PSolver, EdgeBasisDegree, PerformPiolaTransform 2531!------------------------------------------------------------------------------ 2532 IF(PRESENT(EdgeBasis)) THEN 2533 IF( PRESENT( USolver ) ) THEN 2534 IF( .NOT. ASSOCIATED( USolver, PSolver ) ) THEN 2535 IF( ListGetLogical(USolver % Values,'Quadratic Approximation', Found ) ) THEN 2536 EdgeBasisDegree = 2 2537 PerformPiolaTransform = .TRUE. 2538 ELSE 2539 EdgeBasisDegree = 1 2540 PerformPiolaTransform = ListGetLogical(USolver % Values,'Use Piola Transform', Found ) 2541 END IF 2542 PSolver => USolver 2543 END IF 2544 ELSE 2545 EdgeBasisDegree = 1 2546 PerformPiolaTransform = .TRUE. 2547 END IF 2548 IF( PerformPiolaTransform ) THEN 2549 stat = EdgeElementInfo(Element,Nodes,u,v,w,detF=Detj,Basis=Basis, & 2550 EdgeBasis=EdgeBasis,RotBasis=RotBasis,dBasisdx=dBasisdx,& 2551 BasisDegree = EdgeBasisDegree, ApplyPiolaTransform = PerformPiolaTransform ) 2552 ELSE 2553 ! Is this really necessary to call in case no piola version? 2554 stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis, dBasisdx ) 2555 CALL GetEdgeBasis(Element,EdgeBasis,RotBasis,Basis,dBasisdx) 2556 END IF 2557 RETURN 2558 END IF 2559 2560 stat = .TRUE. 2561 n = Element % TYPE % NumberOfNodes 2562 dim = Element % TYPE % DIMENSION 2563 cdim = CoordinateSystemDimension() 2564 2565 IF ( Element % TYPE % ElementCode == 101 ) THEN 2566 detJ = 1.0d0 2567 Basis(1) = 1.0d0 2568 IF ( PRESENT(dBasisdx) ) dBasisdx(1,:) = 0.0d0 2569 RETURN 2570 END IF 2571 2572 Basis = 0.0d0 2573 CALL NodalBasisFunctions(n, Basis, element, u, v, w) 2574 2575 dLbasisdx = 0.0d0 2576 CALL NodalFirstDerivatives(n, dLBasisdx, element, u, v, w) 2577 2578 q = n 2579 2580 ! P ELEMENT CODE: 2581 ! --------------- 2582 IF ( isActivePElement(element) ) THEN 2583 2584 ! Check for need of P basis degrees and set degree of 2585 ! linear basis if vector asked: 2586 ! --------------------------------------------------- 2587 degrees = .FALSE. 2588 IF ( PRESENT(BasisDegree)) THEN 2589 degrees = .TRUE. 2590 BasisDegree = 0 2591 BasisDegree(1:n) = 1 2592 END IF 2593 2594!------------------------------------------------------------------------------ 2595 SELECT CASE( Element % TYPE % ElementCode ) 2596!------------------------------------------------------------------------------ 2597 2598 ! P element code for line element: 2599 ! -------------------------------- 2600 CASE(202) 2601 ! Bubbles of line element 2602 IF (Element % BDOFs > 0) THEN 2603 ! For boundary element integration check direction 2604 invert = .FALSE. 2605 IF ( Element % PDefs % isEdge .AND. & 2606 Element % NodeIndexes(1)>Element % NodeIndexes(2) ) invert = .TRUE. 2607 2608 ! For each bubble in line element get value of basis function 2609 DO i=1, Element % BDOFs 2610 IF (q >= SIZE(Basis)) CYCLE 2611 q = q + 1 2612 2613 Basis(q) = LineBubblePBasis(i+1,u,invert) 2614 dLBasisdx(q,1) = dLineBubblePBasis(i+1,u,invert) 2615 2616 ! Polynomial degree of basis function to vector 2617 IF (degrees) BasisDegree(q) = 1+i 2618 END DO 2619 END IF 2620 2621!------------------------------------------------------------------------------ 2622! P element code for edges and bubbles of triangle 2623 CASE(303) 2624 ! Edges of triangle 2625 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2626 ! For each edge calculate the value of edge basis function 2627 DO i=1,3 2628 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2629 2630 ! Get local number of edge start and endpoint nodes 2631 tmp(1:2) = getTriangleEdgeMap(i) 2632 locali = tmp(1) 2633 localj = tmp(2) 2634 2635 ! Invert edge for parity if needed 2636 invert = .FALSE. 2637 IF ( Element % NodeIndexes(locali)>Element % NodeIndexes(localj) ) invert=.TRUE. 2638 2639 ! For each dof in edge get value of p basis function 2640 DO k=1,Edge % BDOFs 2641 IF (q >= SIZE(Basis)) CYCLE 2642 q = q + 1 2643 2644 ! Value of basis functions for edge=i and i=k+1 by parity 2645 Basis(q) = TriangleEdgePBasis(i, k+1, u, v, invert) 2646 ! Value of derivative of basis function 2647 dLBasisdx(q,1:2) = dTriangleEdgePBasis(i, k+1, u, v, invert) 2648 2649 ! Polynomial degree of basis function to vector 2650 IF (degrees) BasisDegree(q) = 1+k 2651 END DO 2652 END DO 2653 END IF 2654 2655 ! Bubbles of p triangle 2656 IF ( Element % BDOFs > 0 ) THEN 2657 ! Get element p 2658 p = Element % PDefs % P 2659 2660 nb = MAX( GetBubbleDOFs( Element, p ), Element % BDOFs ) 2661 p = CEILING( ( 3.0d0+SQRT(1.0d0+8.0d0*nb) ) / 2.0d0 - AEPS) 2662 2663 ! For boundary element direction needs to be calculated 2664 IF (Element % PDefs % isEdge) THEN 2665 direction = 0 2666 ! Get direction of this face (mask for face = boundary element nodes) 2667 direction(1:3) = getTriangleFaceDirection(Element, [ 1,2,3 ]) 2668 END IF 2669 2670 DO i = 0,p-3 2671 DO j = 0,p-i-3 2672 IF ( q >= SIZE(Basis) ) CYCLE 2673 q = q + 1 2674 2675 ! Get bubble basis functions and their derivatives 2676 ! 3d Boundary element has a direction 2677 IF (Element % PDefs % isEdge) THEN 2678 Basis(q) = TriangleEBubblePBasis(i,j,u,v,direction) 2679 dLBasisdx(q,1:2) = dTriangleEBubblePBasis(i,j,u,v,direction) 2680 ELSE 2681 ! 2d element bubbles have no direction 2682 Basis(q) = TriangleBubblePBasis(i,j,u,v) 2683 dLBasisdx(q,1:2) = dTriangleBubblePBasis(i,j,u,v) 2684 END IF 2685 2686 ! Polynomial degree of basis function to vector 2687 IF (degrees) BasisDegree(q) = 3+i+j 2688 END DO 2689 END DO 2690 END IF 2691!------------------------------------------------------------------------------ 2692! P element code for quadrilateral edges and bubbles 2693 CASE(404) 2694 ! Edges of p quadrilateral 2695 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2696 ! For each edge begin node calculate values of edge functions 2697 DO i=1,4 2698 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2699 2700 ! Choose correct parity by global edge dofs 2701 tmp(1:2) = getQuadEdgeMap(i) 2702 locali = tmp(1) 2703 localj = tmp(2) 2704 2705 ! Invert parity if needed 2706 invert = .FALSE. 2707 IF (Element % NodeIndexes(locali) > Element % NodeIndexes(localj)) invert = .TRUE. 2708 2709 ! For each DOF in edge calculate value of p basis function 2710 DO k=1,Edge % BDOFs 2711 IF ( q >= SIZE(Basis) ) CYCLE 2712 q = q + 1 2713 2714 ! For pyramid square face edges use different basis 2715 IF (Edge % PDefs % pyramidQuadEdge) THEN 2716 Basis(q) = QuadPyraEdgePBasis(i,k+1,u,v,invert) 2717 dLBasisdx(q,1:2) = dQuadPyraEdgePBasis(i,k+1,u,v,invert) 2718 ! Normal case, use basis of quadrilateral 2719 ELSE 2720 ! Get values of basis functions for edge=i and i=k+1 by parity 2721 Basis(q) = QuadEdgePBasis(i,k+1,u,v,invert) 2722 ! Get value of derivatives of basis functions 2723 dLBasisdx(q,1:2) = dQuadEdgePBasis(i,k+1,u,v,invert) 2724 END IF 2725 2726 ! Polynomial degree of basis function to vector 2727 IF (degrees) BasisDegree(q) = 1+k 2728 END DO 2729 END DO 2730 END IF 2731 2732 ! Bubbles of p quadrilateral 2733 IF ( Element % BDOFs > 0 ) THEN 2734 ! Get element P 2735 p = Element % PDefs % P 2736 2737 nb = MAX( GetBubbleDOFs( Element, p ), Element % BDOFs ) 2738 p = CEILING( ( 5.0d0+SQRT(1.0d0+8.0d0*nb) ) / 2.0d0 - AEPS) 2739 2740 ! For boundary element direction needs to be calculated 2741 IF (Element % PDefs % isEdge) THEN 2742 direction = 0 2743 direction = getSquareFaceDirection(Element, [ 1,2,3,4 ]) 2744 END IF 2745 2746 ! For each bubble calculate value of p basis function 2747 ! and their derivatives for index pairs i,j>=2, i+j=4,...,p 2748 DO i=2,(p-2) 2749 DO j=2,(p-i) 2750 IF ( q >= SIZE(Basis) ) CYCLE 2751 q = q + 1 2752 2753 ! Get values of bubble functions 2754 ! 3D boundary elements have a direction 2755 IF (Element % PDefs % isEdge) THEN 2756 Basis(q) = QuadBubblePBasis(i,j,u,v,direction) 2757 dLBasisdx(q,1:2) = dQuadBubblePBasis(i,j,u,v,direction) 2758 ELSE 2759 ! 2d element bubbles have no direction 2760 Basis(q) = QuadBubblePBasis(i,j,u,v) 2761 dLBasisdx(q,1:2) = dQuadBubblePBasis(i,j,u,v) 2762 END IF 2763 2764 ! Polynomial degree of basis function to vector 2765 IF (degrees) BasisDegree(q) = i+j 2766 END DO 2767 END DO 2768 END IF 2769!------------------------------------------------------------------------------ 2770! P element code for tetrahedron edges, faces and bubbles 2771 CASE(504) 2772 ! Edges of p tetrahedron 2773 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 2774 ! For each edge calculate value of edge functions 2775 DO i=1,6 2776 Edge => CurrentModel % Solver % Mesh % Edges (Element % EdgeIndexes(i)) 2777 2778 ! Do not solve edge DOFS if there is not any 2779 IF (Edge % BDOFs <= 0) CYCLE 2780 2781 ! For each DOF in edge calculate value of edge functions 2782 ! and their derivatives for edge=i, i=k+1 2783 DO k=1, Edge % BDOFs 2784 IF (q >= SIZE(Basis)) CYCLE 2785 q = q + 1 2786 2787 Basis(q) = TetraEdgePBasis(i,k+1,u,v,w, Element % PDefs % TetraType) 2788 dLBasisdx(q,1:3) = dTetraEdgePBasis(i,k+1,u,v,w, Element % PDefs % TetraType) 2789 2790 ! Polynomial degree of basis function to vector 2791 IF (degrees) BasisDegree(q) = 1+k 2792 END DO 2793 END DO 2794 END IF 2795 2796 ! Faces of p tetrahedron 2797 IF ( ASSOCIATED( Element % FaceIndexes )) THEN 2798 ! For each face calculate value of face functions 2799 DO F=1,4 2800 Face => CurrentModel % Solver % Mesh % Faces (Element % FaceIndexes(F)) 2801 2802 ! Do not solve face DOFs if there is not any 2803 IF (Face % BDOFs <= 0) CYCLE 2804 2805 ! Get face p 2806 p = Face % PDefs % P 2807 2808 ! For each DOF in face calculate value of face functions and 2809 ! their derivatives for face=F and index pairs 2810 ! i,j=0,..,p-3, i+j=0,..,p-3 2811 DO i=0,p-3 2812 DO j=0,p-i-3 2813 IF (q >= SIZE(Basis)) CYCLE 2814 q = q + 1 2815 2816 Basis(q) = TetraFacePBasis(F,i,j,u,v,w, Element % PDefs % TetraType) 2817 dLBasisdx(q,1:3) = dTetraFacePBasis(F,i,j,u,v,w, Element % PDefs % TetraType) 2818 2819 ! Polynomial degree of basis function to vector 2820 IF (degrees) BasisDegree(q) = 3+i+j 2821 END DO 2822 END DO 2823 END DO 2824 END IF 2825 2826 ! Bubbles of p tetrahedron 2827 IF ( Element % BDOFs > 0 ) THEN 2828 p = Element % PDefs % P 2829 2830 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 2831 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 2832 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+2 - AEPS) 2833 2834 ! For each DOF in bubbles calculate value of bubble functions 2835 ! and their derivatives for index pairs 2836 ! i,j,k=0,..,p-4 i+j+k=0,..,p-4 2837 DO i=0,p-4 2838 DO j=0,p-i-4 2839 DO k=0,p-i-j-4 2840 IF (q >= SIZE(Basis)) CYCLE 2841 q = q + 1 2842 2843 Basis(q) = TetraBubblePBasis(i,j,k,u,v,w) 2844 dLBasisdx(q,1:3) = dTetraBubblePBasis(i,j,k,u,v,w) 2845 2846 ! Polynomial degree of basis function to vector 2847 IF (degrees) BasisDegree(q) = 4+i+j+k 2848 END DO 2849 END DO 2850 END DO 2851 2852 END IF 2853!------------------------------------------------------------------------------ 2854! P element code for pyramid edges, faces and bubbles 2855 CASE(605) 2856 ! Edges of P Pyramid 2857 IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN 2858 ! For each edge in wedge, calculate values of edge functions 2859 DO i=1,8 2860 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2861 2862 ! Do not solve edge dofs, if there is not any 2863 IF (Edge % BDOFs <= 0) CYCLE 2864 2865 ! Get local indexes of current edge 2866 tmp(1:2) = getPyramidEdgeMap(i) 2867 locali = tmp(1) 2868 localj = tmp(2) 2869 2870 ! Determine edge direction 2871 invert = .FALSE. 2872 2873 ! Invert edge if local first node has greater global index than second one 2874 IF ( Element % NodeIndexes(locali) > Element % NodeIndexes(localj) ) invert = .TRUE. 2875 2876 ! For each DOF in edge calculate values of edge functions 2877 ! and their derivatives for edge=i and i=k+1 2878 DO k=1,Edge % BDOFs 2879 IF ( q >= SIZE(Basis) ) CYCLE 2880 q = q + 1 2881 2882 ! Get values of edge basis functions and their derivatives 2883 Basis(q) = PyramidEdgePBasis(i,k+1,u,v,w,invert) 2884 dLBasisdx(q,1:3) = dPyramidEdgePBasis(i,k+1,u,v,w,invert) 2885 2886 ! Polynomial degree of basis function to vector 2887 IF (degrees) BasisDegree(q) = 1+k 2888 END DO 2889 END DO 2890 END IF 2891 2892 ! Faces of P Pyramid 2893 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 2894 ! For each face in pyramid, calculate values of face functions 2895 DO F=1,5 2896 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 2897 2898 ! Do not solve face dofs, if there is not any 2899 IF ( Face % BDOFs <= 0) CYCLE 2900 2901 ! Get face p 2902 p = Face % PDefs % P 2903 2904 ! Handle triangle and square faces separately 2905 SELECT CASE(F) 2906 CASE (1) 2907 direction = 0 2908 ! Get global direction vector for enforcing parity 2909 tmp(1:4) = getPyramidFaceMap(F) 2910 direction(1:4) = getSquareFaceDirection( Element, tmp(1:4) ) 2911 2912 ! For each face calculate values of functions from index 2913 ! pairs i,j=2,..,p-2 i+j=4,..,p 2914 DO i=2,p-2 2915 DO j=2,p-i 2916 IF ( q >= SIZE(Basis) ) CYCLE 2917 q = q + 1 2918 2919 Basis(q) = PyramidFacePBasis(F,i,j,u,v,w,direction) 2920 dLBasisdx(q,:) = dPyramidFacePBasis(F,i,j,u,v,w,direction) 2921 2922 ! Polynomial degree of basis function to vector 2923 IF (degrees) BasisDegree(q) = i+j 2924 END DO 2925 END DO 2926 2927 CASE (2,3,4,5) 2928 direction = 0 2929 ! Get global direction vector for enforcing parity 2930 tmp(1:4) = getPyramidFaceMap(F) 2931 direction(1:3) = getTriangleFaceDirection( Element, tmp(1:3) ) 2932 2933 ! For each face calculate values of functions from index 2934 ! pairs i,j=0,..,p-3 i+j=0,..,p-3 2935 DO i=0,p-3 2936 DO j=0,p-i-3 2937 IF ( q >= SIZE(Basis) ) CYCLE 2938 q = q + 1 2939 2940 Basis(q) = PyramidFacePBasis(F,i,j,u,v,w,direction) 2941 dLBasisdx(q,:) = dPyramidFacePBasis(F,i,j,u,v,w,direction) 2942 2943 ! Polynomial degree of basis function to vector 2944 IF (degrees) BasisDegree(q) = 3+i+j 2945 END DO 2946 END DO 2947 END SELECT 2948 END DO 2949 END IF 2950 2951 ! Bubbles of P Pyramid 2952 IF (Element % BDOFs > 0) THEN 2953 ! Get element p 2954 p = Element % PDefs % p 2955 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 2956 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 2957 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+2 - AEPS) 2958 2959 ! Calculate value of bubble functions from indexes 2960 ! i,j,k=0,..,p-4 i+j+k=0,..,p-4 2961 DO i=0,p-4 2962 DO j=0,p-i-4 2963 DO k=0,p-i-j-4 2964 IF ( q >= SIZE(Basis)) CYCLE 2965 q = q + 1 2966 2967 Basis(q) = PyramidBubblePBasis(i,j,k,u,v,w) 2968 dLBasisdx(q,:) = dPyramidBubblePBasis(i,j,k,u,v,w) 2969 2970 ! Polynomial degree of basis function to vector 2971 IF (degrees) BasisDegree(q) = 4+i+j+k 2972 END DO 2973 END DO 2974 END DO 2975 END IF 2976 2977!------------------------------------------------------------------------------ 2978! P element code for wedge edges, faces and bubbles 2979 CASE(706) 2980 ! Edges of P Wedge 2981 IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN 2982 ! For each edge in wedge, calculate values of edge functions 2983 DO i=1,9 2984 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 2985 2986 ! Do not solve edge dofs, if there is not any 2987 IF (Edge % BDOFs <= 0) CYCLE 2988 2989 ! Get local indexes of current edge 2990 tmp(1:2) = getWedgeEdgeMap(i) 2991 locali = tmp(1) 2992 localj = tmp(2) 2993 2994 ! Determine edge direction 2995 invert = .FALSE. 2996 ! Invert edge if local first node has greater global index than second one 2997 IF ( Element % NodeIndexes(locali) > Element % NodeIndexes(localj) ) invert = .TRUE. 2998 2999 ! For each DOF in edge calculate values of edge functions 3000 ! and their derivatives for edge=i and i=k+1 3001 DO k=1,Edge % BDOFs 3002 IF ( q >= SIZE(Basis) ) CYCLE 3003 q = q + 1 3004 3005 ! Use basis compatible with pyramid if necessary 3006 ! @todo Correct this! 3007 IF (Edge % PDefs % pyramidQuadEdge) THEN 3008 CALL Fatal('ElementInfo','Pyramid compatible wedge edge basis NIY!') 3009 END IF 3010 3011 ! Get values of edge basis functions and their derivatives 3012 Basis(q) = WedgeEdgePBasis(i,k+1,u,v,w,invert) 3013 dLBasisdx(q,1:3) = dWedgeEdgePBasis(i,k+1,u,v,w,invert) 3014 3015 ! Polynomial degree of basis function to vector 3016 IF (degrees) BasisDegree(q) = 1+k 3017 END DO 3018 END DO 3019 END IF 3020 3021 ! Faces of P Wedge 3022 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 3023 ! For each face in wedge, calculate values of face functions 3024 DO F=1,5 3025 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 3026 3027 ! Do not solve face dofs, if there is not any 3028 IF ( Face % BDOFs <= 0) CYCLE 3029 3030 p = Face % PDefs % P 3031 3032 ! Handle triangle and square faces separately 3033 SELECT CASE(F) 3034 CASE (1,2) 3035 direction = 0 3036 ! Get global direction vector for enforcing parity 3037 tmp(1:4) = getWedgeFaceMap(F) 3038 direction(1:3) = getTriangleFaceDirection( Element, tmp(1:3) ) 3039 3040 ! For each face calculate values of functions from index 3041 ! pairs i,j=0,..,p-3 i+j=0,..,p-3 3042 DO i=0,p-3 3043 DO j=0,p-i-3 3044 IF ( q >= SIZE(Basis) ) CYCLE 3045 q = q + 1 3046 3047 Basis(q) = WedgeFacePBasis(F,i,j,u,v,w,direction) 3048 dLBasisdx(q,:) = dWedgeFacePBasis(F,i,j,u,v,w,direction) 3049 3050 ! Polynomial degree of basis function to vector 3051 IF (degrees) BasisDegree(q) = 3+i+j 3052 END DO 3053 END DO 3054 CASE (3,4,5) 3055 direction = 0 3056 ! Get global direction vector for enforcing parity 3057 invert = .FALSE. 3058 tmp(1:4) = getWedgeFaceMap(F) 3059 direction(1:4) = getSquareFaceDirection( Element, tmp(1:4) ) 3060 3061 ! First and second node must form a face in upper or lower triangle 3062 IF (.NOT. wedgeOrdering(direction)) THEN 3063 invert = .TRUE. 3064 tmp(1) = direction(2) 3065 direction(2) = direction(4) 3066 direction(4) = tmp(1) 3067 END IF 3068 3069 ! For each face calculate values of functions from index 3070 ! pairs i,j=2,..,p-2 i+j=4,..,p 3071 DO i=2,p-2 3072 DO j=2,p-i 3073 IF ( q >= SIZE(Basis) ) CYCLE 3074 q = q + 1 3075 3076 IF (.NOT. invert) THEN 3077 Basis(q) = WedgeFacePBasis(F,i,j,u,v,w,direction) 3078 dLBasisdx(q,:) = dWedgeFacePBasis(F,i,j,u,v,w,direction) 3079 ELSE 3080 Basis(q) = WedgeFacePBasis(F,j,i,u,v,w,direction) 3081 dLBasisdx(q,:) = dWedgeFacePBasis(F,j,i,u,v,w,direction) 3082 END IF 3083 3084 ! Polynomial degree of basis function to vector 3085 IF (degrees) BasisDegree(q) = i+j 3086 END DO 3087 END DO 3088 END SELECT 3089 3090 END DO 3091 END IF 3092 3093 ! Bubbles of P Wedge 3094 IF ( Element % BDOFs > 0 ) THEN 3095 ! Get p from element 3096 p = Element % PDefs % P 3097 nb = MAX( GetBubbleDOFs( Element, p ), Element % BDOFs ) 3098 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 3099 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+3 - AEPS) 3100 3101 ! For each bubble calculate value of basis function and its derivative 3102 ! for index pairs i,j=0,..,p-5 k=2,..,p-3 i+j+k=2,..,p-3 3103 DO i=0,p-5 3104 DO j=0,p-5-i 3105 DO k=2,p-3-i-j 3106 IF ( q >= SIZE(Basis) ) CYCLE 3107 q = q + 1 3108 3109 Basis(q) = WedgeBubblePBasis(i,j,k,u,v,w) 3110 dLBasisdx(q,:) = dWedgeBubblePBasis(i,j,k,u,v,w) 3111 3112 ! Polynomial degree of basis function to vector 3113 IF (degrees) BasisDegree(q) = 3+i+j+k 3114 END DO 3115 END DO 3116 END DO 3117 END IF 3118 3119!------------------------------------------------------------------------------ 3120! P element code for brick edges, faces and bubbles 3121 CASE(808) 3122 ! Edges of P brick 3123 IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN 3124 ! For each edge in brick, calculate values of edge functions 3125 DO i=1,12 3126 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 3127 3128 ! Do not solve edge dofs, if there is not any 3129 IF (Edge % BDOFs <= 0) CYCLE 3130 3131 ! Get local indexes of current edge 3132 tmp(1:2) = getBrickEdgeMap(i) 3133 locali = tmp(1) 3134 localj = tmp(2) 3135 3136 ! Determine edge direction 3137 invert = .FALSE. 3138 3139 ! Invert edge if local first node has greater global index than second one 3140 IF ( Element % NodeIndexes(locali) > Element % NodeIndexes(localj) ) invert = .TRUE. 3141 3142 ! For each DOF in edge calculate values of edge functions 3143 ! and their derivatives for edge=i and i=k+1 3144 DO k=1,Edge % BDOFs 3145 IF ( q >= SIZE(Basis) ) CYCLE 3146 q = q + 1 3147 3148 ! For edges connected to pyramid square face, use different basis 3149 IF (Edge % PDefs % pyramidQuadEdge) THEN 3150 ! Get values of edge basis functions and their derivatives 3151 Basis(q) = BrickPyraEdgePBasis(i,k+1,u,v,w,invert) 3152 dLBasisdx(q,1:3) = dBrickPyraEdgePBasis(i,k+1,u,v,w,invert) 3153 ! Normal case. Use standard brick edge functions 3154 ELSE 3155 ! Get values of edge basis functions and their derivatives 3156 Basis(q) = BrickEdgePBasis(i,k+1,u,v,w,invert) 3157 dLBasisdx(q,1:3) = dBrickEdgePBasis(i,k+1,u,v,w,invert) 3158 END IF 3159 3160 ! Polynomial degree of basis function to vector 3161 IF (degrees) BasisDegree(q) = 1+k 3162 END DO 3163 END DO 3164 END IF 3165 3166 ! Faces of P brick 3167 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 3168 ! For each face in brick, calculate values of face functions 3169 DO F=1,6 3170 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 3171 3172 ! Do not calculate face values if no dofs 3173 IF (Face % BDOFs <= 0) CYCLE 3174 3175 ! Get p for face 3176 p = Face % PDefs % P 3177 3178 ! Generate direction vector for this face 3179 tmp(1:4) = getBrickFaceMap(F) 3180 direction(1:4) = getSquareFaceDirection(Element, tmp) 3181 3182 ! For each face calculate values of functions from index 3183 ! pairs i,j=2,..,p-2 i+j=4,..,p 3184 DO i=2,p-2 3185 DO j=2,p-i 3186 IF ( q >= SIZE(Basis) ) CYCLE 3187 q = q + 1 3188 Basis(q) = BrickFacePBasis(F,i,j,u,v,w,direction) 3189 dLBasisdx(q,:) = dBrickFacePBasis(F,i,j,u,v,w,direction) 3190 3191 ! Polynomial degree of basis function to vector 3192 IF (degrees) BasisDegree(q) = i+j 3193 END DO 3194 END DO 3195 END DO 3196 END IF 3197 3198 ! Bubbles of p brick 3199 IF ( Element % BDOFs > 0 ) THEN 3200 ! Get p from bubble DOFs 3201 p = Element % PDefs % P 3202 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 3203 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 3204 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+4 - AEPS) 3205 3206 3207 ! For each bubble calculate value of basis function and its derivative 3208 ! for index pairs i,j,k=2,..,p-4, i+j+k=6,..,p 3209 DO i=2,p-4 3210 DO j=2,p-i-2 3211 DO k=2,p-i-j 3212 IF ( q >= SIZE(Basis) ) CYCLE 3213 q = q + 1 3214 Basis(q) = BrickBubblePBasis(i,j,k,u,v,w) 3215 dLBasisdx(q,:) = dBrickBubblePBasis(i,j,k,u,v,w) 3216 3217 ! Polynomial degree of basis function to vector 3218 IF (degrees) BasisDegree(q) = i+j+k 3219 END DO 3220 END DO 3221 END DO 3222 END IF 3223 3224 END SELECT 3225 END IF ! P element flag check 3226!------------------------------------------------------------------------------ 3227 3228 ! Element (contravariant) metric and square root of determinant 3229 !-------------------------------------------------------------- 3230 IF ( .NOT. ElementMetric( q, Element, Nodes, & 3231 ElmMetric, detJ, dLBasisdx, LtoGMap ) ) THEN 3232 stat = .FALSE. 3233 RETURN 3234 END IF 3235 3236 ! Get global first derivatives: 3237 !------------------------------ 3238 IF ( PRESENT(dBasisdx) ) THEN 3239 dBasisdx = 0.0d0 3240 DO i=1,q 3241 DO j=1,cdim 3242 DO k=1,dim 3243 dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LtoGMap(j,k) 3244 END DO 3245 END DO 3246 END DO 3247 END IF 3248 3249 ! Get matrix of second derivatives, if needed: 3250 !--------------------------------------------- 3251 IF ( PRESENT(ddBasisddx) .AND. PRESENT(SecondDerivatives) ) THEN 3252 IF ( SecondDerivatives ) THEN 3253 NodalBasis = 0.0d0 3254 ddBasisddx(1:n,:,:) = 0.0d0 3255 DO q=1,n 3256 NodalBasis(q) = 1.0d0 3257 CALL GlobalSecondDerivatives(Element,Nodes,NodalBasis, & 3258 ddBasisddx(q,:,:),u,v,w,ElmMetric,dLBasisdx ) 3259 NodalBasis(q) = 0.0d0 3260 END DO 3261 END IF 3262 END IF 3263 3264!------------------------------------------------------------------------------ 3265! Generate bubble basis functions, if requested. Bubble basis is as follows: 3266! B_i (=(N_(i+n)) = B * N_i, where N_i:s are the nodal basis functions of 3267! the element, and B the basic bubble, i.e. the product of nodal basis 3268! functions of the corresponding linear element for triangles and tetras, 3269! and product of two diagonally opposed nodal basisfunctions of the 3270! corresponding (bi-,tri-)linear element for 1d-elements, quads and hexas. 3271!------------------------------------------------------------------------------ 3272 IF ( PRESENT( Bubbles ) ) THEN 3273 Bubble % BDOFs = 0 3274 NULLIFY( Bubble % PDefs ) 3275 NULLIFY( Bubble % EdgeIndexes ) 3276 NULLIFY( Bubble % FaceIndexes ) 3277 NULLIFY( Bubble % BubbleIndexes ) 3278 3279 IF ( Bubbles .AND. SIZE(Basis) >= 2*n ) THEN 3280 3281 SELECT CASE(Element % TYPE % ElementCode / 100) 3282 CASE(2) 3283 3284 IF ( Element % TYPE % ElementCode == 202 ) THEN 3285 LinBasis(1:n) = Basis(1:n) 3286 dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim) 3287 ELSE 3288 Bubble % TYPE => GetElementType(202) 3289 3290 stat = ElementInfo( Bubble, nodes, u, v, w, detJ, & 3291 LinBasis, dLinBasisdx ) 3292 END IF 3293 3294 BubbleValue = LinBasis(1) * LinBasis(2) 3295 3296 DO i=1,n 3297 Basis(n+i) = Basis(i) * BubbleValue 3298 DO j=1,cdim 3299 dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue 3300 3301 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3302 dLinBasisdx(1,j) * LinBasis(2) 3303 3304 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3305 dLinBasisdx(2,j) * LinBasis(1) 3306 END DO 3307 END DO 3308 3309 CASE(3) 3310 3311 IF ( Element % TYPE % ElementCode == 303 ) THEN 3312 LinBasis(1:n) = Basis(1:n) 3313 dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim) 3314 ELSE 3315 Bubble % TYPE => GetElementType(303) 3316 3317 stat = ElementInfo( Bubble, nodes, u, v, w, detJ, & 3318 LinBasis, dLinBasisdx ) 3319 END IF 3320 3321 BubbleValue = LinBasis(1) * LinBasis(2) * LinBasis(3) 3322 3323 DO i=1,n 3324 Basis(n+i) = Basis(i) * BubbleValue 3325 DO j=1,cdim 3326 dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue 3327 3328 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3329 dLinBasisdx(1,j) * LinBasis(2) * LinBasis(3) 3330 3331 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3332 dLinBasisdx(2,j) * LinBasis(1) * LinBasis(3) 3333 3334 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3335 dLinBasisdx(3,j) * LinBasis(1) * LinBasis(2) 3336 END DO 3337 END DO 3338 3339 CASE(4) 3340 3341 IF ( Element % TYPE % ElementCode == 404 ) THEN 3342 LinBasis(1:n) = Basis(1:n) 3343 dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim) 3344 ELSE 3345 Bubble % TYPE => GetElementType(404) 3346 3347 stat = ElementInfo( Bubble, nodes, u, v, w, detJ, & 3348 LinBasis, dLinBasisdx ) 3349 END IF 3350 3351 BubbleValue = LinBasis(1) * LinBasis(3) 3352 3353 DO i=1,n 3354 Basis(n+i) = Basis(i) * BubbleValue 3355 DO j=1,cdim 3356 dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue 3357 3358 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3359 dLinBasisdx(1,j) * LinBasis(3) 3360 3361 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3362 dLinBasisdx(3,j) * LinBasis(1) 3363 END DO 3364 END DO 3365 3366 CASE(5) 3367 3368 IF ( Element % TYPE % ElementCode == 504 ) THEN 3369 LinBasis(1:n) = Basis(1:n) 3370 dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim) 3371 ELSE 3372 Bubble % TYPE => GetElementType(504) 3373 3374 stat = ElementInfo( Bubble, nodes, u, v, w, detJ, & 3375 LinBasis, dLinBasisdx ) 3376 END IF 3377 3378 BubbleValue = LinBasis(1) * LinBasis(2) * LinBasis(3) * LinBasis(4) 3379 DO i=1,n 3380 Basis(n+i) = Basis(i) * BubbleValue 3381 DO j=1,cdim 3382 dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue 3383 3384 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(1,j) * & 3385 LinBasis(2) * LinBasis(3) * LinBasis(4) 3386 3387 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(2,j) * & 3388 LinBasis(1) * LinBasis(3) * LinBasis(4) 3389 3390 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(3,j) * & 3391 LinBasis(1) * LinBasis(2) * LinBasis(4) 3392 3393 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(4,j) * & 3394 LinBasis(1) * LinBasis(2) * LinBasis(3) 3395 END DO 3396 END DO 3397 3398 CASE(8) 3399 3400 IF ( Element % TYPE % ElementCode == 808 ) THEN 3401 LinBasis(1:n) = Basis(1:n) 3402 dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim) 3403 ELSE 3404 Bubble % TYPE => GetElementType(808) 3405 3406 stat = ElementInfo( Bubble, nodes, u, v, w, detJ, & 3407 LinBasis, dLinBasisdx ) 3408 END IF 3409 3410 BubbleValue = LinBasis(1) * LinBasis(7) 3411 3412 DO i=1,n 3413 Basis(n+i) = Basis(i) * BubbleValue 3414 DO j=1,cdim 3415 dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue 3416 3417 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3418 dLinBasisdx(1,j) * LinBasis(7) 3419 3420 dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * & 3421 dLinBasisdx(7,j) * LinBasis(1) 3422 END DO 3423 END DO 3424 3425 CASE DEFAULT 3426 3427 WRITE( Message, '(a,i4,a)' ) 'Bubbles for element: ', & 3428 Element % TYPE % ElementCode, ' are not implemented.' 3429 CALL Error( 'ElementInfo', Message ) 3430 CALL Fatal( 'ElementInfo', 'Please use p-element basis instead.' ) 3431 3432 END SELECT 3433 END IF 3434 END IF 3435!------------------------------------------------------------------------------ 3436 END FUNCTION ElementInfo 3437!------------------------------------------------------------------------------ 3438 3439 ! SUBROUTINE ElementInfoVec_InitWork(m, n) 3440 ! IMPLICIT NONE 3441 3442 ! INTEGER, INTENT(IN) :: m, n 3443 ! INTEGER :: allocstat 3444 3445 ! allocstat = 0 3446 ! IF (.NOT. ALLOCATED(BasisWrk)) THEN 3447 ! ALLOCATE(BasisWrk(m,n), & 3448 ! dBasisdxWrk(m,n,3), & 3449 ! LtoGMapsWrk(m,3,3), & 3450 ! DetJWrk(m), & 3451 ! uWrk(m), vWrk(m), wWrk(m), STAT=allocstat) 3452 ! ELSE IF (SIZE(BasisWrk,1) /= m .OR. SIZE(BasisWrk,2) /= n) THEN 3453 ! DEALLOCATE(BasisWrk, dBasisdxWrk, LtoGMapsWrk, DetJWrk, uWrk, vWrk, wWrk) 3454 ! ALLOCATE(BasisWrk(m,n), & 3455 ! dBasisdxWrk(m,n,3), & 3456 ! LtoGMapsWrk(m,3,3), & 3457 ! DetJWrk(m), & 3458 ! uWrk(m), vWrk(m), wWrk(m), STAT=allocstat) 3459 ! END IF 3460 3461 ! ! Check memory allocation status 3462 ! IF (allocstat /= 0) THEN 3463 ! CALL Error('ElementInfo_InitWork','Storage allocation for local element basis failed') 3464 ! END IF 3465 ! END SUBROUTINE ElementInfoVec_InitWork 3466 3467 ! SUBROUTINE ElementInfoVec_FreeWork() 3468 ! IMPLICIT NONE 3469 3470 ! IF (ALLOCATED(BasisWrk)) THEN 3471 ! DEALLOCATE(BasisWrk, dBasisdxWrk, LtoGMapsWrk, DetJWrk, uWrk, vWrk, wWrk) 3472 ! END IF 3473 ! END SUBROUTINE ElementInfoVec_FreeWork 3474 3475! ElementInfoVec currently uses only P element definitions for basis 3476! functions, even for purely nodal elements. Support for standard nodal elements 3477! will be implemented in the future. 3478!------------------------------------------------------------------------------ 3479 FUNCTION ElementInfoVec( Element, Nodes, nc, u, v, w, detJ, nbmax, Basis, dBasisdx ) RESULT(retval) 3480!------------------------------------------------------------------------------ 3481 IMPLICIT NONE 3482 3483 TYPE(Element_t), TARGET :: Element !< Element structure 3484 TYPE(Nodes_t) :: Nodes !< Element nodal coordinates. 3485 INTEGER, INTENT(IN) :: nc !< Number of local coordinates to compute values of the basis function 3486 REAL(KIND=dp), POINTER CONTIG :: u(:) !< 1st local coordinates at which to calculate the basis function. 3487 REAL(KIND=dp), POINTER CONTIG :: v(:) !< 2nd local coordinates. 3488 REAL(KIND=dp), POINTER CONTIG :: w(:) !< 3rd local coordinates. 3489 REAL(KIND=dp) CONTIG, INTENT(OUT) :: detJ(:) !< Square roots of determinants of element coordinate system metric at coordinates 3490 INTEGER, INTENT(IN) :: nbmax !< Maximum number of basis functions to compute 3491 REAL(KIND=dp) CONTIG :: Basis(:,:) !< Basis function values at (u,v,w) 3492 REAL(KIND=dp) CONTIG, OPTIONAL :: dBasisdx(:,:,:) !< Global first derivatives of basis functions at (u,v,w) 3493 LOGICAL :: retval !< If .FALSE. element is degenerate. or if local storage allocation fails 3494 3495 ! Internal work arrays (always needed) 3496 REAL(KIND=dp) :: uWrk(VECTOR_BLOCK_LENGTH), vWrk(VECTOR_BLOCK_LENGTH), wWrk(VECTOR_BLOCK_LENGTH) 3497 REAL(KIND=dp) :: BasisWrk(VECTOR_BLOCK_LENGTH,nbmax) 3498 REAL(KIND=dp) :: dBasisdxWrk(VECTOR_BLOCK_LENGTH,nbmax,3) 3499 REAL(KIND=dp) :: DetJWrk(VECTOR_BLOCK_LENGTH) 3500 REAL(KIND=dp) :: LtoGMapsWrk(VECTOR_BLOCK_LENGTH,3,3) 3501 3502 INTEGER :: i, l, n, dim, cdim, ll, ncl, lln 3503 LOGICAL :: elem 3504!DIR$ ATTRIBUTES ALIGN:64::uWrk, vWrk, wWrk, BasisWrk, dBasisdxWrk, DetJWrk, LtoGMapsWrk 3505 3506 !------------------------------------------------------------------------------ 3507 ! Special case, Element: POINT 3508 IF (Element % TYPE % ElementCODE == 101) THEN 3509 DetJ(1:nc) = REAL(1, dp) 3510 Basis(1:nc,1) = REAL(1, dp) 3511 IF (PRESENT(dBasisdx)) THEN 3512 DO i=1,nc 3513 dBasisdx(i,1,1) = REAL(0, dp) 3514 END DO 3515 END IF 3516 retval = .TRUE. 3517 RETURN 3518 END IF 3519 3520 ! Set up workspace arrays 3521 ! CALL ElementInfoVec_InitWork(VECTOR_BLOCK_LENGTH, nbmax) 3522 IF ( nbmax < Element % TYPE % NumberOfNodes ) THEN 3523 CALL Fatal('ElementInfoVec','Not enough storage to compute local element basis') 3524 END IF 3525 3526 IF(PRESENT(dBasisdx)) & 3527 dBasisdx = 0._dp ! avoid uninitialized stuff depending on coordinate dimension... 3528 3529 IF(ASSOCIATED(Element % PDefs) .OR. Element % Type % BasisFunctionDegree<2) THEN 3530 retval = ElementInfoVec_ComputePElementBasis(Element,Nodes,nc,u,v,w,detJ,nbmax,Basis,& 3531 uWrk,vWrk,wWrk,BasisWrk,dBasisdxWrk,DetJWrk,LtoGmapsWrk,dBasisdx) 3532 ELSE 3533 retval = .TRUE. 3534 n = Element % TYPE % NumberOfNodes 3535 dim = Element % TYPE % DIMENSION 3536 cdim = CoordinateSystemDimension() 3537 3538 DO ll=1,nc,VECTOR_BLOCK_LENGTH 3539 lln = MIN(ll+VECTOR_BLOCK_LENGTH-1,nc) 3540 ncl = lln-ll+1 3541 3542 ! Block copy input 3543 uWrk(1:ncl) = u(ll:lln) 3544 IF (cdim > 1) THEN 3545 vWrk(1:ncl) = v(ll:lln) 3546 END IF 3547 IF (cdim > 2) THEN 3548 wWrk(1:ncl) = w(ll:lln) 3549 END IF 3550 3551 DO l=1,ncl 3552 CALL NodalBasisFunctions(n, Basis(l,:), element, uWrk(l), vWrk(l), wWrk(l)) 3553 CALL NodalFirstDerivatives(n, dBasisdxWrk(l,:,:), element, uWrk(l), vWrk(l), wWrk(l)) 3554 !-------------------------------------------------------------- 3555 END DO 3556 3557 ! Element (contravariant) metric and square root of determinant 3558 !-------------------------------------------------------------- 3559 elem = ElementMetricVec( Element, Nodes, ncl, n, DetJWrk, & 3560 nbmax, dBasisdxWrk, LtoGMapsWrk ) 3561 3562 IF (.NOT. elem) THEN 3563 retval = .FALSE. 3564 RETURN 3565 END IF 3566 3567 !_ELMER_OMP_SIMD 3568 DO i=1,ncl 3569 DetJ(i+ll-1)=DetJWrk(i) 3570 END DO 3571 3572 ! Get global basis functions 3573 !-------------------------------------------------------------- 3574 ! First derivatives 3575 IF (PRESENT(dBasisdx)) THEN 3576!DIR$ FORCEINLINE 3577 CALL ElementInfoVec_ElementBasisToGlobal(ncl, n, nbmax, dBasisdxWrk, dim, cdim, LtoGMapsWrk, ll, dBasisdx) 3578 END IF 3579 END DO 3580 END IF 3581 END FUNCTION ElementInfoVec 3582 3583 FUNCTION ElementInfoVec_ComputePElementBasis(Element, Nodes, nc, u, v, w, DetJ, nbmax, Basis, & 3584 uWrk, vWrk, wWrk, BasisWrk, dBasisdxWrk, DetJWrk, LtoGmapsWrk, dBasisdx) RESULT(retval) 3585 IMPLICIT NONE 3586 TYPE(Element_t), TARGET :: Element !< Element structure 3587 TYPE(Nodes_t) :: Nodes !< Element nodal coordinates. 3588 INTEGER, INTENT(IN) :: nc !< Number of local coordinates to compute values of the basis function 3589 REAL(KIND=dp), POINTER CONTIG :: u(:) !< 1st local coordinates at which to calculate the basis function. 3590 REAL(KIND=dp), POINTER CONTIG :: v(:) !< 2nd local coordinates. 3591 REAL(KIND=dp), POINTER CONTIG :: w(:) !< 3rd local coordinates. 3592 REAL(KIND=dp) CONTIG, INTENT(OUT) :: detJ(:) !< Square roots of determinants of element coordinate system metric at coordinates 3593 INTEGER, INTENT(IN) :: nbmax !< Maximum number of basis functions to compute 3594 REAL(KIND=dp) CONTIG :: Basis(:,:) !< Basis function values at (u,v,w) 3595 ! Internal work arrays 3596 REAL(KIND=dp) :: uWrk(VECTOR_BLOCK_LENGTH), vWrk(VECTOR_BLOCK_LENGTH), wWrk(VECTOR_BLOCK_LENGTH) 3597 REAL(KIND=dp) :: BasisWrk(VECTOR_BLOCK_LENGTH,nbmax) 3598 REAL(KIND=dp) :: dBasisdxWrk(VECTOR_BLOCK_LENGTH,nbmax,3) 3599 REAL(KIND=dp) :: DetJWrk(VECTOR_BLOCK_LENGTH) 3600 REAL(KIND=dp) :: LtoGMapsWrk(VECTOR_BLOCK_LENGTH,3,3) 3601 REAL(KIND=dp) CONTIG, OPTIONAL :: dBasisdx(:,:,:) !< Global first derivatives of basis functions at (u,v,w) 3602 LOGICAL :: retval !< If .FALSE. element is degenerate. or if local storage allocation fails 3603 3604 3605 !------------------------------------------------------------------------------ 3606 ! Local variables 3607 !------------------------------------------------------------------------------ 3608 INTEGER :: EdgeDegree(H1Basis_MaxPElementEdges), & 3609 FaceDegree(H1Basis_MaxPElementFaces), & 3610 EdgeDirection(H1Basis_MaxPElementEdgeNodes,H1Basis_MaxPElementEdges), & 3611 FaceDirection(H1Basis_MaxPElementFaceNodes,H1Basis_MaxPElementFaces) 3612 3613 INTEGER :: cdim, dim, i, j, k, l, ll, lln, ncl, ip, n, p, nb, & 3614 nbp, nbq, nbdxp, allocstat, ncpad, EdgeMaxDegree, FaceMaxDegree 3615 3616 3617 LOGICAL :: invertBubble, elem 3618 3619!DIR$ ATTRIBUTES ALIGN:64::EdgeDegree, FaceDegree 3620!DIR$ ATTRIBUTES ALIGN:64::EdgeDirection, FaceDirection 3621!DIR$ ASSUME_ALIGNED uWrk:64, vWrk:64, wWrk:64, BasisWrk:64, dBasisdxWrk:64, DetJWrk:64, LtoGMapsWrk:64 3622 3623 retval = .TRUE. 3624 n = Element % TYPE % NumberOfNodes 3625 dim = Element % TYPE % DIMENSION 3626 cdim = CoordinateSystemDimension() 3627 3628 dBasisdxWrk = 0._dp ! avoid uninitialized stuff depending on coordinate dimension... 3629 3630 ! Block the computation for large values of input points 3631 DO ll=1,nc,VECTOR_BLOCK_LENGTH 3632 lln = MIN(ll+VECTOR_BLOCK_LENGTH-1,nc) 3633 ncl = lln-ll+1 3634 3635 ! Set number of computed basis functions 3636 nbp = 0 3637 nbdxp = 0 3638 3639 ! Block copy input 3640 uWrk(1:ncl) = u(ll:lln) 3641 IF (cdim > 1) THEN 3642 vWrk(1:ncl) = v(ll:lln) 3643 END IF 3644 IF (cdim > 2) THEN 3645 wWrk(1:ncl) = w(ll:lln) 3646 END IF 3647 3648 ! Compute local p element basis 3649 SELECT CASE (Element % Type % ElementCode) 3650 ! Element: LINE 3651 CASE (202) 3652 ! Compute nodal basis 3653 CALL H1Basis_LineNodal(ncl, uWrk, nbmax, BasisWrk, nbp) 3654 ! Compute local first derivatives 3655 CALL H1Basis_dLineNodal(ncl, uWrk, nbmax, dBasisdxWrk, nbdxp) 3656 3657 ! Element bubble functions 3658 IF (Element % BDOFS > 0) THEN 3659 ! For first round of blocked loop, compute edge direction 3660 IF (ll==1) THEN 3661 ! Compute P from bubble dofs 3662 P = Element % BDOFS + 1 3663 3664 IF (Element % PDefs % isEdge .AND. & 3665 Element % NodeIndexes(1)> Element % NodeIndexes(2)) THEN 3666 invertBubble = .TRUE. 3667 ELSE 3668 invertBubble = .FALSE. 3669 END IF 3670 END IF 3671 3672 CALL H1Basis_LineBubbleP(ncl, uWrk, P, nbmax, BasisWrk, nbp, invertBubble) 3673 CALL H1Basis_dLineBubbleP(ncl, uWrk, P, nbmax, dBasisdxWrk, nbdxp, invertBubble) 3674 END IF 3675 3676 ! Element: TRIANGLE 3677 CASE (303) 3678 ! Compute nodal basis 3679 CALL H1Basis_TriangleNodalP(ncl, uWrk, vWrk, nbmax, BasisWrk, nbp) 3680 ! Compute local first derivatives 3681 CALL H1Basis_dTriangleNodalP(ncl, uWrk, vWrk, nbmax, dBasisdxWrk, nbdxp) 3682 3683 IF (ASSOCIATED( Element % EdgeIndexes)) THEN 3684 ! For first round of blocked loop, compute polynomial degrees and 3685 ! edge directions 3686 IF (ll==1) THEN 3687 CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, & 3688 Element, EdgeDegree, EdgeDirection, EdgeMaxDegree) 3689 END IF 3690 3691 ! Compute basis function values 3692 IF (EdgeMaxDegree>1 ) THEN 3693 nbq = nbp + SUM(EdgeDegree(1:3)-1) 3694 IF(nbmax >= nbq ) THEN 3695 CALL H1Basis_TriangleEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, BasisWrk, & 3696 nbp, EdgeDirection) 3697 CALL H1Basis_dTriangleEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, dBasisdxWrk, & 3698 nbdxp, EdgeDirection) 3699 END IF 3700 END IF 3701 END IF 3702 3703 ! Element bubble functions 3704 IF (Element % BDOFS > 0) THEN 3705 ! For first round of blocked loop, compute polynomial degrees and 3706 ! edge directions 3707 IF (ll==1) THEN 3708 ! Compute P from bubble dofs 3709 P = CEILING( ( 3.0d0+SQRT(1.0d0+8.0d0*(Element % BDOFS)) ) / 2.0d0 - AEPS) 3710 3711 IF (Element % PDefs % isEdge) THEN 3712 ! Get 2D face direction 3713 CALL H1Basis_GetFaceDirection(Element % Type % ElementCode, & 3714 1, & 3715 Element % NodeIndexes, & 3716 FaceDirection) 3717 END IF 3718 END IF 3719 IF (Element % PDefs % isEdge) THEN 3720 CALL H1Basis_TriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp, & 3721 FaceDirection(1:3,1)) 3722 CALL H1Basis_dTriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp, & 3723 FaceDirection(1:3,1)) 3724 ELSE 3725 CALL H1Basis_TriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp) 3726 CALL H1Basis_dTriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp) 3727 END IF 3728 END IF 3729 3730 ! QUADRILATERAL 3731 CASE (404) 3732 ! Compute nodal basis 3733 CALL H1Basis_QuadNodal(ncl, uWrk, vWrk, nbmax, BasisWrk, nbp) 3734 ! Compute local first derivatives 3735 CALL H1Basis_dQuadNodal(ncl, uWrk, vWrk, nbmax, dBasisdxWrk, nbdxp) 3736 3737 IF (ASSOCIATED( Element % EdgeIndexes )) THEN 3738 ! For first round of blocked loop, compute polynomial degrees and 3739 ! edge directions 3740 IF (ll==1) THEN 3741 CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, & 3742 Element, EdgeDegree, EdgeDirection, EdgeMaxDegree) 3743 END IF 3744 3745 ! Compute basis function values 3746 IF (EdgeMaxDegree > 1) THEN 3747 nbq = nbp + SUM(EdgeDegree(1:4)-1) 3748 IF(nbmax >= nbq) THEN 3749 CALL H1Basis_QuadEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, BasisWrk, nbp, & 3750 EdgeDirection) 3751 CALL H1Basis_dQuadEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, & 3752 EdgeDirection) 3753 END IF 3754 END IF 3755 END IF 3756 3757 ! Element bubble functions 3758 IF (Element % BDOFS > 0) THEN 3759 ! For first round of blocked loop, compute polynomial degrees and 3760 ! edge directions 3761 IF (ll==1) THEN 3762 ! Compute P from bubble dofs 3763 P = CEILING( ( 5.0d0+SQRT(1.0d0+8.0d0*(Element % BDOFS)) ) / 2.0d0 - AEPS ) 3764 3765 IF (Element % PDefs % isEdge) THEN 3766 ! Get 2D face direction 3767 CALL H1Basis_GetFaceDirection(Element % Type % ElementCode, & 3768 1, & 3769 Element % NodeIndexes, & 3770 FaceDirection) 3771 END IF 3772 END IF 3773 3774 IF (Element % PDefs % isEdge) THEN 3775 CALL H1Basis_QuadBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp, & 3776 FaceDirection(1:4,1)) 3777 CALL H1Basis_dQuadBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp, & 3778 FaceDirection(1:4,1)) 3779 ELSE 3780 CALL H1Basis_QuadBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp) 3781 CALL H1Basis_dQuadBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp) 3782 END IF 3783 END IF 3784 3785 ! TETRAHEDRON 3786 CASE (504) 3787 ! Compute nodal basis 3788 CALL H1Basis_TetraNodalP(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp) 3789 ! Compute local first derivatives 3790 CALL H1Basis_dTetraNodalP(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp) 3791 3792 IF (ASSOCIATED( Element % EdgeIndexes )) THEN 3793 ! For first round of blocked loop, compute polynomial degrees and 3794 ! edge directions 3795 IF (ll==1) THEN 3796 ! Get polynomial degree of each edge 3797 EdgeMaxDegree = 0 3798 IF( CurrentModel % Solver % Mesh % MaxEdgeDofs == 0 ) THEN 3799 CONTINUE 3800 ELSE IF (CurrentModel % Solver % Mesh % MinEdgeDOFs == & 3801 CurrentModel % Solver % Mesh % MaxEdgeDOFs) THEN 3802 EdgeMaxDegree = Element % BDOFs+1 3803 EdgeDegree(1:Element % Type % NumberOfFaces) = EdgeMaxDegree 3804 ELSE 3805 DO i=1,6 3806 EdgeDegree(i) = CurrentModel % Solver % & 3807 Mesh % Edges( Element % EdgeIndexes(i) ) % BDOFs + 1 3808 EdgeMaxDegree = MAX(EdgeDegree(i),EdgeMaxDegree) 3809 END DO 3810 END IF 3811 3812 ! Tetrahedral directions are enforced by tetra element types 3813 IF (EdgeMaxDegree > 1) THEN 3814 CALL H1Basis_GetTetraEdgeDirection(Element % PDefs % TetraType, EdgeDirection) 3815 END IF 3816 END IF 3817 3818 ! Compute basis function values 3819 IF (EdgeMaxDegree > 1) THEN 3820 nbq = nbp + SUM(EdgeDegree(1:6)-1) 3821 IF(nbmax >= nbq) THEN 3822 CALL H1Basis_TetraEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, & 3823 EdgeDirection) 3824 CALL H1Basis_dTetraEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, & 3825 EdgeDirection) 3826 END IF 3827 END IF 3828 END IF 3829 3830 IF (ASSOCIATED( Element % FaceIndexes )) THEN 3831 ! For first round of blocked loop, compute polynomial degrees and 3832 ! face directions 3833 IF (ll==1) THEN 3834 ! Get polynomial degree of each face 3835 FaceMaxDegree = 0 3836 3837 IF( CurrentModel % Solver % Mesh % MaxFaceDofs == 0 ) THEN 3838 CONTINUE 3839 ELSE IF (CurrentModel % Solver % Mesh % MinFaceDOFs == & 3840 CurrentModel % Solver % Mesh % MaxFaceDOFs) THEN 3841 FaceMaxDegree = CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(1) ) % PDefs % P 3842 FaceDegree(1:Element % Type % NumberOfFaces) = FaceMaxDegree 3843 ELSE 3844 DO i=1,4 3845 IF (CurrentModel % Solver % Mesh % & 3846 Faces( Element % FaceIndexes(i) ) % BDOFs /= 0) THEN 3847 FaceDegree(i) = CurrentModel % Solver % Mesh % & 3848 Faces( Element % FaceIndexes(i) ) % PDefs % P 3849 FaceMaxDegree = MAX(FaceDegree(i), FaceMaxDegree) 3850 ELSE 3851 FaceDegree(i) = 0 3852 END IF 3853 END DO 3854 END IF 3855 3856 IF (FaceMaxDegree > 1) THEN 3857 CALL H1Basis_GetTetraFaceDirection(Element % PDefs % TetraType, FaceDirection) 3858 END IF 3859 END IF 3860 3861 ! Compute basis function values 3862 IF (FaceMaxDegree>1 ) THEN 3863 nbq = nbp 3864 DO i=1,4 3865 DO j=0,FaceDegree(i) 3866 nbq = nbq + MAX(FaceDegree(i)-j-2,0) 3867 END DO 3868 END DO 3869 3870 IF (nbmax >= nbq ) THEN 3871 CALL H1Basis_TetraFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, & 3872 FaceDirection) 3873 CALL H1Basis_dTetraFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, & 3874 FaceDirection) 3875 END IF 3876 END IF 3877 END IF 3878 3879 ! Element bubble functions 3880 IF (Element % BDOFS > 0) THEN 3881 ! Compute P based on bubble dofs 3882 nb = Element % BDOFs 3883 p = CEILING( 1/3._dp*(81*nb+3*SQRT(-3._dp+729*nb**2))**(1/3._dp) + & 3884 1d0/(81*nb+3*SQRT(-3._dp+729*nb**2))**(1/3._dp)+2 - AEPS ) 3885 3886 CALL H1Basis_TetraBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp) 3887 CALL H1Basis_dTetraBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp) 3888 END IF 3889 3890 ! TEMPORARY NONVECTORIZED PYRAMID 3891 CASE (605) 3892BLOCK 3893 INTEGER :: F, locali, localj, nb, q, tmp(4), direction(4) 3894 LOGICAL :: invert 3895 TYPE(Element_t), POINTER :: Face, Edge 3896 3897 dBasisdxWrk(1:ncl,:,:) = 0.0d0 3898 BasisWrk(1:ncl,:) = 0.0d0 3899 DO l=1,ncl 3900 CALL NodalBasisFunctions(5, BasisWrk(l,:), element, uWrk(l), vWrk(l), wWrk(l)) 3901 CALL NodalFirstDerivatives(5, dBasisdxWrk(l,:,:), element, uWrk(l), vWrk(l), wWrk(l) ) 3902 3903 q = 5 3904 3905 ! Edges of P Pyramid 3906 IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN 3907 ! For each edge in wedge, calculate values of edge functions 3908 DO i=1,8 3909 Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) ) 3910 3911 ! Do not solve edge dofs, if there is not any 3912 IF (Edge % BDOFs <= 0) CYCLE 3913 3914 ! Get local indexes of current edge 3915 tmp(1:2) = getPyramidEdgeMap(i) 3916 locali = tmp(1) 3917 localj = tmp(2) 3918 3919 ! Determine edge direction 3920 invert = .FALSE. 3921 3922 ! Invert edge if local first node has greater global index than second one 3923 IF ( Element % NodeIndexes(locali) > Element % NodeIndexes(localj) ) invert = .TRUE. 3924 3925 ! For each DOF in edge calculate values of edge functions 3926 ! and their derivatives for edge=i and i=k+1 3927 DO k=1,Edge % BDOFs 3928 IF ( q >= SIZE(BasisWrk,2) ) CYCLE 3929 q = q + 1 3930 3931 ! Get values of edge basis functions and their derivatives 3932 BasisWrk(l,q) = PyramidEdgePBasis(i,k+1,uwrk(l),vwrk(l),wwrk(l),invert) 3933 dBasisdxWrk(l,q,1:3) = dPyramidEdgePBasis(i,k+1,uwrk(l),vwrk(l),wwrk(l),invert) 3934 END DO 3935 END DO 3936 END IF 3937 3938 ! Faces of P Pyramid 3939 IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN 3940 ! For each face in pyramid, calculate values of face functions 3941 DO F=1,5 3942 Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) ) 3943 3944 ! Do not solve face dofs, if there is not any 3945 IF ( Face % BDOFs <= 0) CYCLE 3946 3947 ! Get face p 3948 p = Face % PDefs % P 3949 3950 ! Handle triangle and square faces separately 3951 SELECT CASE(F) 3952 CASE (1) 3953 direction = 0 3954 ! Get global direction vector for enforcing parity 3955 tmp(1:4) = getPyramidFaceMap(F) 3956 direction(1:4) = getSquareFaceDirection( Element, tmp(1:4) ) 3957 3958 ! For each face calculate values of functions from index 3959 ! pairs i,j=2,..,p-2 i+j=4,..,p 3960 DO i=2,p-2 3961 DO j=2,p-i 3962 IF ( q >= SIZE(BasisWrk,2) ) CYCLE 3963 q = q + 1 3964 3965 BasisWrk(l,q) = PyramidFacePBasis(F,i,j,uwrk(l),vwrk(l),wwrk(l),direction) 3966 dBasisdxWrk(l,q,:) = dPyramidFacePBasis(F,i,j,uwrk(l),vwrk(l),wwrk(l),direction) 3967 END DO 3968 END DO 3969 3970 CASE (2,3,4,5) 3971 direction = 0 3972 ! Get global direction vector for enforcing parity 3973 tmp(1:4) = getPyramidFaceMap(F) 3974 direction(1:3) = getTriangleFaceDirection( Element, tmp(1:3) ) 3975 3976 ! For each face calculate values of functions from index 3977 ! pairs i,j=0,..,p-3 i+j=0,..,p-3 3978 DO i=0,p-3 3979 DO j=0,p-i-3 3980 IF ( q >= SIZE(BasisWrk,2) ) CYCLE 3981 q = q + 1 3982 3983 BasisWrk(l,q) = PyramidFacePBasis(F,i,j,uwrk(l),vwrk(l),wwrk(l),direction) 3984 dBasisdxWrk(l,q,:) = dPyramidFacePBasis(F,i,j,uwrk(l),vwrk(l),wwrk(l),direction) 3985 END DO 3986 END DO 3987 END SELECT 3988 END DO 3989 END IF 3990 3991 ! Bubbles of P Pyramid 3992 IF (Element % BDOFs > 0) THEN 3993 ! Get element p 3994 p = Element % PDefs % p 3995 nb = MAX( GetBubbleDOFs(Element, p), Element % BDOFs ) 3996 p=CEILING(1/3d0*(81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+1d0/ & 3997 (81*nb+3*SQRT(-3d0+729*nb**2))**(1/3d0)+2 - AEPS) 3998 3999 ! Calculate value of bubble functions from indexes 4000 ! i,j,k=0,..,p-4 i+j+k=0,..,p-4 4001 DO i=0,p-4 4002 DO j=0,p-i-4 4003 DO k=0,p-i-j-4 4004 IF ( q >= SIZE(BasisWrk,2)) CYCLE 4005 q = q + 1 4006 4007 BasisWrk(l,q) = PyramidBubblePBasis(i,j,k,uwrk(l),vwrk(l),wwrk(l)) 4008 dBasisdxWrk(l,q,:) = dPyramidBubblePBasis(i,j,k,uwrk(l),vwrk(l),wwrk(l)) 4009 END DO 4010 END DO 4011 END DO 4012 END IF 4013 END DO 4014 4015 nbp = q 4016!------------------------------------------------------------------------------ 4017END BLOCK 4018 4019 4020 ! WEDGE 4021 CASE (706) 4022 ! Compute nodal basis 4023 CALL H1Basis_WedgeNodalP(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp) 4024 ! Compute local first derivatives 4025 CALL H1Basis_dWedgeNodalP(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp) 4026 4027 IF (ASSOCIATED( Element % EdgeIndexes )) THEN 4028 ! For first round of blocked loop, compute polynomial degrees and 4029 ! edge directions 4030 IF (ll==1) THEN 4031 CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, & 4032 Element, EdgeDegree, EdgeDirection, EdgeMaxDegree) 4033 END IF 4034 4035 ! Compute basis function values 4036 IF (EdgeMaxDegree > 1)THEN 4037 nbq = nbp+SUM(EdgeDegree(1:9)-1) 4038 IF(nbmax >= nbq) THEN 4039 CALL H1Basis_WedgeEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, & 4040 EdgeDirection) 4041 CALL H1Basis_dWedgeEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, & 4042 EdgeDirection) 4043 END IF 4044 END IF 4045 END IF 4046 4047 IF (ASSOCIATED( Element % FaceIndexes )) THEN 4048 ! For first round of blocked loop, compute polynomial degrees and 4049 ! face directions 4050 IF (ll==1) THEN 4051 CALL GetElementMeshFaceInfo(CurrentModel % Solver % Mesh, & 4052 Element, FaceDegree, FaceDirection, FaceMaxDegree) 4053 END IF 4054 4055 ! Compute basis function values 4056 IF (FaceMaxDegree > 1 ) THEN 4057 nbq = nbp 4058 ! Triangle faces 4059 DO i=1,2 4060 DO j=0,FaceDegree(i)-3 4061 nbq = nbq + MAX(FaceDegree(i)-j-2,0) 4062 END DO 4063 END DO 4064 ! Square faces 4065 DO i=3,5 4066 DO j=2,FaceDegree(i)-2 4067 nbq = nbq + MAX(FaceDegree(i)-j-1,0) 4068 END DO 4069 END DO 4070 4071 IF(nbmax >= nbq) THEN 4072 CALL H1Basis_WedgeFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, & 4073 FaceDirection) 4074 CALL H1Basis_dWedgeFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, & 4075 FaceDirection) 4076 END IF 4077 END IF 4078 END IF 4079 4080 ! Element bubble functions 4081 IF (Element % BDOFS > 0) THEN 4082 ! Compute P from bubble dofs 4083 P=CEILING(1/3d0*(81*(Element % BDOFS) + & 4084 3*SQRT(-3d0+729*(Element % BDOFS)**2))**(1/3d0) + & 4085 1d0/(81*(Element % BDOFS)+ & 4086 3*SQRT(-3d0+729*(Element % BDOFS)**2))**(1/3d0)+3 - AEPS) 4087 4088 CALL H1Basis_WedgeBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp) 4089 CALL H1Basis_dWedgeBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp) 4090 END IF 4091 4092 ! HEXAHEDRON 4093 CASE (808) 4094 ! Compute local basis 4095 CALL H1Basis_BrickNodal(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp) 4096 ! Compute local first derivatives 4097 CALL H1Basis_dBrickNodal(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp) 4098 4099 IF (ASSOCIATED( Element % EdgeIndexes )) THEN 4100 ! For first round of blocked loop, compute polynomial degrees and 4101 ! edge directions 4102 IF (ll==1) THEN 4103 CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, & 4104 Element, EdgeDegree, EdgeDirection, EdgeMaxDegree) 4105 END IF 4106 4107 ! Compute basis function values 4108 IF (EdgeMaxDegree > 1) THEN 4109 nbq = nbp + SUM(EdgeDegree(1:12)-1) 4110 IF(nbmax >= nbq) THEN 4111 CALL H1Basis_BrickEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, & 4112 EdgeDirection) 4113 CALL H1Basis_dBrickEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, & 4114 EdgeDirection) 4115 END IF 4116 END IF 4117 END IF 4118 4119 4120 IF (ASSOCIATED( Element % FaceIndexes )) THEN 4121 ! For first round of blocked loop, compute polynomial degrees and 4122 ! face directions 4123 IF (ll==1) THEN 4124 CALL GetElementMeshFaceInfo(CurrentModel % Solver % Mesh, & 4125 Element, FaceDegree, FaceDirection, FaceMaxDegree) 4126 END IF 4127 4128 ! Compute basis function values 4129 IF (FaceMaxDegree > 1) THEN 4130 nbq = nbp 4131 DO i=1,6 4132 DO j=2,FaceDegree(i) 4133 nbq = nbq + MAX(FaceDegree(i)-j-1,0) 4134 END DO 4135 END DO 4136 4137 IF(nbmax >= nbq) THEN 4138 CALL H1Basis_BrickFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, & 4139 FaceDirection) 4140 CALL H1Basis_dBrickFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, & 4141 FaceDirection) 4142 END IF 4143 END IF 4144 END IF 4145 4146 4147 ! Element bubble functions 4148 IF (Element % BDOFS > 0) THEN 4149 ! Compute P from bubble dofs 4150 P=CEILING(1/3d0*(81*Element % BDOFS + & 4151 3*SQRT(-3d0+729*Element % BDOFS**2))**(1/3d0) + & 4152 1d0/(81*Element % BDOFS+3*SQRT(-3d0+729*Element % BDOFS**2))**(1/3d0)+4 - AEPS) 4153 CALL H1Basis_BrickBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp) 4154 CALL H1Basis_dBrickBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp) 4155 END IF 4156 4157 4158 CASE DEFAULT 4159 WRITE( Message, '(a,i4,a)' ) 'Vectorized basis for element: ', & 4160 Element % TYPE % ElementCode, ' not implemented.' 4161 CALL Error( 'ElementInfoVec', Message ) 4162 CALL Fatal( 'ElementInfoVec', 'ElementInfoVec is still does not include pyramids.' ) 4163 END SELECT 4164 4165 ! Copy basis function values to global array 4166 DO j=1,nbp 4167 DO i=1,ncl 4168 Basis(i+ll-1,j)=BasisWrk(i,j) 4169 END DO 4170 END DO 4171 4172 !-------------------------------------------------------------- 4173 ! Element (contravariant) metric and square root of determinant 4174 !-------------------------------------------------------------- 4175 elem = ElementMetricVec( Element, Nodes, ncl, nbp, DetJWrk, & 4176 nbmax, dBasisdxWrk, LtoGMapsWrk ) 4177 IF (.NOT. elem) THEN 4178 retval = .FALSE. 4179 RETURN 4180 END IF 4181 4182 !_ELMER_OMP_SIMD 4183 DO i=1,ncl 4184 DetJ(i+ll-1)=DetJWrk(i) 4185 END DO 4186 4187 ! Get global basis functions 4188 !-------------------------------------------------------------- 4189 ! First derivatives 4190 IF (PRESENT(dBasisdx)) THEN 4191!DIR$ FORCEINLINE 4192 CALL ElementInfoVec_ElementBasisToGlobal(ncl, nbp, nbmax, dBasisdxWrk, dim, cdim, LtoGMapsWrk, ll, dBasisdx) 4193 END IF 4194 END DO ! Block over Gauss points 4195 4196 CONTAINS 4197 4198 SUBROUTINE GetElementMeshEdgeInfo(Mesh, Element, EdgeDegree, EdgeDirection, EdgeMaxDegree) 4199 IMPLICIT NONE 4200 4201 TYPE(Mesh_t), INTENT(IN) :: Mesh 4202 TYPE(Element_t), INTENT(IN) :: Element 4203 INTEGER, INTENT(OUT) :: EdgeDegree(H1Basis_MaxPElementEdges), & 4204 EdgeDirection(H1Basis_MaxPElementEdgeNodes,H1Basis_MaxPElementEdges) 4205 INTEGER, INTENT(OUT) :: EdgeMaxDegree 4206 INTEGER :: i 4207 4208 EdgeMaxDegree = 0 4209 4210 IF( Mesh % MaxEdgeDofs == 0 ) THEN 4211 CONTINUE 4212 4213 ELSE IF (Mesh % MinEdgeDOFs == Mesh % MaxEdgeDOFs) THEN 4214 EdgeDegree(1:Element % Type % NumberOfEdges) = Mesh % MaxEdgeDOFs + 1 4215 EdgeMaxDegree = Mesh % MaxEdgeDOFs + 1 4216 ELSE 4217 ! Get polynomial degree of each edge separately 4218!DIR$ LOOP COUNT MAX=12 4219 DO i=1,Element % Type % NumberOfEdges 4220 EdgeDegree(i) = Mesh % Edges( Element % EdgeIndexes(i) ) % BDOFs + 1 4221 EdgeMaxDegree = MAX(EdgeDegree(i), EdgeMaxDegree) 4222 END DO 4223 END IF 4224 4225 ! Get edge directions if needed 4226 IF (EdgeMaxDegree > 1) THEN 4227 CALL H1Basis_GetEdgeDirection(Element % Type % ElementCode, & 4228 Element % Type % NumberOfEdges, & 4229 Element % NodeIndexes, & 4230 EdgeDirection) 4231 END IF 4232 END SUBROUTINE GetElementMeshEdgeInfo 4233 4234 SUBROUTINE GetElementMeshFaceInfo(Mesh, Element, FaceDegree, FaceDirection, FaceMaxDegree) 4235 IMPLICIT NONE 4236 4237 TYPE(Mesh_t), INTENT(IN) :: Mesh 4238 TYPE(Element_t), INTENT(IN) :: Element 4239 INTEGER, INTENT(OUT) :: FaceDegree(H1Basis_MaxPElementFaces), & 4240 FaceDirection(H1Basis_MaxPElementFaceNodes,H1Basis_MaxPElementFaces) 4241 INTEGER, INTENT(OUT) :: FaceMaxDegree 4242 INTEGER :: i 4243 4244 ! Get polynomial degree of each face 4245 FaceMaxDegree = 0 4246 4247 IF( Mesh % MaxFaceDofs == 0 ) THEN 4248 CONTINUE 4249 4250 ELSE IF (Mesh % MinFaceDOFs == Mesh % MaxFaceDOFs) THEN 4251 FaceMaxDegree = Mesh % Faces( Element % FaceIndexes(1) ) % PDefs % P 4252 FaceDegree(1:Element % Type % NumberOfFaces) = FaceMaxDegree 4253 ELSE 4254!DIR$ LOOP COUNT MAX=6 4255 DO i=1,Element % Type % NumberOfFaces 4256 IF (Mesh % Faces( Element % FaceIndexes(i) ) % BDOFs /= 0) THEN 4257 FaceDegree(i) = Mesh % Faces( Element % FaceIndexes(i) ) % PDefs % P 4258 FaceMaxDegree = MAX(FaceDegree(i), FaceMaxDegree) 4259 ELSE 4260 FaceDegree(i) = 0 4261 END IF 4262 END DO 4263 END IF 4264 4265 ! Get face directions 4266 IF (FaceMaxDegree > 1) THEN 4267 CALL H1Basis_GetFaceDirection(Element % Type % ElementCode, & 4268 Element % Type % NumberOfFaces, & 4269 Element % NodeIndexes, & 4270 FaceDirection) 4271 END IF 4272 END SUBROUTINE GetElementMeshFaceInfo 4273!------------------------------------------------------------------------------ 4274 END FUNCTION ElementInfoVec_ComputePElementBasis 4275!------------------------------------------------------------------------------ 4276 4277 SUBROUTINE ElementInfoVec_ElementBasisToGlobal(npts, nbasis, nbmax, dLBasisdx, dim, cdim, LtoGMap, offset, dBasisdx) 4278 IMPLICIT NONE 4279 4280 INTEGER, INTENT(IN) :: npts 4281 INTEGER, INTENT(IN) :: nbasis 4282 INTEGER, INTENT(IN) :: nbmax 4283 REAL(KIND=dp), INTENT(IN) :: dLBasisdx(VECTOR_BLOCK_LENGTH,nbmax,3) 4284 INTEGER, INTENT(IN) :: dim 4285 INTEGER, INTENT(IN) :: cdim 4286 REAL(KIND=dp), INTENT(IN) :: LtoGMap(VECTOR_BLOCK_LENGTH,3,3) 4287 INTEGER, INTENT(IN) :: offset 4288 REAL(KIND=dp) CONTIG :: dBasisdx(:,:,:) 4289 4290 INTEGER :: i, j, l 4291!DIR$ ASSUME_ALIGNED dLBasisdx:64, LtoGMap:64 4292 4293 ! Map local basis function to global 4294 SELECT CASE (dim) 4295 CASE(1) 4296 !DIR$ LOOP COUNT MAX=3 4297 DO j=1,cdim 4298 DO i=1,nbasis 4299 !_ELMER_OMP_SIMD 4300 DO l=1,npts 4301 dBasisdx(l+offset-1,i,j) = dLBasisdx(l,i,1)*LtoGMap(l,j,1) 4302 END DO 4303 END DO 4304 END DO 4305 CASE(2) 4306 !DIR$ LOOP COUNT MAX=3 4307 DO j=1,cdim 4308 DO i=1,nbasis 4309 !_ELMER_OMP_SIMD 4310 DO l=1,npts 4311 ! Map local basis function to global 4312 dBasisdx(l+offset-1,i,j) = dLBasisdx(l,i,1)*LtoGMap(l,j,1)+ & 4313 dLBasisdx(l,i,2)*LtoGMap(l,j,2) 4314 END DO 4315 END DO 4316 END DO 4317 CASE(3) 4318 !DIR$ LOOP COUNT MAX=3 4319 DO j=1,cdim 4320 DO i=1,nbasis 4321 !_ELMER_OMP_SIMD 4322 DO l=1,npts 4323 ! Map local basis function to global 4324 dBasisdx(l+offset-1,i,j) = dLBasisdx(l,i,1)*LtoGMap(l,j,1)+ & 4325 dLBasisdx(l,i,2)*LtoGMap(l,j,2)+ & 4326 dLBasisdx(l,i,3)*LtoGMap(l,j,3) 4327 END DO 4328 END DO 4329 END DO 4330 END SELECT 4331 4332 END SUBROUTINE ElementInfoVec_ElementBasisToGlobal 4333 4334 4335!------------------------------------------------------------------------------ 4336!> Returns just the size of the element at its center. 4337!> providing a more economical way than calling ElementInfo. 4338!------------------------------------------------------------------------------ 4339 FUNCTION ElementSize( Element, Nodes ) RESULT ( detJ ) 4340 4341 TYPE(Element_t) :: Element 4342 TYPE(Nodes_t) :: Nodes 4343 REAL(KIND=dp) :: detJ 4344 4345 REAL(KIND=dp) :: u,v,w 4346 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 4347 INTEGER :: n,family 4348 LOGICAL :: Stat 4349 4350 4351 family = Element % TYPE % ElementCode / 100 4352 n = Element % TYPE % NumberOfNodes 4353 ALLOCATE( Basis(n) ) 4354 4355 SELECT CASE ( family ) 4356 4357 CASE ( 1 ) 4358 DetJ = 1.0_dp 4359 RETURN 4360 4361 CASE ( 2 ) 4362 u = 0.0_dp 4363 v = 0.0_dp 4364 4365 CASE ( 3 ) 4366 u = 0.5_dp 4367 v = 0.5_dp 4368 4369 CASE ( 4 ) 4370 u = 0.0_dp 4371 v = 0.0_dp 4372 4373 CASE ( 5 ) 4374 u = 0.5_dp 4375 v = 0.5_dp 4376 w = 0.5_dp 4377 4378 CASE ( 8 ) 4379 u = 0.0_dp 4380 v = 0.0_dp 4381 w = 0.0_dp 4382 4383 CASE DEFAULT 4384 CALL Fatal('ElementSize','Not implemented for elementtype') 4385 4386 END SELECT 4387 4388 Stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 4389 4390 END FUNCTION ElementSize 4391!------------------------------------------------------------------------------ 4392 4393 4394!---------------------------------------------------------------------------------- 4395!> Return H(div)-conforming face element basis function values and their divergence 4396!> with respect to the reference element coordinates at a given point on the 4397!> reference element. Here the basis for a real element K is constructed by 4398!> transforming the basis functions defined on the reference element k via the 4399!> Piola transformation. The data for performing the Piola transformation is also returned. 4400!> Note that the reference element is chosen as in the p-approximation so that 4401!> the reference element edges/faces have the same length/area. This choice simplifies 4402!> the associated assembly procedure. 4403!> With giving the optional argument ApplyPiolaTransform = .TRUE., this function 4404!> also performs the Piola transform, so that the basis functions and their spatial 4405!> div as defined on the physical element are returned. 4406!> The implementation is not yet complete as all element shapes are not supported. 4407!--------------------------------------------------------------------------------- 4408 RECURSIVE FUNCTION FaceElementInfo( Element, Nodes, u, v, w, F, detF, & 4409 Basis, FBasis, DivFBasis, BDM, Dual, BasisDegree, ApplyPiolaTransform) RESULT(stat) 4410!------------------------------------------------------------------------------ 4411 IMPLICIT NONE 4412 4413 TYPE(Element_t), TARGET :: Element !< Element structure 4414 TYPE(Nodes_t) :: Nodes !< Data corresponding to the classic element nodes 4415 REAL(KIND=dp) :: u !< 1st reference element coordinate at which the basis functions are evaluated 4416 REAL(KIND=dp) :: v !< 2nd reference element coordinate 4417 REAL(KIND=dp) :: w !< 3rd reference element coordinate 4418 REAL(KIND=dp), OPTIONAL :: F(3,3) !< The gradient F=Grad f, with f the element map f:k->K 4419 REAL(KIND=dp) :: detF !< The determinant of the gradient matrix F 4420 REAL(KIND=dp) :: Basis(:) !< Standard nodal basis functions evaluated at (u,v,w) 4421 REAL(KIND=dp) :: FBasis(:,:) !< Face element basis functions b spanning the reference element space 4422 REAL(KIND=dp), OPTIONAL :: DivFBasis(:) !< The divergence of basis functions with respect to the local coordinates 4423 LOGICAL, OPTIONAL :: BDM !< If .TRUE., a basis for BDM space is constructed 4424 LOGICAL, OPTIONAL :: Dual !< If .TRUE., create an alternate dual basis 4425 INTEGER, OPTIONAL :: BasisDegree(:) !< This a dummy parameter at the moment 4426 LOGICAL, OPTIONAL :: ApplyPiolaTransform !< If .TRUE., perform the Piola transform so that, instead of b 4427 !< and Div b, return B(f(p)) and (div B)(f(p)) with B(x) the basis 4428 !< functions on the physical element and div the spatial divergence operator. 4429 LOGICAL :: Stat !< Should be .FALSE. for a degenerate element but this is not yet checked 4430!----------------------------------------------------------------------------------------------------------------- 4431! Local variables 4432!------------------------------------------------------------------------------------------------------------ 4433 TYPE(Mesh_t), POINTER :: Mesh 4434 INTEGER, POINTER :: EdgeMap(:,:), FaceMap(:,:), Ind(:) 4435 INTEGER :: SquareFaceMap(4) 4436 INTEGER :: DOFs 4437 INTEGER :: n, dim, q, i, j, k, ni, nj, nk, I1, I2 4438 INTEGER :: FDofMap(4,3), DofsPerFace, FaceIndices(4) 4439 REAL(KIND=dp) :: LF(3,3) 4440 REAL(KIND=dp) :: DivBasis(12) ! Note the hard-coded size, alter if new elements are added 4441 REAL(KIND=dp) :: dLbasisdx(MAX(SIZE(Nodes % x),SIZE(Basis)),3), S, D1, D2 4442 REAL(KIND=dp) :: BDMBasis(12,3), BDMDivBasis(12), WorkBasis(2,3), WorkDivBasis(2) 4443 4444 LOGICAL :: RevertSign(4), CreateBDMBasis, Parallel 4445 LOGICAL :: CreateDualBasis 4446 LOGICAL :: PerformPiolaTransform 4447!----------------------------------------------------------------------------------------------------- 4448 Mesh => CurrentModel % Solver % Mesh 4449 Parallel = ASSOCIATED(Mesh % ParallelInfo % Interface) 4450 4451 !-------------------------------------------------------------------- 4452 ! Check whether BDM or dual basis functions should be created and 4453 ! whether the Piola transform is already applied within this function. 4454 !--------------------------------------------------------------------- 4455 CreateBDMBasis = .FALSE. 4456 IF ( PRESENT(BDM) ) CreateBDMBasis = BDM 4457 CreateDualBasis = .FALSE. 4458 IF ( PRESENT(Dual) ) CreateDualBasis = Dual 4459 PerformPiolaTransform = .FALSE. 4460 IF ( PRESENT(ApplyPiolaTransform) ) PerformPiolaTransform = ApplyPiolaTransform 4461 !----------------------------------------------------------------------------------------------------- 4462 stat = .TRUE. 4463 Basis = 0.0d0 4464 FBasis = 0.0d0 4465 DivFBasis = 0.0d0 4466 DivBasis = 0.0d0 4467 LF = 0.0d0 4468 4469 dLbasisdx = 0.0d0 4470 n = Element % TYPE % NumberOfNodes 4471 dim = Element % TYPE % DIMENSION 4472 4473 IF ( Element % TYPE % ElementCode == 101 ) THEN 4474 detF = 1.0d0 4475 Basis(1) = 1.0d0 4476 RETURN 4477 END IF 4478 4479 !----------------------------------------------------------------------- 4480 ! The standard nodal basis functions on the reference element and 4481 ! their derivatives with respect to the local coordinates. These define 4482 ! the mapping of the reference element to an actual element on the 4483 ! background mesh but are not the basis functions for face element approximation. 4484 ! Remark: Using reference elements having the faces of the same area 4485 ! simplifies the implementation of element assembly procedures. 4486 !----------------------------------------------------------------------- 4487 SELECT CASE(Element % TYPE % ElementCode / 100) 4488 CASE(3) 4489 DO q=1,n 4490 Basis(q) = TriangleNodalPBasis(q, u, v) 4491 dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 4492 END DO 4493 CASE(4) 4494 DO q=1,n 4495 Basis(q) = QuadNodalPBasis(q, u, v) 4496 dLBasisdx(q,1:2) = dQuadNodalPBasis(q, u, v) 4497 END DO 4498 CASE(5) 4499 DO q=1,n 4500 Basis(q) = TetraNodalPBasis(q, u, v, w) 4501 dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w) 4502 END DO 4503 CASE DEFAULT 4504 CALL Fatal('ElementDescription::FaceElementInfo','Unsupported element type') 4505 END SELECT 4506 4507 !----------------------------------------------------------------------- 4508 ! Get data for performing the Piola transformation... 4509 !----------------------------------------------------------------------- 4510 stat = PiolaTransformationData(n, Element, Nodes, LF, detF, dLBasisdx) 4511 !------------------------------------------------------------------------ 4512 ! ... in order to define the basis for the element space X(K) via 4513 ! applying the Piola transformation as 4514 ! X(K) = { B | B = 1/(det F) F b(f^{-1}(x)) } 4515 ! with b giving the face element basis function on the reference element k, 4516 ! f mapping k to the actual element K, i.e. K = f(k) and F = Grad f. This 4517 ! function returns the local basis functions b and their divergence (with respect 4518 ! to local coordinates) evaluated at the integration point. The effect of 4519 ! the Piola transformation need to be considered when integrating, so we 4520 ! shall return also the values of F and det F. 4521 ! 4522 ! The construction of face element bases could be done in an alternate way for 4523 ! triangles and tetrahedra, while the chosen approach has the benefit that 4524 ! it generalizes to other cases. For example general quadrilaterals may now 4525 ! be handled in the same way. 4526 !--------------------------------------------------------------------------- 4527 4528 SELECT CASE(Element % TYPE % ElementCode / 100) 4529 CASE(3) 4530 !---------------------------------------------------------------- 4531 ! Note that the global orientation of face normal is taken to be 4532 ! n = t x e_z where the tangent vector t is aligned with 4533 ! the element edge and points towards the node that has 4534 ! a larger global index. 4535 !--------------------------------------------------------------- 4536 EdgeMap => GetEdgeMap(3) 4537 !EdgeMap => GetEdgeMap(GetElementFamily(Element)) 4538 4539 !----------------------------------------------------------------------------------- 4540 ! Check first whether a sign reversion will be needed as face dofs have orientation. 4541 !----------------------------------------------------------------------------------- 4542 CALL FaceElementOrientation(Element, RevertSign) 4543 4544 IF (CreateBDMBasis) THEN 4545 !---------------------------------------------------------------------------- 4546 ! This is for the BDM space of degree k=1. 4547 !---------------------------------------------------------------------------- 4548 DOFs = 6 4549 DofsPerFace = 2 4550 !---------------------------------------------------------------------------- 4551 ! First tabulate the basis functions in the default order. 4552 !---------------------------------------------------------------------------- 4553 ! Two basis functions defined on face 12: 4554 !------------------------------------------------- 4555 FBasis(1,1) = sqrt(3.0d0)/6.0d0 * (-sqrt(3.0d0) + u + v) 4556 FBasis(1,2) = sqrt(3.0d0)/6.0d0 * (-sqrt(3.0d0) + 3.0d0 * u + v) 4557 DivBasis(1) = sqrt(3.0d0)/3.0d0 4558 4559 FBasis(2,1) = sqrt(3.0d0)/6.0d0 * (sqrt(3.0d0) + u - v) 4560 FBasis(2,2) = sqrt(3.0d0)/6.0d0 * (-sqrt(3.0d0) - 3.0d0 * u + v) 4561 DivBasis(2) = sqrt(3.0d0)/3.0d0 4562 4563 ! Two basis functions defined on face 23: 4564 4565 FBasis(3,1) = 1.0d0/(3.0d0+sqrt(3.0d0)) * (2.0d0+sqrt(3.0d0)+(2.0d0+sqrt(3.0d0))*u-(1.0d0+sqrt(3.0d0))*v) 4566 FBasis(3,2) = 1.0d0/6.0d0 * ( -3.0d0+sqrt(3.0d0) ) * v 4567 DivBasis(3) = sqrt(3.0d0)/3.0d0 4568 4569 FBasis(4,1) = 1.0d0/6.0d0 * (-3.0d0+sqrt(3.0d0)+(-3.0d0+sqrt(3.0d0))*u + 2.0d0*sqrt(3.0d0)*v) 4570 FBasis(4,2) = 1.0d0/6.0d0 * ( 3.0d0+sqrt(3.0d0) ) * v 4571 DivBasis(4) = sqrt(3.0d0)/3.0d0 4572 4573 4574 ! Two basis functions defined on face 31: 4575 4576 FBasis(5,1) = 1.0d0/( 3.0d0+sqrt(3.0d0) ) * ( 1.0d0 - u - v - sqrt(3.0d0)*v ) 4577 FBasis(5,2) = ( 3.0d0+2.0d0*sqrt(3.0d0) ) * v /(3.0d0*(1.0d0+sqrt(3.0d0))) 4578 DivBasis(5) = sqrt(3.0d0)/3.0d0 4579 4580 FBasis(6,1) = 1.0d0/6.0d0 * (-3.0d0-sqrt(3.0d0)+(3.0d0+sqrt(3.0d0))*u + 2.0d0*sqrt(3.0d0)*v) 4581 FBasis(6,2) = 1.0d0/6.0d0 * ( -3.0d0+sqrt(3.0d0) ) * v 4582 DivBasis(6) = sqrt(3.0d0)/3.0d0 4583 4584 !----------------------------------------------------- 4585 ! Now do the reordering and sign reversion: 4586 !----------------------------------------------------- 4587 DO q=1,3 4588 IF (RevertSign(q)) THEN 4589 DO j=1,DofsPerFace 4590 i = (q-1)*DofsPerFace + j 4591 WorkBasis(j,1:2) = FBasis(i,1:2) 4592 WorkDivBasis(j) = DivBasis(i) 4593 END DO 4594 i = 2*q - 1 4595 FBasis(i,1:2) = -WorkBasis(2,1:2) 4596 DivBasis(i) = -WorkDivBasis(2) 4597 i = 2*q 4598 FBasis(i,1:2) = -WorkBasis(1,1:2) 4599 DivBasis(i) = -WorkDivBasis(1) 4600 END IF 4601 END DO 4602 4603 ELSE 4604 DOFs = 3 4605 4606 FBasis(1,1) = SQRT(3.0d0)/6.0d0 * u 4607 FBasis(1,2) = -0.5d0 + SQRT(3.0d0)/6.0d0 * v 4608 DivBasis(1) = SQRT(3.0d0)/3.0d0 4609 IF (RevertSign(1)) THEN 4610 FBasis(1,:) = -FBasis(1,:) 4611 DivBasis(1) = -DivBasis(1) 4612 END IF 4613 4614 FBasis(2,1) = SQRT(3.0d0)/6.0d0 * (1.0d0 + u) 4615 FBasis(2,2) = SQRT(3.0d0)/6.0d0 * v 4616 DivBasis(2) = SQRT(3.0d0)/3.0d0 4617 IF (RevertSign(2)) THEN 4618 FBasis(2,:) = -FBasis(2,:) 4619 DivBasis(2) = -DivBasis(2) 4620 END IF 4621 4622 FBasis(3,1) = SQRT(3.0d0)/6.0d0 * (-1.0d0 + u) 4623 FBasis(3,2) = SQRT(3.0d0)/6.0d0 * v 4624 DivBasis(3) = SQRT(3.0d0)/3.0d0 4625 IF (RevertSign(3)) THEN 4626 FBasis(3,:) = -FBasis(3,:) 4627 DivBasis(3) = -DivBasis(3) 4628 END IF 4629 4630 END IF 4631 4632 CASE(4) 4633 DOFs = 6 4634 !-------------------------------------------------------------------- 4635 ! Quadrilateral Arnold-Boffi-Falk (ABF) element basis of degree k=0 4636 !-------------------------------------------------------------------- 4637 EdgeMap => GetEdgeMap(4) 4638 SquareFaceMap(:) = (/ 1,2,3,4 /) 4639 Ind => Element % Nodeindexes 4640 4641 IF (.NOT. CreateDualBasis) THEN 4642 !------------------------------------------------- 4643 ! Four basis functions defined on the edges 4644 !------------------------------------------------- 4645 i = EdgeMap(1,1) 4646 j = EdgeMap(1,2) 4647 ni = Element % NodeIndexes(i) 4648 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4649 nj = Element % NodeIndexes(j) 4650 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4651 FBasis(1,1) = 0.0d0 4652 FBasis(1,2) = -((-1.0d0 + v)*v)/4.0d0 4653 DivBasis(1) = (1.0d0 - 2*v)/4.0d0 4654 IF (nj<ni) THEN 4655 FBasis(1,:) = -FBasis(1,:) 4656 DivBasis(1) = -DivBasis(1) 4657 END IF 4658 4659 i = EdgeMap(2,1) 4660 j = EdgeMap(2,2) 4661 ni = Element % NodeIndexes(i) 4662 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4663 nj = Element % NodeIndexes(j) 4664 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4665 FBasis(2,1) = (u*(1.0d0 + u))/4.0d0 4666 FBasis(2,2) = 0.0d0 4667 DivBasis(2) = (1 + 2.0d0*u)/4.0d0 4668 IF (nj<ni) THEN 4669 FBasis(2,:) = -FBasis(2,:) 4670 DivBasis(2) = -DivBasis(2) 4671 END IF 4672 4673 i = EdgeMap(3,1) 4674 j = EdgeMap(3,2) 4675 ni = Element % NodeIndexes(i) 4676 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4677 nj = Element % NodeIndexes(j) 4678 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4679 FBasis(3,1) = 0.0d0 4680 FBasis(3,2) = (v*(1.0d0 + v))/4.0d0 4681 DivBasis(3) = (1.0d0 + 2.0d0*v)/4.0d0 4682 IF (nj<ni) THEN 4683 FBasis(3,:) = -FBasis(3,:) 4684 DivBasis(3) = -DivBasis(3) 4685 END IF 4686 4687 i = EdgeMap(4,1) 4688 j = EdgeMap(4,2) 4689 ni = Element % NodeIndexes(i) 4690 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4691 nj = Element % NodeIndexes(j) 4692 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4693 FBasis(4,1) = -((-1.0d0 + u)*u)/4.0d0 4694 FBasis(4,2) = 0.0d0 4695 DivBasis(4) = (1.0d0 - 2.0d0*u)/4.0d0 4696 IF (nj<ni) THEN 4697 FBasis(4,:) = -FBasis(4,:) 4698 DivBasis(4) = -DivBasis(4) 4699 END IF 4700 4701 !-------------------------------------------------------------------- 4702 ! Additional two basis functions associated with the element interior 4703 !------------------------------------------------------------------- 4704 WorkBasis(1,:) = 0.0d0 4705 WorkBasis(2,:) = 0.0d0 4706 WorkDivBasis(:) = 0.0d0 4707 4708 WorkBasis(1,1) = 0.0d0 4709 WorkBasis(1,2) = (-1.0d0 + v**2)/2.0d0 4710 WorkDivBasis(1) = v 4711 4712 WorkBasis(2,1) = (1.0d0 - u**2)/2.0d0 4713 WorkBasis(2,2) = 0.0d0 4714 WorkDivBasis(2) = -u 4715 4716 DO j=1,4 4717 FaceIndices(j) = Ind(SquareFaceMap(j)) 4718 END DO 4719 IF (Parallel) THEN 4720 DO j=1,4 4721 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 4722 END DO 4723 END IF 4724 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 4725 4726 FBasis(5,:) = D1 * WorkBasis(I1,:) 4727 DivBasis(5) = D1 * WorkDivBasis(I1) 4728 FBasis(6,:) = D2 * WorkBasis(I2,:) 4729 DivBasis(6) = D2 * WorkDivBasis(I2) 4730 ELSE 4731 !--------------------------------------------------------------------------- 4732 ! Create alternate basis functions for the ABF space so that these basis 4733 ! functions are dual to the standard basis functions when the mesh is regular. 4734 ! First four basis functions which are dual to the standard edge basis 4735 ! functions: 4736 !---------------------------------------------------------------------------- 4737 i = EdgeMap(1,1) 4738 j = EdgeMap(1,2) 4739 ni = Element % NodeIndexes(i) 4740 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4741 nj = Element % NodeIndexes(j) 4742 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4743 FBasis(1,1) = 0.0d0 4744 FBasis(1,2) = (-3.0d0*(-1.0d0 - 2.0d0*v + 5.0d0*v**2))/4.0d0 4745 DivBasis(1) = (-3.0d0*(-1.0d0 + 5.0d0*v))/2.0d0 4746 IF (nj<ni) THEN 4747 FBasis(1,:) = -FBasis(1,:) 4748 DivBasis(1) = -DivBasis(1) 4749 END IF 4750 4751 i = EdgeMap(2,1) 4752 j = EdgeMap(2,2) 4753 ni = Element % NodeIndexes(i) 4754 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4755 nj = Element % NodeIndexes(j) 4756 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4757 FBasis(2,1) = (3.0d0*(-1.0d0 + 2.0d0*u + 5.0d0*u**2))/4.0d0 4758 FBasis(2,2) = 0.0d0 4759 DivBasis(2) = (3.0d0*(1.0d0 + 5.0d0*u))/2.0d0 4760 IF (nj<ni) THEN 4761 FBasis(2,:) = -FBasis(2,:) 4762 DivBasis(2) = -DivBasis(2) 4763 END IF 4764 4765 i = EdgeMap(3,1) 4766 j = EdgeMap(3,2) 4767 ni = Element % NodeIndexes(i) 4768 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4769 nj = Element % NodeIndexes(j) 4770 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4771 FBasis(3,1) = 0.0d0 4772 FBasis(3,2) = (3.0d0*(-1.0d0 + 2.0d0*v + 5.0d0*v**2))/4.0d0 4773 DivBasis(3) = (3.0d0*(1.0d0 + 5.0d0*v))/2.0d0 4774 IF (nj<ni) THEN 4775 FBasis(3,:) = -FBasis(3,:) 4776 DivBasis(3) = -DivBasis(3) 4777 END IF 4778 4779 i = EdgeMap(4,1) 4780 j = EdgeMap(4,2) 4781 ni = Element % NodeIndexes(i) 4782 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 4783 nj = Element % NodeIndexes(j) 4784 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 4785 FBasis(4,1) = (-3.0d0*(-1.0d0 - 2.0d0*u + 5.0d0*u**2))/4.0d0 4786 FBasis(4,2) = 0.0d0 4787 DivBasis(4) = (-3.0d0*(-1.0d0 + 5.0d0*u))/2.0d0 4788 IF (nj<ni) THEN 4789 FBasis(4,:) = -FBasis(4,:) 4790 DivBasis(4) = -DivBasis(4) 4791 END IF 4792 4793 !------------------------------------------------------------------------- 4794 ! Additional two dual basis functions associated with the element interior 4795 !------------------------------------------------------------------------- 4796 WorkBasis(1,:) = 0.0d0 4797 WorkBasis(2,:) = 0.0d0 4798 WorkDivBasis(:) = 0.0d0 4799 4800 WorkBasis(1,1) = 0.0d0 4801 WorkBasis(1,2) = (3.0d0*(-3.0d0 + 5.0d0*v**2))/8.0d0 4802 WorkDivBasis(1) = 15.0d0*v/4.0d0 4803 4804 WorkBasis(2,1) = (3.0d0*(3.0d0 - 5.0d0*u**2))/8.0d0 4805 WorkBasis(2,2) = 0.0d0 4806 WorkDivBasis(2) = -15.0d0*u/4.0d0 4807 4808 DO j=1,4 4809 FaceIndices(j) = Ind(SquareFaceMap(j)) 4810 END DO 4811 IF (Parallel) THEN 4812 DO j=1,4 4813 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 4814 END DO 4815 END IF 4816 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 4817 4818 FBasis(5,:) = D1 * WorkBasis(I1,:) 4819 DivBasis(5) = D1 * WorkDivBasis(I1) 4820 FBasis(6,:) = D2 * WorkBasis(I2,:) 4821 DivBasis(6) = D2 * WorkDivBasis(I2) 4822 END IF 4823 4824 CASE(5) 4825 !----------------------------------------- 4826 ! This branch is for handling tetrahedra 4827 !----------------------------------------------------------------------------------- 4828 ! Check first whether a sign reversion will be needed as face dofs have orientation. 4829 ! If the sign is not reverted, the positive value of the degree of freedom produces 4830 ! positive outward flux from the element through the face handled. 4831 !----------------------------------------------------------------------------------- 4832 CALL FaceElementOrientation(Element, RevertSign) 4833 4834 IF (CreateBDMBasis) THEN 4835 DOFs = 12 4836 DofsPerFace = 3 ! This choice is used for the BDM space of degree k=1 4837 !---------------------------------------------------------------------------- 4838 ! Create a table of BDM basis functions in the default order 4839 !---------------------------------------------------------------------------- 4840 ! Face {213}: 4841 BDMBasis(1,1) = (3*Sqrt(6.0d0) + 2*Sqrt(6.0d0)*u - 3*Sqrt(2.0d0)*v - 3*w)/12.0 4842 BDMBasis(1,2) = (-2*Sqrt(2.0d0) - 3*Sqrt(2.0d0)*u + Sqrt(3.0d0)*w)/12.0 4843 BDMBasis(1,3) = (-8 - 12*u + 4*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w)/12.0 4844 4845 BDMBasis(2,1) = (2*Sqrt(6.0d0)*u + 3*(-Sqrt(6.0d0) + Sqrt(2.0d0)*v + w))/12.0 4846 BDMBasis(2,2) = (-2*Sqrt(2.0d0) + 3*Sqrt(2.0d0)*u + Sqrt(3.0d0)*w)/12.0 4847 BDMBasis(2,3) = u + (-8 + 4*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w)/12.0 4848 4849 BDMBasis(3,1) = -u/(2.0*Sqrt(6.0d0)) 4850 BDMBasis(3,2) = (Sqrt(2.0d0) + 3*Sqrt(6.0d0)*v - 2*Sqrt(3.0d0)*w)/12.0 4851 BDMBasis(3,3) = (4 - 8*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w)/12.0 4852 4853 ! Face {124}: 4854 BDMBasis(4,1) = (2*Sqrt(6.0d0)*u + 3*(-Sqrt(6.0d0) + Sqrt(2.0d0)*v + w))/12.0 4855 BDMBasis(4,2) = (-6*Sqrt(2.0d0) + 9*Sqrt(2.0d0)*u + 2*Sqrt(6.0d0)*v + 3*Sqrt(3.0d0)*w)/12.0 4856 BDMBasis(4,3) = -w/(2.0*Sqrt(6.0d0)) 4857 BDMBasis(5,1) = (3*Sqrt(6.0d0) + 2*Sqrt(6.0d0)*u - 3*Sqrt(2.0d0)*v - 3*w)/12.0 4858 BDMBasis(5,2) = (-6*Sqrt(2.0d0) - 9*Sqrt(2.0d0)*u + 2*Sqrt(6.0d0)*v + 3*Sqrt(3.0d0)*w)/12.0 4859 BDMBasis(5,3) = -w/(2.0*Sqrt(6.0d0)) 4860 BDMBasis(6,1) = -u/(2.0*Sqrt(6.0d0)) 4861 BDMBasis(6,2) = (3*Sqrt(2.0d0) - Sqrt(6.0d0)*v - 6*Sqrt(3.0d0)*w)/12.0 4862 BDMBasis(6,3) = (5*w)/(2.0*Sqrt(6.0d0)) 4863 4864 ! Face {234}: 4865 BDMBasis(7,1) = (5*Sqrt(6.0d0) + 5*Sqrt(6.0d0)*u - 6*Sqrt(2.0d0)*v - 6*w)/12.0 4866 BDMBasis(7,2) = -v/(2.0*Sqrt(6.0d0)) 4867 BDMBasis(7,3) = -w/(2.0*Sqrt(6.0d0)) 4868 BDMBasis(8,1) = (-Sqrt(6.0d0) - Sqrt(6.0d0)*u + 6*Sqrt(2.0d0)*v - 3*w)/12.0 4869 BDMBasis(8,2) = (5*Sqrt(6.0)*v - 3*Sqrt(3.0d0)*w)/12.0 4870 BDMBasis(8,3) = -w/(2.0*Sqrt(6.0d0)) 4871 BDMBasis(9,1) = (-Sqrt(6.0d0) - Sqrt(6.0d0)*u + 9*w)/12.0 4872 BDMBasis(9,2) = (-(Sqrt(6.0d0)*v) + 3*Sqrt(3.0d0)*w)/12.0 4873 BDMBasis(9,3) = (5*w)/(2.0*Sqrt(6.0d0)) 4874 4875 ! Face {314}: 4876 BDMBasis(10,1) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - 6*Sqrt(2.0d0)*v + 3*w)/12.0 4877 BDMBasis(10,2) = (5*Sqrt(6.0d0)*v - 3*Sqrt(3.0d0)*w)/12.0 4878 BDMBasis(10,3) = -w/(2.0*Sqrt(6.0d0)) 4879 BDMBasis(11,1) = (-5*Sqrt(6.0d0) + 5*Sqrt(6.0d0)*u + 6*Sqrt(2.0d0)*v + 6*w)/12.0 4880 BDMBasis(11,2) = -v/(2.0*Sqrt(6.0d0)) 4881 BDMBasis(11,3) = -w/(2.0*Sqrt(6.0d0)) 4882 BDMBasis(12,1) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - 9*w)/12.0 4883 BDMBasis(12,2) = (-(Sqrt(6.0d0)*v) + 3*Sqrt(3.0d0)*w)/12.0 4884 BDMBasis(12,3) = (5*w)/(2.0*Sqrt(6.0d0)) 4885 4886 !---------------------------------------------------------------------- 4887 ! Find out how face basis functions must be ordered so that the global 4888 ! indexing convention is respected. 4889 !----------------------------------------------------------------------- 4890 CALL FaceElementBasisOrdering(Element, FDofMap) 4891 4892 !----------------------------------------------------- 4893 ! Now do the actual reordering and sign reversion 4894 !----------------------------------------------------- 4895 DO q=1,4 4896 IF (RevertSign(q)) THEN 4897 S = -1.0d0 4898 ELSE 4899 S = 1.0d0 4900 END IF 4901 4902 DO j=1,DofsPerFace 4903 k = FDofMap(q,j) 4904 i = (q-1)*DofsPerFace + j 4905 FBasis(i,:) = S * BDMBasis((q-1)*DofsPerFace+k,:) 4906 DivBasis(i) = S * sqrt(3.0d0)/(2.0d0*sqrt(2.0d0)) 4907 END DO 4908 END DO 4909 4910 ELSE 4911 DOFs = 4 4912 !------------------------------------------------------------------------- 4913 ! The basis functions that define RT space on reference element 4914 !----------------------------------------------------------------------- 4915 FBasis(1,1) = SQRT(2.0d0)/4.0d0 * u 4916 FBasis(1,2) = -SQRT(6.0d0)/12.0d0 + SQRT(2.0d0)/4.0d0 * v 4917 FBasis(1,3) = -1.0d0/SQRT(3.0d0) + SQRT(2.0d0)/4.0d0 * w 4918 DivBasis(1) = 3.0d0*SQRT(2.0d0)/4.0d0 4919 IF ( RevertSign(1) ) THEN 4920 FBasis(1,:) = -FBasis(1,:) 4921 DivBasis(1) = -DivBasis(1) 4922 END IF 4923 4924 FBasis(2,1) = SQRT(2.0d0)/4.0d0 * u 4925 FBasis(2,2) = -SQRT(6.0d0)/4.0d0 + SQRT(2.0d0)/4.0d0 * v 4926 FBasis(2,3) = SQRT(2.0d0)/4.0d0 * w 4927 DivBasis(2) = 3.0d0*SQRT(2.0d0)/4.0d0 4928 IF ( RevertSign(2) ) THEN 4929 FBasis(2,:) = -FBasis(2,:) 4930 DivBasis(2) = -DivBasis(2) 4931 END IF 4932 4933 FBasis(3,1) = SQRT(2.0d0)/4.0d0 + SQRT(2.0d0)/4.0d0 * u 4934 FBasis(3,2) = SQRT(2.0d0)/4.0d0 * v 4935 FBasis(3,3) = SQRT(2.0d0)/4.0d0 * w 4936 DivBasis(3) = 3.0d0*SQRT(2.0d0)/4.0d0 4937 IF ( RevertSign(3) ) THEN 4938 FBasis(3,:) = -FBasis(3,:) 4939 DivBasis(3) = -DivBasis(3) 4940 END IF 4941 4942 FBasis(4,1) = -SQRT(2.0d0)/4.0d0 + SQRT(2.0d0)/4.0d0 * u 4943 FBasis(4,2) = SQRT(2.0d0)/4.0d0 * v 4944 FBasis(4,3) = SQRT(2.0d0)/4.0d0 * w 4945 DivBasis(4) = 3.0d0*SQRT(2.0d0)/4.0d0 4946 IF ( RevertSign(4) ) THEN 4947 FBasis(4,:) = -FBasis(4,:) 4948 DivBasis(4) = -DivBasis(4) 4949 END IF 4950 END IF 4951 CASE DEFAULT 4952 CALL Fatal('ElementDescription::FaceElementInfo','Unsupported element type') 4953 END SELECT 4954 4955 IF (PerformPiolaTransform) THEN 4956 DO j=1,DOFs 4957 DO k=1,dim 4958 WorkBasis(1,k) = SUM( LF(k,1:dim) * FBasis(j,1:dim) ) 4959 END DO 4960 FBasis(j,1:dim) = 1.0d0/DetF * WorkBasis(1,1:dim) 4961 4962 DivBasis(j) = 1.0d0/DetF * DivBasis(j) 4963 END DO 4964 ! DetF = ABS(DetF) 4965 END IF 4966 4967 IF (PRESENT(F)) F = LF 4968 IF (PRESENT(DivFBasis)) DivFBasis(1:DOFs) = DivBasis(1:DOFs) 4969!----------------------------------------------------------------------------- 4970 END FUNCTION FaceElementInfo 4971!------------------------------------------------------------------------------ 4972 4973 4974!---------------------------------------------------------------------------------------------- 4975!> This function returns data for performing the Piola transformation 4976!------------------------------------------------------------------------------------------------ 4977 FUNCTION PiolaTransformationData(nn,Element,Nodes,F,DetF,dLBasisdx) RESULT(Success) 4978!------------------------------------------------------------------------------------------------- 4979 INTEGER :: nn !< The number of classic nodes used in the element mapping 4980 TYPE(Element_t) :: Element !< Element structure 4981 TYPE(Nodes_t) :: Nodes !< Data corresponding to the classic element nodes 4982 REAL(KIND=dp) :: F(:,:) !< The gradient of the element mapping 4983 REAL(KIND=dp) :: DetF !< The determinant of the gradient matrix (or the Jacobian matrix) 4984 REAL(KIND=dp) :: dLBasisdx(:,:) !< Derivatives of nodal basis functions with respect to local coordinates 4985 LOGICAL :: Success !< Could and should return .FALSE. if the element is degenerate 4986!----------------------------------------------------------------------------------------------------- 4987! Local variables 4988!------------------------------------------------------------------------------------------------- 4989 REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z 4990 INTEGER :: cdim,dim,n,i 4991!------------------------------------------------------------------------------------------------- 4992 x => Nodes % x 4993 y => Nodes % y 4994 z => Nodes % z 4995 4996 ! cdim = CoordinateSystemDimension() 4997 n = MIN( SIZE(x), nn ) 4998 dim = Element % TYPE % DIMENSION 4999 5000 !------------------------------------------------------------------------------ 5001 ! The gradient of the element mapping K = f(k), with k the reference element 5002 !------------------------------------------------------------------------------ 5003 F = 0.0d0 5004 DO i=1,dim 5005 F(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) ) 5006 F(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) ) 5007 !IF (dim == 3) & 5008 ! In addition to the case dim = 3, the following entries may be useful 5009 ! with dim=2 when natural BCs in 3-D are handled. 5010 F(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) ) 5011 END DO 5012 5013 SELECT CASE( dim ) 5014 CASE(1) 5015 DetF = sqrt(SUM(F(1:3,1)**2)) 5016 CASE (2) 5017 DetF = F(1,1)*F(2,2) - F(1,2)*F(2,1) 5018 CASE(3) 5019 DetF = F(1,1) * ( F(2,2)*F(3,3) - F(2,3)*F(3,2) ) + & 5020 F(1,2) * ( F(2,3)*F(3,1) - F(2,1)*F(3,3) ) + & 5021 F(1,3) * ( F(2,1)*F(3,2) - F(2,2)*F(3,1) ) 5022 END SELECT 5023 5024 success = .TRUE. 5025!------------------------------------------------ 5026 END FUNCTION PiolaTransformationData 5027!------------------------------------------------ 5028 5029!----------------------------------------------------------------------------------- 5030!> Get information about whether a sign reversion will be needed to obtain right 5031!> DOFs for face (vector) elements. If the sign is not reverted, the positive value of 5032!> the degree of freedom produces positive outward flux from the element through 5033!> the face handled. 5034!----------------------------------------------------------------------------------- 5035SUBROUTINE FaceElementOrientation(Element, RevertSign, FaceIndex, Nodes) 5036!----------------------------------------------------------------------------------- 5037 IMPLICIT NONE 5038 5039 TYPE(Element_t), INTENT(IN) :: Element !< A 3-D/2-D element having 2-D/1-D faces 5040 LOGICAL, INTENT(OUT) :: RevertSign(:) !< Face-wise information about the sign reversions 5041 INTEGER, OPTIONAL, INTENT(IN) :: FaceIndex !< Check just one face that is specified here 5042 TYPE(Nodes_t), OPTIONAL :: Nodes !< An inactive variable related to code verification 5043!----------------------------------------------------------------------------------- 5044 TYPE(Mesh_t), POINTER :: Mesh 5045 LOGICAL :: Parallel 5046 5047 INTEGER, POINTER :: FaceMap(:,:), Ind(:) 5048 INTEGER, TARGET :: TetraFaceMap(4,3) 5049 INTEGER :: FaceIndices(4) 5050 INTEGER :: j, q, first_face, last_face 5051 5052 ! Some inactive variables that were used in the code verification 5053 LOGICAL :: RevertSign2(4), CheckSignReversions 5054 INTEGER :: i, k, A, B, C, D 5055 REAL(KIND=dp) :: t1(3), t2(3), m(3), e(3) 5056!----------------------------------------------------------------------------------- 5057 RevertSign(:) = .FALSE. 5058 5059 IF (PRESENT(FaceIndex)) THEN 5060 first_face = FaceIndex 5061 last_face = FaceIndex 5062 ELSE 5063 first_face = 1 5064 END IF 5065 5066 Mesh => CurrentModel % Solver % Mesh 5067 Parallel = ASSOCIATED(Mesh % ParallelInfo % Interface) 5068 Ind => Element % NodeIndexes 5069 5070 SELECT CASE(Element % TYPE % ElementCode / 100) 5071 CASE(3) 5072 FaceMap => GetEdgeMap(3) 5073 5074 IF (.NOT. PRESENT(FaceIndex)) last_face = 3 5075 IF (SIZE(RevertSign) < last_face) CALL Fatal('FaceElementOrientation', & 5076 'Too small array for listing element faces') 5077 5078 DO q=first_face,last_face 5079 DO j=1,2 5080 FaceIndices(j) = Ind(FaceMap(q,j)) 5081 END DO 5082 IF (Parallel) THEN 5083 DO j=1,2 5084 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 5085 END DO 5086 END IF 5087 5088 IF (FaceIndices(2) < FaceIndices(1)) RevertSign(q) = .TRUE. 5089 END DO 5090 5091 CASE(4) 5092 FaceMap => GetEdgeMap(4) 5093 5094 IF (.NOT. PRESENT(FaceIndex)) last_face = 4 5095 IF (SIZE(RevertSign) < last_face) CALL Fatal('FaceElementOrientation', & 5096 'Too small array for listing element faces') 5097 5098 DO q=first_face,last_face 5099 DO j=1,2 5100 FaceIndices(j) = Ind(FaceMap(q,j)) 5101 END DO 5102 IF (Parallel) THEN 5103 DO j=1,2 5104 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 5105 END DO 5106 END IF 5107 5108 IF (FaceIndices(2) < FaceIndices(1)) RevertSign(q) = .TRUE. 5109 END DO 5110 5111 CASE(5) 5112 TetraFaceMap(1,:) = (/ 2, 1, 3 /) 5113 TetraFaceMap(2,:) = (/ 1, 2, 4 /) 5114 TetraFaceMap(3,:) = (/ 2, 3, 4 /) 5115 TetraFaceMap(4,:) = (/ 3, 1, 4 /) 5116 5117 FaceMap => TetraFaceMap 5118 5119 IF (.NOT. PRESENT(FaceIndex)) last_face = 4 5120 IF (SIZE(RevertSign) < last_face) CALL Fatal('FaceElementOrientation', & 5121 'Too small array for listing element faces') 5122 5123 DO q=first_face,last_face 5124 DO j=1,3 5125 FaceIndices(j) = Ind(FaceMap(q,j)) 5126 END DO 5127 IF (Parallel) THEN 5128 DO j=1,3 5129 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 5130 END DO 5131 END IF 5132 5133 IF ( (FaceIndices(1) < FaceIndices(2)) .AND. (FaceIndices(1) < FaceIndices(3)) ) THEN 5134 IF (FaceIndices(3) < FaceIndices(2)) THEN 5135 RevertSign(q) = .TRUE. 5136 END IF 5137 ELSE IF ( ( FaceIndices(2) < FaceIndices(1) ) .AND. ( FaceIndices(2) < FaceIndices(3) ) ) THEN 5138 IF ( FaceIndices(1) < FaceIndices(3) ) THEN 5139 RevertSign(q) = .TRUE. 5140 END IF 5141 ELSE 5142 IF ( FaceIndices(2) < FaceIndices(1) ) THEN 5143 RevertSign(q) = .TRUE. 5144 END IF 5145 END IF 5146 END DO 5147 5148 !---------------------------------------------------------------------- 5149 ! Another way for finding sign reversions in the case of tetrahedron. 5150 ! This code is retained here, although it was used for verification purposes... 5151 !---------------------------------------------------------------------- 5152 CheckSignReversions = .FALSE. 5153 IF (CheckSignReversions) THEN 5154 DO q=1,4 5155 RevertSign2(q) = .FALSE. 5156 i = FaceMap(q,1) 5157 j = FaceMap(q,2) 5158 k = FaceMap(q,3) 5159 5160 IF ( ( Ind(i) < Ind(j) ) .AND. ( Ind(i) < Ind(k) ) ) THEN 5161 A = i 5162 IF (Ind(j) < Ind(k)) THEN 5163 B = j 5164 C = k 5165 ELSE 5166 B = k 5167 C = j 5168 END IF 5169 ELSE IF ( ( Ind(j) < Ind(i) ) .AND. ( Ind(j) < Ind(k) ) ) THEN 5170 A = j 5171 IF (Ind(i) < Ind(k)) THEN 5172 B = i 5173 C = k 5174 ELSE 5175 B = k 5176 C = i 5177 END IF 5178 ELSE 5179 A = k 5180 IF (Ind(i) < Ind(j)) THEN 5181 B = i 5182 C = j 5183 ELSE 5184 B = j 5185 C = i 5186 END IF 5187 END IF 5188 5189 t1(1) = Nodes % x(B) - Nodes % x(A) 5190 t1(2) = Nodes % y(B) - Nodes % y(A) 5191 t1(3) = Nodes % z(B) - Nodes % z(A) 5192 5193 t2(1) = Nodes % x(C) - Nodes % x(A) 5194 t2(2) = Nodes % y(C) - Nodes % y(A) 5195 t2(3) = Nodes % z(C) - Nodes % z(A) 5196 5197 m(1:3) = CrossProduct(t1,t2) 5198 5199 SELECT CASE(q) 5200 CASE(1) 5201 D = 4 5202 CASE(2) 5203 D = 3 5204 CASE(3) 5205 D = 1 5206 CASE(4) 5207 D = 2 5208 END SELECT 5209 5210 e(1) = Nodes % x(D) - Nodes % x(A) 5211 e(2) = Nodes % y(D) - Nodes % y(A) 5212 e(3) = Nodes % z(D) - Nodes % z(A) 5213 5214 IF ( SUM(m(1:3) * e(1:3)) > 0.0d0 ) RevertSign2(q) = .TRUE. 5215 5216 END DO 5217 5218 IF ( ANY(RevertSign(1:4) .NEQV. RevertSign2(1:4)) ) THEN 5219 PRINT *, 'CONFLICTING SIGN REVERSIONS SUGGESTED' 5220 PRINT *, RevertSign(1:4) 5221 PRINT *, RevertSign2(1:4) 5222 STOP EXIT_ERROR 5223 END IF 5224 END IF 5225 5226 CASE DEFAULT 5227 CALL Fatal('FaceElementOrientation', 'Unsupported element family') 5228 END SELECT 5229!----------------------------------------------------------------------------------- 5230END SUBROUTINE FaceElementOrientation 5231!----------------------------------------------------------------------------------- 5232 5233!----------------------------------------------------------------------------------- 5234!> This subroutine produces information about how the basis functions of face (vector) 5235!> elements have to be reordered to conform with the global ordering convention. 5236!> Currently this can handle only the tetrahedron of Nedelec's second family. 5237!----------------------------------------------------------------------------------- 5238SUBROUTINE FaceElementBasisOrdering(Element, FDofMap, FaceIndex) 5239!----------------------------------------------------------------------------------- 5240 IMPLICIT NONE 5241 5242 TYPE(Element_t), INTENT(IN) :: Element !< A 3-D element having 2-D faces 5243 INTEGER, INTENT(OUT) :: FDofMap(4,3) !< Face-wise information for the basis permutation 5244 INTEGER, OPTIONAL, INTENT(IN) :: FaceIndex !< Check just one face that is specified here 5245!----------------------------------------------------------------------------------- 5246 TYPE(Mesh_t), POINTER :: Mesh 5247 LOGICAL :: Parallel 5248 INTEGER, POINTER :: FaceMap(:,:), Ind(:) 5249 INTEGER, TARGET :: TetraFaceMap(4,3), FaceIndices(4) 5250 INTEGER :: j, q, first_face, last_face 5251!----------------------------------------------------------------------------------- 5252 FDofMap(4,3) = 0 5253 5254 IF (PRESENT(FaceIndex)) THEN 5255 first_face = FaceIndex 5256 last_face = FaceIndex 5257 ELSE 5258 first_face = 1 5259 END IF 5260 5261 Mesh => CurrentModel % Solver % Mesh 5262 Parallel = ASSOCIATED(Mesh % ParallelInfo % Interface) 5263 Ind => Element % NodeIndexes 5264 5265 SELECT CASE(Element % TYPE % ElementCode / 100) 5266 CASE(5) 5267 TetraFaceMap(1,:) = (/ 2, 1, 3 /) 5268 TetraFaceMap(2,:) = (/ 1, 2, 4 /) 5269 TetraFaceMap(3,:) = (/ 2, 3, 4 /) 5270 TetraFaceMap(4,:) = (/ 3, 1, 4 /) 5271 5272 FaceMap => TetraFaceMap 5273 5274 IF (.NOT. PRESENT(FaceIndex)) last_face = 4 5275 5276 DO q=first_face,last_face 5277 DO j=1,3 5278 FaceIndices(j) = Ind(FaceMap(q,j)) 5279 END DO 5280 IF (Parallel) THEN 5281 DO j=1,3 5282 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 5283 END DO 5284 END IF 5285 5286 IF ( ( FaceIndices(1) < FaceIndices(2) ) .AND. ( FaceIndices(1) < FaceIndices(3) ) ) THEN 5287 FDofMap(q,1) = 1 5288 IF (FaceIndices(2) < FaceIndices(3)) THEN 5289 FDofMap(q,2) = 2 5290 FDofMap(q,3) = 3 5291 ELSE 5292 FDofMap(q,2) = 3 5293 FDofMap(q,3) = 2 5294 END IF 5295 ELSE IF ( ( FaceIndices(2) < FaceIndices(1) ) .AND. ( FaceIndices(2) < FaceIndices(3) ) ) THEN 5296 FDofMap(q,1) = 2 5297 IF (FaceIndices(1) < FaceIndices(3)) THEN 5298 FDofMap(q,2) = 1 5299 FDofMap(q,3) = 3 5300 ELSE 5301 FDofMap(q,2) = 3 5302 FDofMap(q,3) = 1 5303 END IF 5304 ELSE 5305 FDofMap(q,1) = 3 5306 IF (FaceIndices(1) < FaceIndices(2)) THEN 5307 FDofMap(q,2) = 1 5308 FDofMap(q,3) = 2 5309 ELSE 5310 FDofMap(q,2) = 2 5311 FDofMap(q,3) = 1 5312 END IF 5313 END IF 5314 END DO 5315 5316 CASE DEFAULT 5317 CALL Fatal('FaceElementBasisOrdering', 'Unsupported element family') 5318 END SELECT 5319!----------------------------------------------------------------------------------- 5320END SUBROUTINE FaceElementBasisOrdering 5321!----------------------------------------------------------------------------------- 5322 5323 5324!------------------------------------------------------------------------------ 5325!> Here the given element can be supposed to be some face of its parent element. 5326!> The index of the face in reference to the parent element and pointer 5327!> to the face are returned. The given element and the face returned are thus 5328!> representations of the same entity but they may still be indexed differently. 5329!------------------------------------------------------------------------------ 5330SUBROUTINE PickActiveFace(Mesh, Parent, Element, Face, ActiveFaceId) 5331!------------------------------------------------------------------------------ 5332 IMPLICIT NONE 5333 TYPE(Mesh_t), POINTER, INTENT(IN) :: Mesh 5334 TYPE(Element_t), POINTER, INTENT(IN) :: Parent, Element 5335 TYPE(Element_t), POINTER, INTENT(OUT) :: Face 5336 INTEGER, INTENT(OUT) :: ActiveFaceId 5337!------------------------------------------------------------------------------ 5338 INTEGER :: matches, k, l 5339!------------------------------------------------------------------------------ 5340 SELECT CASE(Element % TYPE % ElementCode / 100) 5341 CASE(2) 5342 IF ( ASSOCIATED(Parent % EdgeIndexes) ) THEN 5343 DO ActiveFaceId=1,Parent % TYPE % NumberOfEdges 5344 Face => Mesh % Edges(Parent % EdgeIndexes(ActiveFaceId)) 5345 matches = 0 5346 DO k=1,Element % TYPE % NumberOfNodes 5347 DO l=1,Face % TYPE % NumberOfNodes 5348 IF (Element % NodeIndexes(k) == Face % NodeIndexes(l)) & 5349 matches=matches+1 5350 END DO 5351 END DO 5352 IF (matches==Element % TYPE % NumberOfNodes) EXIT 5353 END DO 5354 ELSE 5355 matches = 0 5356 END IF 5357 CASE(3,4) 5358 IF ( ASSOCIATED(Parent % FaceIndexes) ) THEN 5359 DO ActiveFaceId=1,Parent % TYPE % NumberOfFaces 5360 Face => Mesh % Faces(Parent % FaceIndexes(ActiveFaceId)) 5361 IF ((Element % TYPE % ElementCode / 100) /= (Face % TYPE % ElementCode / 100)) CYCLE 5362 matches = 0 5363 DO k=1,Element % TYPE % NumberOfNodes 5364 DO l=1,Face % TYPE % NumberOfNodes 5365 IF (Element % NodeIndexes(k) == Face % NodeIndexes(l)) & 5366 matches=matches+1 5367 END DO 5368 END DO 5369 IF (matches == Element % TYPE % NumberOfNodes ) EXIT 5370 END DO 5371 ELSE 5372 matches = 0 5373 END IF 5374 CASE DEFAULT 5375 CALL Fatal('PickActiveFace', 'Element variable is of a wrong dimension') 5376 END SELECT 5377 5378 IF (matches /= Element % TYPE % NumberOfNodes) THEN 5379 Face => NULL() 5380 ActiveFaceId = 0 5381 CALL Warn('PickActiveFace', 'The element is not a face of given parent') 5382 END IF 5383!------------------------------------------------------------------------------ 5384END SUBROUTINE PickActiveFace 5385!------------------------------------------------------------------------------ 5386 5387 5388!------------------------------------------------------------------------------ 5389!> Perform the cross product of two vectors 5390!------------------------------------------------------------------------------ 5391 FUNCTION CrossProduct( v1, v2 ) RESULT( v3 ) 5392!------------------------------------------------------------------------------ 5393 IMPLICIT NONE 5394 REAL(KIND=dp) :: v1(3), v2(3), v3(3) 5395 v3(1) = v1(2)*v2(3) - v1(3)*v2(2) 5396 v3(2) = -v1(1)*v2(3) + v1(3)*v2(1) 5397 v3(3) = v1(1)*v2(2) - v1(2)*v2(1) 5398!------------------------------------------------------------------------------ 5399 END FUNCTION CrossProduct 5400!------------------------------------------------------------------------------ 5401 5402 5403!---------------------------------------------------------------------------------- 5404!> Return H(curl)-conforming edge element basis function values and their Curl 5405!> with respect to the reference element coordinates at a given point on the 5406!> reference element. Here the basis for a real element K is constructed by 5407!> transforming the basis functions defined on the reference element k via a version 5408!> of the Piola transformation designed for functions in H(curl). This construction 5409!> differs from the approach taken in the alternate subroutine GetEdgeBasis, which 5410!> does not make reference to the Piola transformation and hence may have limitations 5411!> in its extendability. The data for performing the Piola transformation is also returned. 5412!> Note that the reference element is chosen as in the p-approximation so that 5413!> the reference element edges/faces have the same length/area. This choice simplifies 5414!> the associated assembly procedure. 5415!> With giving the optional argument ApplyPiolaTransform = .TRUE., this function 5416!> also performs the Piola transform, so that the basis functions and their spatial 5417!> curl as defined on the physical element are returned. 5418!> In the lowest-order case this function returns the basis functions belonging 5419!> to the optimal family which is not subject to degradation of convergence on 5420!> meshes consisting of non-affine physical elements. The second-order elements 5421!> are members of the Nedelec's first family and are constructed in a hierarchic 5422!> fashion (the lowest-order basis functions give a partial construction of 5423!> the second-order basis). 5424!--------------------------------------------------------------------------------- 5425 FUNCTION EdgeElementInfo( Element, Nodes, u, v, w, F, G, detF, & 5426 Basis, EdgeBasis, RotBasis, dBasisdx, SecondFamily, BasisDegree, & 5427 ApplyPiolaTransform, ReadyEdgeBasis, ReadyRotBasis, & 5428 TangentialTrMapping) RESULT(stat) 5429!------------------------------------------------------------------------------ 5430 IMPLICIT NONE 5431 5432 TYPE(Element_t), TARGET :: Element !< Element structure 5433 TYPE(Nodes_t) :: Nodes !< Data corresponding to the classic element nodes 5434 REAL(KIND=dp) :: u !< 1st reference element coordinate at which the basis functions are evaluated 5435 REAL(KIND=dp) :: v !< 2nd local coordinate 5436 REAL(KIND=dp) :: w !< 3rd local coordinate 5437 REAL(KIND=dp), OPTIONAL :: F(3,3) !< The gradient F=Grad f, with f the element map f:k->K 5438 REAL(KIND=dp), OPTIONAL :: G(3,3) !< The transpose of the inverse of the gradient F 5439 REAL(KIND=dp) :: detF !< The determinant of the gradient matrix F 5440 REAL(KIND=dp) :: Basis(:) !< H1-conforming basis functions evaluated at (u,v,w) 5441 REAL(KIND=dp) :: EdgeBasis(:,:) !< The basis functions b spanning the reference element space 5442 REAL(KIND=dp), OPTIONAL :: RotBasis(:,:) !< The Curl of the edge basis functions with respect to the local coordinates 5443 REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:) !< The first derivatives of the H1-conforming basis functions at (u,v,w) 5444 LOGICAL, OPTIONAL :: SecondFamily !< If .TRUE., a Nedelec basis of the second kind is returned (only simplicial elements) 5445 INTEGER, OPTIONAL :: BasisDegree !< The approximation degree 2 is also supported 5446 LOGICAL, OPTIONAL :: ApplyPiolaTransform !< If .TRUE., perform the Piola transform so that, instead of b 5447 !< and Curl b, return B(f(p)) and (curl B)(f(p)) with B(x) the basis 5448 !< functions on the physical element and curl the spatial curl operator. 5449 !< In this case the absolute value of detF is returned. 5450 REAL(KIND=dp), OPTIONAL :: ReadyEdgeBasis(:,:) !< A pretabulated edge basis function can be given 5451 REAL(KIND=dp), OPTIONAL :: ReadyRotBasis(:,:) !< The preretabulated Curl of the edge basis function 5452 LOGICAL, OPTIONAL :: TangentialTrMapping !< To return b x n, with n=(0,0,1) the normal to the 2D reference element. 5453 !< The Piola transform is then the usual div-conforming version. 5454 LOGICAL :: Stat !< .FALSE. for a degenerate element 5455!----------------------------------------------------------------------------------------------------------------- 5456! Local variables 5457!------------------------------------------------------------------------------------------------------------ 5458 TYPE(Mesh_t), POINTER :: Mesh 5459 TYPE(Element_t), POINTER :: Parent, Face, pElement 5460 INTEGER :: n, dim, cdim, q, i, j, k, l, ni, nj, A, I1, I2, FaceIndices(4) 5461 REAL(KIND=dp) :: dLbasisdx(MAX(SIZE(Nodes % x),SIZE(Basis)),3), WorkBasis(4,3), WorkCurlBasis(4,3) 5462 REAL(KIND=dp) :: D1, D2, B(3), curlB(3), GT(3,3), LG(3,3), LF(3,3) 5463 REAL(KIND=dp) :: ElmMetric(3,3), detJ, CurlBasis(54,3) 5464 REAL(KIND=dp) :: t(3), s(3), v1, v2, v3, h1, h2, h3, dh1, dh2, dh3, grad(2) 5465 REAL(KIND=dp) :: LBasis(Element % TYPE % NumberOfNodes), Beta(4), EdgeSign(16) 5466 LOGICAL :: Create2ndKindBasis, PerformPiolaTransform, UsePretabulatedBasis, Parallel 5467 LOGICAL :: SecondOrder, ApplyTraceMapping, Found 5468 LOGICAL :: RevertSign(4) 5469 INTEGER, POINTER :: EdgeMap(:,:), Ind(:) 5470 INTEGER :: TriangleFaceMap(3), SquareFaceMap(4), BrickFaceMap(6,4), PrismSquareFaceMap(3,4), DOFs 5471 INTEGER :: ActiveFaceId 5472!---------------------------------------------------------------------------------------------------------- 5473 5474 Mesh => CurrentModel % Solver % Mesh 5475 Parallel = ASSOCIATED(Mesh % ParallelInfo % Interface) 5476 5477 stat = .TRUE. 5478 Basis = 0.0d0 5479 EdgeBasis = 0.0d0 5480 WorkBasis = 0.0d0 5481 CurlBasis = 0.0d0 5482 LG = 0.0d0 5483 !-------------------------------------------------------------------------------------------- 5484 ! Check whether ready edge basis function values are available to reduce computation. 5485 ! If they are available, this function is used primarily to obtain the Piola transformation. 5486 !-------------------------------------------------------------------------------------------- 5487 UsePretabulatedBasis = .FALSE. 5488 IF ( PRESENT(ReadyEdgeBasis) .AND. PRESENT(ReadyRotBasis) ) UsePretabulatedBasis = .TRUE. 5489 !------------------------------------------------------------------------------------------ 5490 ! Check whether the Nedelec basis functions of the second kind or higher order basis 5491 ! functions should be created and whether the Piola transform is already applied within 5492 ! this function. 5493 !------------------------------------------------------------------------------------------ 5494 Create2ndKindBasis = .FALSE. 5495 IF ( PRESENT(SecondFamily) ) Create2ndKindBasis = SecondFamily 5496 SecondOrder = .FALSE. 5497 IF ( PRESENT(BasisDegree) ) THEN 5498 SecondOrder = BasisDegree > 1 5499 END IF 5500 PerformPiolaTransform = .FALSE. 5501 IF ( PRESENT(ApplyPiolaTransform) ) PerformPiolaTransform = ApplyPiolaTransform 5502 5503 ApplyTraceMapping = .FALSE. 5504 IF ( PRESENT(TangentialTrMapping) ) ApplyTraceMapping = TangentialTrMapping 5505 !------------------------------------------------------------------------------------------- 5506 dLbasisdx = 0.0d0 5507 n = Element % TYPE % NumberOfNodes 5508 dim = Element % TYPE % DIMENSION 5509 cdim = CoordinateSystemDimension() 5510 5511 IF ( Element % TYPE % ElementCode == 101 ) THEN 5512 detF = 1.0d0 5513 Basis(1) = 1.0d0 5514 IF ( PRESENT(dBasisdx) ) dBasisdx(1,:) = 0.0d0 5515 RETURN 5516 END IF 5517 5518 !IF (cdim == 3 .AND. dim==1) THEN 5519 ! CALL Warn('EdgeElementInfo', 'Traces of 2-D edge elements have not been implemented yet') 5520 ! RETURN 5521 !END IF 5522 5523 !----------------------------------------------------------------------- 5524 ! The standard nodal basis functions on the reference element and 5525 ! their derivatives with respect to the local coordinates. These define 5526 ! the mapping of the reference element to an actual element on the background 5527 ! mesh but are not the basis functions for the edge element approximation. 5528 ! Remark: Using reference elements having the edges of the same length 5529 ! simplifies the implementation of element assembly procedures. 5530 !----------------------------------------------------------------------- 5531 SELECT CASE(Element % TYPE % ElementCode / 100) 5532 CASE(2) 5533 IF (SecondOrder .AND. n==3) CALL Fatal('EdgeElementInfo', & 5534 'The lowest-order background mesh needed for trace evaluation over an edge') 5535 IF (Create2ndKindBasis) CALL Fatal('EdgeElementInfo', & 5536 'Traces of 2-D edge elements (the 2nd family) have not been implemented yet') 5537 IF (SecondOrder) THEN 5538 DOFs = 2 5539 ELSE 5540 DOFs = 1 5541 END IF 5542 DO q=1,2 5543 Basis(q) = LineNodalPBasis(q, u) 5544 dLBasisdx(q,1) = dLineNodalPBasis(q, u) 5545 END DO 5546 CASE(3) 5547 IF (SecondOrder) THEN 5548 ! DOFs is the number of H(curl)-conforming basis functions: 5549 DOFs = 8 5550 IF (n == 6) THEN 5551 ! Here the element of the background mesh is of type 306. 5552 ! The Lagrange interpolation basis on the p-approximation reference element: 5553 Basis(1) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v))/6.0d0 5554 dLBasisdx(1,1) = -0.5d0 + u + v/Sqrt(3.0d0) 5555 dLBasisdx(1,2) = (-Sqrt(3.0d0) + 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0 5556 Basis(2) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(3.0d0 - 2.0d0*Sqrt(3.0d0)*v))/6.0d0 5557 dLBasisdx(2,1) = 0.5d0 + u - v/Sqrt(3.d0) 5558 dLBasisdx(2,2) = (-Sqrt(3.0d0) - 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0 5559 Basis(3) = (v*(-Sqrt(3.0d0) + 2.0d0*v))/3.0d0 5560 dLBasisdx(3,1) = 0.0d0 5561 dLBasisdx(3,2) = -(1.0d0/Sqrt(3.0d0)) + (4.0d0*v)/3.0d0 5562 Basis(4) = (3.0d0 - 3.0d0*u**2 - 2.0d0*Sqrt(3.0d0)*v + v**2)/3.0d0 5563 dLBasisdx(4,1) = -2.0d0*u 5564 dLBasisdx(4,2) = (-2.0d0*(Sqrt(3.0d0) - v))/3.0d0 5565 Basis(5) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - v)*v)/3.0d0 5566 dLBasisdx(5,1) = (2.0d0*v)/Sqrt(3.0d0) 5567 dLBasisdx(5,2) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 2.0d0*v))/3.0d0 5568 Basis(6) = (-2.0d0*v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v))/3.0d0 5569 dLBasisdx(6,1) = (-2.0d0*v)/Sqrt(3.0d0) 5570 dLBasisdx(6,2) = (-2.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 2.0d0*v))/3.0d0 5571 ELSE 5572 ! Here the element of the background mesh is of type 303: 5573 DO q=1,3 5574 Basis(q) = TriangleNodalPBasis(q, u, v) 5575 dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 5576 END DO 5577 END IF 5578 ELSE 5579 DO q=1,n 5580 Basis(q) = TriangleNodalPBasis(q, u, v) 5581 dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 5582 END DO 5583 IF (Create2ndKindBasis) THEN 5584 DOFs = 6 5585 ELSE 5586 DOFs = 3 5587 END IF 5588 END IF 5589 CASE(4) 5590 IF (SecondOrder) THEN 5591 ! The second-order quad from the Nedelec's first family: affine physical elements may be needed 5592 DOFs = 12 5593 ELSE 5594 ! The lowest-order quad from the optimal family (ABF_0) 5595 DOFs = 6 5596 END IF 5597 IF (n>4) THEN 5598 ! Here the background mesh is supposed to be of type 408/409 5599 CALL NodalBasisFunctions2D(Basis, Element, u, v) 5600 CALL NodalFirstDerivatives(n, dLBasisdx, Element, u, v, w) 5601 ELSE 5602 ! Here the background mesh is of type 404 5603 DO q=1,4 5604 Basis(q) = QuadNodalPBasis(q, u, v) 5605 dLBasisdx(q,1:2) = dQuadNodalPBasis(q, u, v) 5606 END DO 5607 END IF 5608 CASE(5) 5609 IF (SecondOrder) THEN 5610 DOFs = 20 5611 IF (n == 10) THEN 5612 ! Here the element of the background mesh is of type 510. 5613 ! The Lagrange interpolation basis on the p-approximation reference element: 5614 Basis(1) = (6.0d0*u**2 - 2.0d0*Sqrt(3.0d0)*v + 2.0d0*v**2 - Sqrt(6.0d0)*w + 2.0d0*Sqrt(2.0d0)*v*w + & 5615 w**2 + 2.0d0*u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/12.0d0 5616 dLBasisdx(1,1) = -0.5d0 + u + v/Sqrt(3.0d0) + w/Sqrt(6.0d0) 5617 dLBasisdx(1,2) = (-Sqrt(3.0d0) + 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v + Sqrt(2.0d0)*w)/6.0d0 5618 dLBasisdx(1,3) = (-Sqrt(6.0d0) + 2.0d0*Sqrt(6.0d0)*u + 2.0d0*Sqrt(2.0d0)*v + 2.0d0*w)/12.0d0 5619 Basis(2) = (6.0d0*u**2 - 2.0d0*Sqrt(3.0d0)*v + 2.0d0*v**2 - Sqrt(6.0d0)*w + 2.0d0*Sqrt(2.0d0)*v*w + & 5620 w**2 - 2.0d0*u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/12.0d0 5621 dLBasisdx(2,1) = 0.5d0 + u - v/Sqrt(3.0d0) - w/Sqrt(6.0d0) 5622 dLBasisdx(2,2) = (-Sqrt(3.0d0) - 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v + Sqrt(2.0d0)*w)/6.0d0 5623 dLBasisdx(2,3) = (-Sqrt(6.0d0) - 2.0d0*Sqrt(6.0d0)*u + 2.0d0*Sqrt(2.0d0)*v + 2.0d0*w)/12.0d0 5624 Basis(3) = (8.0d0*v**2 + w*(Sqrt(6.0d0) + w) - 4.0d0*v*(Sqrt(3.0d0) + Sqrt(2.0d0)*w))/12.0d0 5625 dLBasisdx(3,1) = 0.0d0 5626 dLBasisdx(3,2) = (-Sqrt(3.0d0) + 4.0d0*v - Sqrt(2.0d0)*w)/3.0d0 5627 dLBasisdx(3,3) = (Sqrt(6.0d0) - 4.0d0*Sqrt(2.0d0)*v + 2.0d0*w)/12.0d0 5628 Basis(4) = (w*(-Sqrt(6.0d0) + 3.0d0*w))/4.0d0 5629 dLBasisdx(4,1) = 0.0d0 5630 dLBasisdx(4,2) = 0.0d0 5631 dLBasisdx(4,3) = (-Sqrt(6.0d0) + 6.0d0*w)/4.0d0 5632 Basis(5) = (6.0d0 - 6.0d0*u**2 - 4.0d0*Sqrt(3.0d0)*v + 2.0d0*v**2 - 2.0d0*Sqrt(6.0d0)*w + & 5633 2.0d0*Sqrt(2.0d0)*v*w + w**2)/6.0d0 5634 dLBasisdx(5,1) = -2.0d0*u 5635 dLBasisdx(5,2) = (-2.0d0*Sqrt(3.0d0) + 2.0d0*v + Sqrt(2.0d0)*w)/3.0d0 5636 dLBasisdx(5,3) = (-Sqrt(6.0d0) + Sqrt(2.0d0)*v + w)/3.0d0 5637 Basis(6) = (-4.0d0*v**2 + w*(-Sqrt(6.0d0) - Sqrt(6.0d0)*u + w) + v*(4.0d0*Sqrt(3.0d0) + & 5638 4.0d0*Sqrt(3.0d0)*u - Sqrt(2.0d0)*w))/6.0d0 5639 dLBasisdx(6,1) = (2.0d0*v)/Sqrt(3.0d0) - w/Sqrt(6.0d0) 5640 dLBasisdx(6,2) = (4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 8.0d0*v - Sqrt(2.0d0)*w)/6.0d0 5641 dLBasisdx(6,3) = (-Sqrt(6.0d0) - Sqrt(6.0d0)*u - Sqrt(2.0d0)*v + 2.0d0*w)/6.0d0 5642 Basis(7) = (-4.0d0*v**2 + w*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + w) - & 5643 v*(-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + Sqrt(2.0d0)*w))/6.0d0 5644 dLBasisdx(7,1) = (-2.0d0*v)/Sqrt(3.0d0) + w/Sqrt(6.0d0) 5645 dLBasisdx(7,2) = (4.0d0*Sqrt(3.0d0) - 4.0d0*Sqrt(3.0d0)*u - 8.0d0*v - Sqrt(2.0d0)*w)/6.0d0 5646 dLBasisdx(7,3) = (-Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v + 2.0d0*w)/6.0d0 5647 Basis(8) = -(w*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + w))/2.0d0 5648 dLBasisdx(8,1) = -(Sqrt(1.5d0)*w) 5649 dLBasisdx(8,2) = -(w/Sqrt(2.0d0)) 5650 dLBasisdx(8,3) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 2.0d0*w)/2.0d0 5651 Basis(9) = ((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - w)*w)/2.0d0 5652 dLBasisdx(9,1) = Sqrt(1.5d0)*w 5653 dLBasisdx(9,2) = -(w/Sqrt(2.0d0)) 5654 dLBasisdx(9,3) = (Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 2.0d0*w)/2.0d0 5655 Basis(10) = Sqrt(2.0d0)*v*w - w**2/2.0d0 5656 dLBasisdx(10,1) = 0.0d0 5657 dLBasisdx(10,2) = Sqrt(2.0d0)*w 5658 dLBasisdx(10,3) = Sqrt(2.0d0)*v - w 5659 ELSE 5660 ! Here the element of the background mesh is of type 504: 5661 DO q=1,4 5662 Basis(q) = TetraNodalPBasis(q, u, v, w) 5663 dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w) 5664 END DO 5665 END IF 5666 ELSE 5667 DO q=1,n 5668 Basis(q) = TetraNodalPBasis(q, u, v, w) 5669 dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w) 5670 END DO 5671 IF (Create2ndKindBasis) THEN 5672 DOFs = 12 5673 ELSE 5674 DOFs = 6 5675 END IF 5676 END IF 5677 CASE(6) 5678 IF (SecondOrder) THEN 5679 ! The second-order pyramid from the Nedelec's first family 5680 DOFs = 31 5681 ELSE 5682 ! The lowest-order pyramid from the optimal family 5683 DOFs = 10 5684 END IF 5685 5686 IF (n==13) THEN 5687 ! Here the background mesh is supposed to be of type 613. The difference between the standard 5688 ! reference element and the p-reference element can be taken into account by a simple scaling: 5689 CALL NodalBasisFunctions3D(Basis, Element, u, v, sqrt(2.0d0)*w) 5690 CALL NodalFirstDerivatives(n, dLBasisdx, Element, u, v, sqrt(2.0d0)*w) 5691 dLBasisdx(1:n,3) = sqrt(2.0d0) * dLBasisdx(1:n,3) 5692 ELSE 5693 ! Background mesh elements of the type 605: 5694 DO q=1,n 5695 Basis(q) = PyramidNodalPBasis(q, u, v, w) 5696 dLBasisdx(q,1:3) = dPyramidNodalPBasis(q, u, v, w) 5697 END DO 5698 END IF 5699 5700 CASE(7) 5701 IF (SecondOrder) THEN 5702 ! The second-order prism from the Nedelec's first family: affine physical elements may be needed 5703 DOFs = 36 5704 ELSE 5705 ! The lowest-order prism from the optimal family 5706 DOFs = 15 5707 END IF 5708 5709 IF (n==15) THEN 5710 ! Here the background mesh is of type 715. 5711 ! The Lagrange interpolation basis on the p-approximation reference element: 5712 5713 h1 = -0.5d0*w + 0.5d0*w**2 5714 h2 = 0.5d0*w + 0.5d0*w**2 5715 h3 = 1.0d0 - w**2 5716 dh1 = -0.5d0 + w 5717 dh2 = 0.5d0 + w 5718 dh3 = -2.0d0 * w 5719 5720 WorkBasis(1,1) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v))/6 5721 grad(1) = -0.5d0 + u + v/Sqrt(3.0d0) 5722 grad(2) = (-Sqrt(3.0d0) + 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0 5723 Basis(1) = WorkBasis(1,1) * h1 5724 dLBasisdx(1,1:2) = grad(1:2) * h1 5725 dLBasisdx(1,3) = WorkBasis(1,1) * dh1 5726 Basis(4) = WorkBasis(1,1) * h2 5727 dLBasisdx(4,1:2) = grad(1:2) * h2 5728 dLBasisdx(4,3) = WorkBasis(1,1) * dh2 5729 Basis(13) = WorkBasis(1,1) * h3 5730 dLBasisdx(13,1:2) = grad(1:2) * h3 5731 dLBasisdx(13,3) = WorkBasis(1,1) * dh3 5732 5733 WorkBasis(1,1) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(3.0d0 - 2.0d0*Sqrt(3.0d0)*v))/6.0d0 5734 grad(1) = 0.5d0 + u - v/Sqrt(3.d0) 5735 grad(2) = (-Sqrt(3.0d0) - 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0 5736 Basis(2) = WorkBasis(1,1) * h1 5737 dLBasisdx(2,1:2) = grad(1:2) * h1 5738 dLBasisdx(2,3) = WorkBasis(1,1) * dh1 5739 Basis(5) = WorkBasis(1,1) * h2 5740 dLBasisdx(5,1:2) = grad(1:2) * h2 5741 dLBasisdx(5,3) = WorkBasis(1,1) * dh2 5742 Basis(14) = WorkBasis(1,1) * h3 5743 dLBasisdx(14,1:2) = grad(1:2) * h3 5744 dLBasisdx(14,3) = WorkBasis(1,1) * dh3 5745 5746 WorkBasis(1,1) = (v*(-Sqrt(3.0d0) + 2.0d0*v))/3.0d0 5747 grad(1) = 0.0d0 5748 grad(2) = -(1.0d0/Sqrt(3.0d0)) + (4.0d0*v)/3.0d0 5749 Basis(3) = WorkBasis(1,1) * h1 5750 dLBasisdx(3,1:2) = grad(1:2) * h1 5751 dLBasisdx(3,3) = WorkBasis(1,1) * dh1 5752 Basis(6) = WorkBasis(1,1) * h2 5753 dLBasisdx(6,1:2) = grad(1:2) * h2 5754 dLBasisdx(6,3) = WorkBasis(1,1) * dh2 5755 Basis(15) = WorkBasis(1,1) * h3 5756 dLBasisdx(15,1:2) = grad(1:2) * h3 5757 dLBasisdx(15,3) = WorkBasis(1,1) * dh3 5758 5759 h1 = 0.5d0 * (1.0d0 - w) 5760 dh1 = -0.5d0 5761 h2 = 0.5d0 * (1.0d0 + w) 5762 dh2 = 0.5d0 5763 5764 WorkBasis(1,1) = (3.0d0 - 3.0d0*u**2 - 2.0d0*Sqrt(3.0d0)*v + v**2)/3.0d0 5765 grad(1) = -2.0d0*u 5766 grad(2) = (-2.0d0*(Sqrt(3.0d0) - v))/3.0d0 5767 Basis(7) = WorkBasis(1,1) * h1 5768 dLBasisdx(7,1:2) = grad(1:2) * h1 5769 dLBasisdx(7,3) = WorkBasis(1,1) * dh1 5770 Basis(10) = WorkBasis(1,1) * h2 5771 dLBasisdx(10,1:2) = grad(1:2) * h2 5772 dLBasisdx(10,3) = WorkBasis(1,1) * dh2 5773 5774 WorkBasis(1,1) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - v)*v)/3.0d0 5775 grad(1) = (2.0d0*v)/Sqrt(3.0d0) 5776 grad(2) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 2.0d0*v))/3.0d0 5777 Basis(8) = WorkBasis(1,1) * h1 5778 dLBasisdx(8,1:2) = grad(1:2) * h1 5779 dLBasisdx(8,3) = WorkBasis(1,1) * dh1 5780 Basis(11) = WorkBasis(1,1) * h2 5781 dLBasisdx(11,1:2) = grad(1:2) * h2 5782 dLBasisdx(11,3) = WorkBasis(1,1) * dh2 5783 5784 WorkBasis(1,1) = (-2.0d0*v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v))/3.0d0 5785 grad(1) = (-2.0d0*v)/Sqrt(3.0d0) 5786 grad(2) = (-2.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 2.0d0*v))/3.0d0 5787 Basis(9) = WorkBasis(1,1) * h1 5788 dLBasisdx(9,1:2) = grad(1:2) * h1 5789 dLBasisdx(9,3) = WorkBasis(1,1) * dh1 5790 Basis(12) = WorkBasis(1,1) * h2 5791 dLBasisdx(12,1:2) = grad(1:2) * h2 5792 dLBasisdx(12,3) = WorkBasis(1,1) * dh2 5793 ELSE 5794 ! Here the background mesh is of type 706 5795 DO q=1,n 5796 Basis(q) = WedgeNodalPBasis(q, u, v, w) 5797 dLBasisdx(q,1:3) = dWedgeNodalPBasis(q, u, v, w) 5798 END DO 5799 END IF 5800 CASE(8) 5801 IF (SecondOrder) THEN 5802 ! The second-order brick from the Nedelec's first family: affine physical elements may be needed 5803 DOFs = 54 5804 ELSE 5805 ! The lowest-order brick from the optimal family 5806 DOFs = 27 5807 END IF 5808 IF (n>8) THEN 5809 ! Here the background mesh is supposed to be of type 820/827 5810 CALL NodalBasisFunctions3D(Basis, Element, u, v, w) 5811 CALL NodalFirstDerivatives(n, dLBasisdx, Element, u, v, w) 5812 ELSE 5813 ! Here the background mesh is of type 808 5814 DO q=1,n 5815 Basis(q) = BrickNodalPBasis(q, u, v, w) 5816 dLBasisdx(q,1:3) = dBrickNodalPBasis(q, u, v, w) 5817 END DO 5818 END IF 5819 CASE DEFAULT 5820 CALL Fatal('ElementDescription::EdgeElementInfo','Unsupported element type') 5821 END SELECT 5822 5823 !----------------------------------------------------------------------- 5824 ! Get data for performing the Piola transformation... 5825 !----------------------------------------------------------------------- 5826 stat = PiolaTransformationData(n, Element, Nodes, LF, detF, dLBasisdx) 5827 !------------------------------------------------------------------------ 5828 ! ... in order to define the basis for the element space X(K) via 5829 ! applying a version of the Piola transformation as 5830 ! X(K) = { B | B = F^{-T}(f^{-1}(x)) b(f^{-1}(x)) } 5831 ! with b giving the edge basis function on the reference element k, 5832 ! f mapping k to the actual element K, i.e. K = f(k) and F = Grad f. This 5833 ! function returns the local basis functions b and their Curl (with respect 5834 ! to local coordinates) evaluated at the integration point. The effect of 5835 ! the Piola transformation need to be considered when integrating, so we 5836 ! shall return also the values of F, G=F^{-T} and det F. 5837 ! 5838 ! It should be noted that the case of 2-D surface elements embedded in 5839 ! the three-dimensional space is handled as a special case. Then F^{-T} 5840 ! is replaced by the transpose of the pseudoinverse of F. The Piola 5841 ! transformation then maps a 2-component field to a 3-component vector 5842 ! field which is tangential to the 2-D surface. 5843 ! 5844 ! The construction of edge element bases could be done in an alternate way for 5845 ! triangles and tetrahedra, while the chosen approach has the benefit that 5846 ! it generalizes to other cases. For example general quadrilaterals may now 5847 ! be handled in the same way. 5848 !--------------------------------------------------------------------------- 5849 IF (cdim == dim) THEN 5850 SELECT CASE(Element % TYPE % ElementCode / 100) 5851 CASE(3,4) 5852 LG(1,1) = 1.0d0/detF * LF(2,2) 5853 LG(1,2) = -1.0d0/detF * LF(1,2) 5854 LG(2,1) = -1.0d0/detF * LF(2,1) 5855 LG(2,2) = 1.0d0/detF * LF(1,1) 5856 CASE(5,6,7,8) 5857 CALL InvertMatrix3x3(LF,LG,detF) 5858 CASE DEFAULT 5859 CALL Fatal('ElementDescription::EdgeElementInfo','Unsupported element type') 5860 END SELECT 5861 LG(1:dim,1:dim) = TRANSPOSE( LG(1:dim,1:dim) ) 5862 END IF 5863 5864 IF (UsePretabulatedBasis) THEN 5865 DO i=1,DOFs 5866 EdgeBasis(i,1:3) = ReadyEdgeBasis(i,1:3) 5867 CurlBasis(i,1:3) = ReadyRotBasis(i,1:3) 5868 END DO 5869 ELSE 5870 SELECT CASE(Element % TYPE % ElementCode / 100) 5871 CASE(2) 5872 !-------------------------------------------------------------- 5873 ! This is a special case to return the tangential components 5874 ! trace of 2D elements 5875 !-------------------------------------------------------------- 5876 ! 5877 ! The sign reversion of basis must be checked via the parent element: 5878 ! 5879 Parent => Element % BoundaryInfo % Left 5880 IF (.NOT. ASSOCIATED(Parent)) THEN 5881 Parent => Element % BoundaryInfo % Right 5882 END IF 5883 IF (.NOT. ASSOCIATED(Parent)) RETURN 5884 ! 5885 ! Identify the edge representing the element among the edges of 5886 ! the parent element: 5887 ! 5888 pElement => Element 5889 CALL PickActiveFace(Mesh, Parent, pElement, Face, ActiveFaceId) 5890 IF (ActiveFaceId == 0) RETURN 5891 ! 5892 ! Use the parent element to check whether sign reversions are needed: 5893 ! 5894 CALL FaceElementOrientation(Parent, RevertSign, ActiveFaceId) 5895 5896 IF (RevertSign(ActiveFaceId)) THEN 5897 EdgeBasis(1,1) = -0.5d0 5898 ELSE 5899 EdgeBasis(1,1) = 0.5d0 5900 END IF 5901 IF (SecondOrder) THEN 5902 EdgeBasis(2,1) = 1.5d0 * u 5903 END IF 5904 CurlBasis(1:DOFs,:) = 0.0d0 5905 5906 CASE(3) 5907 !-------------------------------------------------------------- 5908 ! This branch is for handling triangles. Note that 5909 ! the global orientation of the edge tangent t is defined such that 5910 ! t points towards the node that has a larger global index. 5911 !-------------------------------------------------------------- 5912 EdgeMap => GetEdgeMap(3) 5913 !EdgeMap => GetEdgeMap(GetElementFamily(Element)) 5914 5915 IF (Create2ndKindBasis) THEN 5916 !------------------------------------------------- 5917 ! Two basis functions defined on the edge 12. 5918 !------------------------------------------------- 5919 i = EdgeMap(1,1) 5920 j = EdgeMap(1,2) 5921 ni = Element % NodeIndexes(i) 5922 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 5923 nj = Element % NodeIndexes(j) 5924 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 5925 IF (nj<ni) THEN 5926 ! The sign and order of basis functions are reverted as 5927 ! compared with the other possibility 5928 EdgeBasis(1,1) = -(3.0d0 + 3.0d0*Sqrt(3.0d0)*u - Sqrt(3.0d0)*v)/6.0d0 5929 EdgeBasis(1,2) = -(3.0d0 + Sqrt(3.0d0)*u - Sqrt(3.0d0)*v)/6.0d0 5930 CurlBasis(1,3) = -1.0d0/Sqrt(3.0d0) 5931 5932 EdgeBasis(2,1) = -(3.0d0 + Sqrt(3.0d0) - 3.0d0*(1.0d0 + Sqrt(3.0d0))*u - & 5933 (1.0d0 + Sqrt(3.0d0))*v)/(2.0d0*(3.0d0 + Sqrt(3.0d0))) 5934 EdgeBasis(2,2) = -(-3.0d0 - Sqrt(3.0d0) + u + Sqrt(3.0d0)*u + v + Sqrt(3.0d0)*v)/ & 5935 (2.0d0*(3.0d0 + Sqrt(3.0d0))) 5936 CurlBasis(2,3) = -1.0d0/Sqrt(3.0d0) 5937 ELSE 5938 EdgeBasis(1,1) = (3.0d0 + Sqrt(3.0d0) - 3.0d0*(1.0d0 + Sqrt(3.0d0))*u - & 5939 (1.0d0 + Sqrt(3.0d0))*v)/(2.0d0*(3.0d0 + Sqrt(3.0d0))) 5940 EdgeBasis(1,2) = (-3.0d0 - Sqrt(3.0d0) + u + Sqrt(3.0d0)*u + v + Sqrt(3.0d0)*v)/ & 5941 (2.0d0*(3.0d0 + Sqrt(3.0d0))) 5942 CurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) 5943 5944 EdgeBasis(2,1) = (3.0d0 + 3.0d0*Sqrt(3.0d0)*u - Sqrt(3.0d0)*v)/6.0d0 5945 EdgeBasis(2,2) = (3.0d0 + Sqrt(3.0d0)*u - Sqrt(3.0d0)*v)/6.0d0 5946 CurlBasis(2,3) = 1.0d0/Sqrt(3.0d0) 5947 END IF 5948 5949 !------------------------------------------------- 5950 ! Two basis functions defined on the edge 23. 5951 !------------------------------------------------- 5952 i = EdgeMap(2,1) 5953 j = EdgeMap(2,2) 5954 ni = Element % NodeIndexes(i) 5955 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 5956 nj = Element % NodeIndexes(j) 5957 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 5958 IF (nj<ni) THEN 5959 ! The sign and order of basis functions are reverted as 5960 ! compared with the other possibility 5961 EdgeBasis(3,1) = ((3.0d0 + Sqrt(3.0d0))*v)/6.0d0 5962 EdgeBasis(3,2) = -(-3.0d0 + Sqrt(3.0d0) + (-3.0d0 + Sqrt(3.0d0))*u + 2.0d0*Sqrt(3.0d0)*v)/6.0d0 5963 CurlBasis(3,3) = -1.0d0/Sqrt(3.0d0) 5964 5965 EdgeBasis(4,1) = ((-3.0d0 + Sqrt(3.0d0))*v)/6.0d0 5966 EdgeBasis(4,2) = -(2.0d0 + Sqrt(3.0d0) + (2.0d0 + Sqrt(3.0d0))*u - & 5967 (1.0d0 + Sqrt(3.0d0))*v)/(3.0d0 + Sqrt(3.0d0)) 5968 CurlBasis(4,3) = -1.0d0/Sqrt(3.0d0) 5969 ELSE 5970 EdgeBasis(3,1) = -((-3.0d0 + Sqrt(3.0d0))*v)/6.0d0 5971 EdgeBasis(3,2) = (2.0d0 + Sqrt(3.0d0) + (2.0d0 + Sqrt(3.0d0))*u - & 5972 (1.0d0 + Sqrt(3.0d0))*v)/(3.0d0 + Sqrt(3.0d0)) 5973 CurlBasis(3,3) = 1.0d0/Sqrt(3.0d0) 5974 5975 EdgeBasis(4,1) = -((3.0d0 + Sqrt(3.0d0))*v)/6.0d0 5976 EdgeBasis(4,2) = (-3.0d0 + Sqrt(3.0d0) + (-3.0d0 + Sqrt(3.0d0))*u + 2.0d0*Sqrt(3.0d0)*v)/6.0d0 5977 CurlBasis(4,3) = 1.0d0/Sqrt(3.0d0) 5978 END IF 5979 5980 !------------------------------------------------- 5981 ! Two basis functions defined on the edge 31. 5982 !------------------------------------------------- 5983 i = EdgeMap(3,1) 5984 j = EdgeMap(3,2) 5985 ni = Element % NodeIndexes(i) 5986 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 5987 nj = Element % NodeIndexes(j) 5988 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 5989 IF (nj<ni) THEN 5990 ! The sign and order of basis functions are reverted as 5991 ! compared with the other possibility 5992 EdgeBasis(5,1) = ((-3.0d0 + Sqrt(3.0d0))*v)/6.0d0 5993 EdgeBasis(5,2) = -(-3.0d0 - Sqrt(3.0d0) + (3.0d0 + Sqrt(3.0d0))*u + 2.0d0*Sqrt(3.0d0)*v)/6.0d0 5994 CurlBasis(5,3) = -1.0d0/Sqrt(3.0d0) 5995 5996 EdgeBasis(6,1) = ((3.0d0 + 2.0d0*Sqrt(3.0d0))*v)/(3.0d0*(1.0d0 + Sqrt(3.0d0))) 5997 EdgeBasis(6,2) = ((-1.0d0 + u + v + Sqrt(3.0d0)*v)/(3.0d0 + Sqrt(3.0d0))) 5998 CurlBasis(6,3) = -1.0d0/Sqrt(3.0d0) 5999 ELSE 6000 EdgeBasis(5,1) = -((3.0d0 + 2.0d0*Sqrt(3.0d0))*v)/(3.0d0*(1.0d0 + Sqrt(3.0d0))) 6001 EdgeBasis(5,2) = -((-1.0d0 + u + v + Sqrt(3.0d0)*v)/(3.0d0 + Sqrt(3.0d0))) 6002 CurlBasis(5,3) = 1.0d0/Sqrt(3.0d0) 6003 6004 EdgeBasis(6,1) = -((-3.0d0 + Sqrt(3.0d0))*v)/6.0d0 6005 EdgeBasis(6,2) = (-3.0d0 - Sqrt(3.0d0) + (3.0d0 + Sqrt(3.0d0))*u + 2.0d0*Sqrt(3.0d0)*v)/6.0d0 6006 CurlBasis(6,3) = 1.0d0/Sqrt(3.0d0) 6007 END IF 6008 6009 ELSE 6010 6011 !------------------------------------------------------------ 6012 ! The optimal/Nedelec basis functions of the first kind. We employ 6013 ! a hierarchic basis, so the lowest-order basis functions are 6014 ! also utilized in the construction of the second-order basis. 6015 ! First the edge 12 ... 6016 !------------------------------------------------------------ 6017 i = EdgeMap(1,1) 6018 j = EdgeMap(1,2) 6019 ni = Element % NodeIndexes(i) 6020 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6021 nj = Element % NodeIndexes(j) 6022 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6023 EdgeBasis(1,1) = (3.0d0 - Sqrt(3.0d0)*v)/6.0d0 6024 EdgeBasis(1,2) = u/(2.0d0*Sqrt(3.0d0)) 6025 CurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) 6026 IF (nj<ni) THEN 6027 EdgeBasis(1,:) = -EdgeBasis(1,:) 6028 CurlBasis(1,3) = -CurlBasis(1,3) 6029 END IF 6030 IF (SecondOrder) THEN 6031 EdgeBasis(2,1) = -(u*(-3.0d0 + Sqrt(3.0d0)*v))/2.0d0 6032 EdgeBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0 6033 CurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0 6034 END IF 6035 6036 !------------------------------------------------- 6037 ! Basis functions associated with the edge 23: 6038 !------------------------------------------------- 6039 IF (SecondOrder) THEN 6040 k = 3 6041 EdgeBasis(4,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*v)/4.0d0 6042 EdgeBasis(4,2) = (Sqrt(3.0d0)*(1.0d0 + u)*(-1.0d0 - u + Sqrt(3.0d0)*v))/4.0d0 6043 CurlBasis(4,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0 6044 ELSE 6045 k = 2 6046 END IF 6047 i = EdgeMap(2,1) 6048 j = EdgeMap(2,2) 6049 ni = Element % NodeIndexes(i) 6050 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6051 nj = Element % NodeIndexes(j) 6052 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6053 EdgeBasis(k,1) = -v/(2.0d0*Sqrt(3.0d0)) 6054 EdgeBasis(k,2) = (1 + u)/(2.0d0*Sqrt(3.0d0)) 6055 CurlBasis(k,3) = 1.0d0/Sqrt(3.0d0) 6056 IF (nj<ni) THEN 6057 EdgeBasis(k,:) = -EdgeBasis(k,:) 6058 CurlBasis(k,3) = -CurlBasis(k,3) 6059 END IF 6060 6061 !------------------------------------------------- 6062 ! Basis functions associated with the edge 31: 6063 !------------------------------------------------- 6064 IF (SecondOrder) THEN 6065 k = 5 6066 EdgeBasis(6,1) = (v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 6067 EdgeBasis(6,2) = -(Sqrt(3.0d0)*(-1.0d0 + u)*(-1.0d0 + u + Sqrt(3.0d0)*v))/4.0d0 6068 CurlBasis(6,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 6069 ELSE 6070 k = 3 6071 END IF 6072 i = EdgeMap(3,1) 6073 j = EdgeMap(3,2) 6074 ni = Element % NodeIndexes(i) 6075 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6076 nj = Element % NodeIndexes(j) 6077 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6078 EdgeBasis(k,1) = -v/(2.0d0*Sqrt(3.0d0)) 6079 EdgeBasis(k,2) = (-1 + u)/(2.0d0*Sqrt(3.0d0)) 6080 CurlBasis(k,3) = 1.0d0/Sqrt(3.0d0) 6081 IF (nj<ni) THEN 6082 EdgeBasis(k,:) = -EdgeBasis(k,:) 6083 CurlBasis(k,3) = -CurlBasis(k,3) 6084 END IF 6085 6086 IF (SecondOrder) THEN 6087 !------------------------------------------------- 6088 ! Two basis functions defined on the face 123: 6089 !------------------------------------------------- 6090 TriangleFaceMap(:) = (/ 1,2,3 /) 6091 Ind => Element % Nodeindexes 6092 6093 DO j=1,3 6094 FaceIndices(j) = Ind(TriangleFaceMap(j)) 6095 END DO 6096 IF (Parallel) THEN 6097 DO j=1,3 6098 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6099 END DO 6100 END IF 6101 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 6102 6103 WorkBasis(1,1) = ((Sqrt(3.0d0) - v)*v)/6.0d0 6104 WorkBasis(1,2) = (u*v)/6.0d0 6105 WorkCurlBasis(1,3) = (-Sqrt(3.0d0) + 3.0d0*v)/6.0d0 6106 WorkBasis(2,1) = (v*(1.0d0 + u - v/Sqrt(3.0d0)))/(4.0d0*Sqrt(3.0d0)) 6107 WorkBasis(2,2) = ((-1.0d0 + u)*(-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) 6108 WorkCurlBasis(2,3) =(-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0 6109 WorkBasis(3,1) = (v*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) 6110 WorkBasis(3,2) = -((1.0d0 + u)*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) 6111 WorkCurlBasis(3,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0 6112 6113 EdgeBasis(7,:) = D1 * WorkBasis(I1,:) 6114 CurlBasis(7,3) = D1 * WorkCurlBasis(I1,3) 6115 EdgeBasis(8,:) = D2 * WorkBasis(I2,:) 6116 CurlBasis(8,3) = D2 * WorkCurlBasis(I2,3) 6117 6118 END IF 6119 END IF 6120 6121 CASE(4) 6122 !-------------------------------------------------------------- 6123 ! This branch is for handling quadrilaterals 6124 !-------------------------------------------------------------- 6125 EdgeMap => GetEdgeMap(4) 6126 IF (SecondOrder) THEN 6127 !--------------------------------------------------------------- 6128 ! The second-order element from the Nedelec's first family with 6129 ! a hierarchic basis. This element may not be optimally accurate 6130 ! if the physical element is not affine. 6131 ! First, the eight basis functions associated with the edges: 6132 !-------------------------------------------------------------- 6133 i = EdgeMap(1,1) 6134 j = EdgeMap(1,2) 6135 ni = Element % NodeIndexes(i) 6136 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6137 nj = Element % NodeIndexes(j) 6138 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6139 EdgeBasis(1,1) = 0.1D1 / 0.4D1 - v / 0.4D1 6140 CurlBasis(1,3) = 0.1D1 / 0.4D1 6141 IF (nj<ni) THEN 6142 EdgeBasis(1,:) = -EdgeBasis(1,:) 6143 CurlBasis(1,3) = -CurlBasis(1,3) 6144 END IF 6145 EdgeBasis(2,1) = 0.3D1 * u * (0.1D1 / 0.4D1 - v / 0.4D1) 6146 CurlBasis(2,3) = 0.3D1 / 0.4D1 * u 6147 6148 i = EdgeMap(2,1) 6149 j = EdgeMap(2,2) 6150 ni = Element % NodeIndexes(i) 6151 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6152 nj = Element % NodeIndexes(j) 6153 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6154 EdgeBasis(3,2) = 0.1D1 / 0.4D1 + u / 0.4D1 6155 CurlBasis(3,3) = 0.1D1 / 0.4D1 6156 IF (nj<ni) THEN 6157 EdgeBasis(3,:) = -EdgeBasis(3,:) 6158 CurlBasis(3,3) = -CurlBasis(3,3) 6159 END IF 6160 EdgeBasis(4,2) = 0.3D1 * v * (0.1D1 / 0.4D1 + u / 0.4D1) 6161 CurlBasis(4,3) = 0.3D1 / 0.4D1 * v 6162 6163 i = EdgeMap(3,1) 6164 j = EdgeMap(3,2) 6165 ni = Element % NodeIndexes(i) 6166 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6167 nj = Element % NodeIndexes(j) 6168 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6169 EdgeBasis(5,1) = -0.1D1 / 0.4D1 - v / 0.4D1 6170 CurlBasis(5,3) = 0.1D1 / 0.4D1 6171 IF (nj<ni) THEN 6172 EdgeBasis(5,:) = -EdgeBasis(5,:) 6173 CurlBasis(5,3) = -CurlBasis(5,3) 6174 END IF 6175 EdgeBasis(6,1) = -0.3D1 * u * (-0.1D1 / 0.4D1 - v / 0.4D1) 6176 CurlBasis(6,3) = -0.3D1 / 0.4D1 * u 6177 6178 i = EdgeMap(4,1) 6179 j = EdgeMap(4,2) 6180 ni = Element % NodeIndexes(i) 6181 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6182 nj = Element % NodeIndexes(j) 6183 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6184 EdgeBasis(7,2) = -0.1D1 / 0.4D1 + u / 0.4D1 6185 CurlBasis(7,3) = 0.1D1 / 0.4D1 6186 IF (nj<ni) THEN 6187 EdgeBasis(7,:) = -EdgeBasis(7,:) 6188 CurlBasis(7,3) = -CurlBasis(7,3) 6189 END IF 6190 EdgeBasis(8,2) = -0.3D1 * v * (-0.1D1 / 0.4D1 + u / 0.4D1) 6191 CurlBasis(8,3) = -0.3D1 / 0.4D1 * v 6192 6193 !-------------------------------------------------------------------- 6194 ! Additional four basis functions associated with the element interior 6195 !------------------------------------------------------------------- 6196 SquareFaceMap(:) = (/ 1,2,3,4 /) 6197 Ind => Element % Nodeindexes 6198 6199 WorkBasis = 0.0d0 6200 WorkCurlBasis = 0.0d0 6201 6202 WorkBasis(1,1) = 0.2D1 * (0.1D1 / 0.2D1 - v / 0.2D1) * (0.1D1 / 0.2D1 + v / 0.2D1) 6203 WorkCurlBasis(1,3) = v 6204 WorkBasis(2,1) = 0.12D2 * u * (0.1D1 / 0.2D1 - v / 0.2D1) * (0.1D1 / 0.2D1 + v / 0.2D1) 6205 WorkCurlBasis(2,3) = 0.6D1 * u * (0.1D1 / 0.2D1 + v / 0.2D1) - & 6206 0.6D1 * u * (0.1D1 / 0.2D1 - v / 0.2D1) 6207 6208 WorkBasis(3,2) = 0.2D1 * (0.1D1 / 0.2D1 - u / 0.2D1) * (0.1D1 / 0.2D1 + u / 0.2D1) 6209 WorkCurlBasis(3,3) = -u 6210 WorkBasis(4,2) = 0.12D2 * v * (0.1D1 / 0.2D1 - u / 0.2D1) * (0.1D1 / 0.2D1 + u / 0.2D1) 6211 WorkCurlBasis(4,3) = -0.6D1 * v * (0.1D1 / 0.2D1 + u / 0.2D1) + & 6212 0.6D1 * v * (0.1D1 / 0.2D1 - u / 0.2D1) 6213 6214 DO j=1,4 6215 FaceIndices(j) = Ind(SquareFaceMap(j)) 6216 END DO 6217 IF (Parallel) THEN 6218 DO j=1,4 6219 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6220 END DO 6221 END IF 6222 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 6223 6224 EdgeBasis(9,:) = D1 * WorkBasis(2*(I1-1)+1,:) 6225 CurlBasis(9,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 6226 EdgeBasis(10,:) = WorkBasis(2*(I1-1)+2,:) 6227 CurlBasis(10,:) = WorkCurlBasis(2*(I1-1)+2,:) 6228 EdgeBasis(11,:) = D2 * WorkBasis(2*(I2-1)+1,:) 6229 CurlBasis(11,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 6230 EdgeBasis(12,:) = WorkBasis(2*(I2-1)+2,:) 6231 CurlBasis(12,:) = WorkCurlBasis(2*(I2-1)+2,:) 6232 6233 ELSE 6234 !------------------------------------------------------ 6235 ! The Arnold-Boffi-Falk element of degree k=0 which is 6236 ! a member of the optimal edge element family. 6237 ! First, four basis functions defined on the edges 6238 !------------------------------------------------- 6239 i = EdgeMap(1,1) 6240 j = EdgeMap(1,2) 6241 ni = Element % NodeIndexes(i) 6242 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6243 nj = Element % NodeIndexes(j) 6244 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6245 EdgeBasis(1,1) = ((-1.0d0 + v)*v)/4.0d0 6246 EdgeBasis(1,2) = 0.0d0 6247 CurlBasis(1,3) = (1.0d0 - 2*v)/4.0d0 6248 IF (nj<ni) THEN 6249 EdgeBasis(1,:) = -EdgeBasis(1,:) 6250 CurlBasis(1,3) = -CurlBasis(1,3) 6251 END IF 6252 6253 i = EdgeMap(2,1) 6254 j = EdgeMap(2,2) 6255 ni = Element % NodeIndexes(i) 6256 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6257 nj = Element % NodeIndexes(j) 6258 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6259 EdgeBasis(2,1) = 0.0d0 6260 EdgeBasis(2,2) = (u*(1.0d0 + u))/4.0d0 6261 CurlBasis(2,3) = (1.0d0 + 2*u)/4.0d0 6262 IF (nj<ni) THEN 6263 EdgeBasis(2,:) = -EdgeBasis(2,:) 6264 CurlBasis(2,3) = -CurlBasis(2,3) 6265 END IF 6266 6267 i = EdgeMap(3,1) 6268 j = EdgeMap(3,2) 6269 ni = Element % NodeIndexes(i) 6270 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6271 nj = Element % NodeIndexes(j) 6272 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6273 EdgeBasis(3,1) = -(v*(1.0d0 + v))/4.0d0 6274 EdgeBasis(3,2) = 0.0d0 6275 CurlBasis(3,3) = (1.0d0 + 2*v)/4.0d0 6276 IF (nj<ni) THEN 6277 EdgeBasis(3,:) = -EdgeBasis(3,:) 6278 CurlBasis(3,3) = -CurlBasis(3,3) 6279 END IF 6280 6281 i = EdgeMap(4,1) 6282 j = EdgeMap(4,2) 6283 ni = Element % NodeIndexes(i) 6284 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6285 nj = Element % NodeIndexes(j) 6286 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6287 EdgeBasis(4,1) = 0.0d0 6288 EdgeBasis(4,2) = -((-1 + u)*u)/4.0d0 6289 CurlBasis(4,3) = (1.0d0 - 2*u)/4.0d0 6290 IF (nj<ni) THEN 6291 EdgeBasis(4,:) = -EdgeBasis(4,:) 6292 CurlBasis(4,3) = -CurlBasis(4,3) 6293 END IF 6294 6295 !-------------------------------------------------------------------- 6296 ! Additional two basis functions associated with the element interior 6297 !------------------------------------------------------------------- 6298 SquareFaceMap(:) = (/ 1,2,3,4 /) 6299 Ind => Element % Nodeindexes 6300 6301 WorkBasis(1,:) = 0.0d0 6302 WorkBasis(2,:) = 0.0d0 6303 WorkCurlBasis(1,:) = 0.0d0 6304 WorkCurlBasis(2,:) = 0.0d0 6305 6306 WorkBasis(1,1) = (1.0d0 - v**2)/2.0d0 6307 WorkBasis(1,2) = 0.0d0 6308 WorkCurlBasis(1,3) = v 6309 6310 WorkBasis(2,1) = 0.0d0 6311 WorkBasis(2,2) = (1.0d0 - u**2)/2.0d0 6312 WorkCurlBasis(2,3) = -u 6313 6314 DO j=1,4 6315 FaceIndices(j) = Ind(SquareFaceMap(j)) 6316 END DO 6317 IF (Parallel) THEN 6318 DO j=1,4 6319 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6320 END DO 6321 END IF 6322 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 6323 6324 EdgeBasis(5,:) = D1 * WorkBasis(I1,:) 6325 CurlBasis(5,:) = D1 * WorkCurlBasis(I1,:) 6326 EdgeBasis(6,:) = D2 * WorkBasis(I2,:) 6327 CurlBasis(6,:) = D2 * WorkCurlBasis(I2,:) 6328 END IF 6329 6330 CASE(5) 6331 !-------------------------------------------------------------- 6332 ! This branch is for handling tetrahedra 6333 !-------------------------------------------------------------- 6334 EdgeMap => GetEdgeMap(5) 6335 6336 IF (Create2ndKindBasis) THEN 6337 !------------------------------------------------- 6338 ! Two basis functions defined on the edge 12. 6339 !------------------------------------------------- 6340 i = EdgeMap(1,1) 6341 j = EdgeMap(1,2) 6342 ni = Element % NodeIndexes(i) 6343 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6344 nj = Element % NodeIndexes(j) 6345 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6346 IF (nj<ni) THEN 6347 ! The sign and order of basis functions are reverted as 6348 ! compared with the other possibility 6349 EdgeBasis(1,1) = -(6.0d0 + 6.0d0*Sqrt(3.0d0)*u - 2.0d0*Sqrt(3.0d0)*v - Sqrt(6.0d0)*w)/12.0d0 6350 EdgeBasis(1,2) = -(6.0d0 + 2.0d0*Sqrt(3.0d0)*u - 2.0d0*Sqrt(3.0d0)*v - Sqrt(6.0d0)*w)/12.0d0 6351 EdgeBasis(1,3) = -(3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0)*u - Sqrt(6.0d0)*v - Sqrt(3.0d0)*w)/12.0d0 6352 CurlBasis(1,1) = 0.0d0 6353 CurlBasis(1,2) = 1.0d0/Sqrt(6.0d0) 6354 CurlBasis(1,3) = -1.0d0/Sqrt(3.0d0) 6355 6356 EdgeBasis(2,1) = (-6.0d0 - 2.0d0*Sqrt(3.0d0) + 6.0d0*(1.0d0 + Sqrt(3.0d0))*u + & 6357 2.0d0*(1.0d0 + Sqrt(3.0d0))*v + Sqrt(2.0d0)*w + Sqrt(6.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6358 EdgeBasis(2,2) = -(-6.0d0 - 2.0d0*Sqrt(3.0d0) + 2.0d0*(1.0d0 + Sqrt(3.0d0))*u + & 6359 2.0d0*(1.0d0 + Sqrt(3.0d0))*v + Sqrt(2.0d0)*w + Sqrt(6.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6360 EdgeBasis(2,3) = -(-3.0d0*Sqrt(2.0d0) - Sqrt(6.0d0) + (Sqrt(2.0d0) + Sqrt(6.0d0))*u + & 6361 (Sqrt(2.0d0) + Sqrt(6.0d0))*v + w + Sqrt(3.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6362 CurlBasis(2,1) = 0.0d0 6363 CurlBasis(2,2) = (Sqrt(2.0d0) + Sqrt(6.0d0))/(6.0d0 + 2.0d0*Sqrt(3.0d0)) 6364 CurlBasis(2,3) = -1.0d0/Sqrt(3.0d0) 6365 ELSE 6366 EdgeBasis(1,1) = -(-6.0d0 - 2.0d0*Sqrt(3.0d0) + 6.0d0*(1.0d0 + Sqrt(3.0d0))*u + & 6367 2.0d0*(1.0d0 + Sqrt(3.0d0))*v + Sqrt(2.0d0)*w + Sqrt(6.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6368 EdgeBasis(1,2) = (-6.0d0 - 2.0d0*Sqrt(3.0d0) + 2.0d0*(1.0d0 + Sqrt(3.0d0))*u + & 6369 2.0d0*(1.0d0 + Sqrt(3.0d0))*v + Sqrt(2.0d0)*w + Sqrt(6.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6370 EdgeBasis(1,3) = (-3.0d0*Sqrt(2.0d0) - Sqrt(6.0d0) + (Sqrt(2.0d0) + Sqrt(6.0d0))*u + & 6371 (Sqrt(2.0d0) + Sqrt(6.0d0))*v + w + Sqrt(3.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6372 CurlBasis(1,1) = 0.0d0 6373 CurlBasis(1,2) = -((Sqrt(2.0d0) + Sqrt(6.0d0))/(6.0d0 + 2.0d0*Sqrt(3.0d0))) 6374 CurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) 6375 6376 EdgeBasis(2,1) = (6.0d0 + 6.0d0*Sqrt(3.0d0)*u - 2.0d0*Sqrt(3.0d0)*v - Sqrt(6.0d0)*w)/12.0d0 6377 EdgeBasis(2,2) = (6.0d0 + 2.0d0*Sqrt(3.0d0)*u - 2.0d0*Sqrt(3.0d0)*v - Sqrt(6.0d0)*w)/12.0d0 6378 EdgeBasis(2,3) = (3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0)*u - Sqrt(6.0d0)*v - Sqrt(3.0d0)*w)/12.0d0 6379 CurlBasis(2,1) = 0.0d0 6380 CurlBasis(2,2) = -1.0d0/Sqrt(6.0d0) 6381 CurlBasis(2,3) = 1.0d0/Sqrt(3.0d0) 6382 END IF 6383 6384 !------------------------------------------------- 6385 ! Two basis functions defined on the edge 23. 6386 !------------------------------------------------- 6387 i = EdgeMap(2,1) 6388 j = EdgeMap(2,2) 6389 ni = Element % NodeIndexes(i) 6390 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6391 nj = Element % NodeIndexes(j) 6392 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6393 IF (nj<ni) THEN 6394 ! The sign and order of basis functions are reverted as 6395 ! compared with the other possibility 6396 EdgeBasis(3,1) = (3.0d0 + Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w)/24.0d0 6397 EdgeBasis(3,2) = -(4.0d0*(-3.0d0 + Sqrt(3.0d0))*u + 8.0d0*Sqrt(3.0d0)*v + & 6398 (-3.0d0 + Sqrt(3.0d0))*(4.0d0 + Sqrt(2.0d0)*w))/24.0d0 6399 EdgeBasis(3,3) = -(3.0d0*Sqrt(2.0d0) - Sqrt(6.0d0) - Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*u + & 6400 Sqrt(2.0d0)*(3.0d0 + Sqrt(3.0d0))*v - 2.0d0*Sqrt(3.0d0)*w)/24.0d0 6401 CurlBasis(3,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6402 CurlBasis(3,2) = -1.0d0/(2.0d0*Sqrt(6.0d0)) 6403 CurlBasis(3,3) = -1.0d0/Sqrt(3.0d0) 6404 6405 EdgeBasis(4,1) = (-3.0d0 + Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w)/24.0d0 6406 EdgeBasis(4,2) = (-4.0d0*(2.0d0 + Sqrt(3.0d0))*u + 4.0d0*(1.0d0 + Sqrt(3.0d0))*v + & 6407 (2.0d0 + Sqrt(3.0d0))*(-4.0d0 + Sqrt(2.0d0)*w))/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6408 EdgeBasis(4,3) = -(-2.0d0*Sqrt(2.0d0) - Sqrt(6.0d0) - Sqrt(2.0d0)*(2.0d0 + Sqrt(3.0d0))*u + & 6409 Sqrt(2.0d0)*v + w + Sqrt(3.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6410 CurlBasis(4,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6411 CurlBasis(4,2) = -(Sqrt(2.0d0) + Sqrt(6.0d0))/(12.0d0 + 4.0d0*Sqrt(3.0d0)) 6412 CurlBasis(4,3) = -1.0d0/Sqrt(3.0d0) 6413 ELSE 6414 EdgeBasis(3,1) = -(-3.0d0 + Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w)/24.0d0 6415 EdgeBasis(3,2) = -(-4.0d0*(2.0d0 + Sqrt(3.0d0))*u + 4.0d0*(1.0d0 + Sqrt(3.0d0))*v + & 6416 (2.0d0 + Sqrt(3.0d0))*(-4.0d0 + Sqrt(2.0d0)*w))/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6417 EdgeBasis(3,3) = (-2.0d0*Sqrt(2.0d0) - Sqrt(6.0d0) - Sqrt(2.0d0)*(2.0d0 + Sqrt(3.0d0))*u + & 6418 Sqrt(2.0d0)*v + w + Sqrt(3.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6419 CurlBasis(3,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6420 CurlBasis(3,2) = (Sqrt(2.0d0) + Sqrt(6.0d0))/(12.0d0 + 4.0d0*Sqrt(3.0d0)) 6421 CurlBasis(3,3) = 1.0d0/Sqrt(3.0d0) 6422 6423 EdgeBasis(4,1) = -((3.0d0 + Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w))/24.0d0 6424 EdgeBasis(4,2) = (4.0d0*(-3.0d0 + Sqrt(3.0d0))*u + 8.0d0*Sqrt(3.0d0)*v + & 6425 (-3.0d0 + Sqrt(3.0d0))*(4.0d0 + Sqrt(2.0d0)*w))/24.0d0 6426 EdgeBasis(4,3) = (3.0d0*Sqrt(2.0d0) - Sqrt(6.0d0) - Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*u + & 6427 Sqrt(2.0d0)*(3.0d0 + Sqrt(3.0d0))*v - 2.0d0*Sqrt(3.0d0)*w)/24.0d0 6428 CurlBasis(4,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6429 CurlBasis(4,2) = 1.0d0/(2.0d0*Sqrt(6.0d0)) 6430 CurlBasis(4,3) = 1.0d0/Sqrt(3.0d0) 6431 END IF 6432 6433 !------------------------------------------------- 6434 ! Two basis functions defined on the edge 31. 6435 !------------------------------------------------- 6436 i = EdgeMap(3,1) 6437 j = EdgeMap(3,2) 6438 ni = Element % NodeIndexes(i) 6439 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6440 nj = Element % NodeIndexes(j) 6441 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6442 IF (nj<ni) THEN 6443 ! The sign and order of basis functions are reverted as 6444 ! compared with the other possibility 6445 EdgeBasis(5,1) = ((-3.0d0 + Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w))/24.0d0 6446 EdgeBasis(5,2) = -(4.0d0*(3.0d0 + Sqrt(3.0d0))*u + 8.0d0*Sqrt(3.0d0)*v + & 6447 (3.0d0 + Sqrt(3.0d0))*(-4.0d0 + Sqrt(2.0d0)*w))/24.0d0 6448 EdgeBasis(5,3) = -(3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0) - Sqrt(2.0d0)*(3.0d0 + Sqrt(3.0d0))*u + & 6449 Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*v - 2.0d0*Sqrt(3.0d0)*w)/24.0d0 6450 CurlBasis(5,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6451 CurlBasis(5,2) = -1.0d0/(2.0d0*Sqrt(6.0d0)) 6452 CurlBasis(5,3) = -1.0d0/Sqrt(3.0d0) 6453 6454 EdgeBasis(6,1) = ((3.0d0 + 2.0d0*Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w))/ & 6455 (12.0d0*(1.0d0 + Sqrt(3.0d0))) 6456 EdgeBasis(6,2) = -(4.0d0 - 4.0d0*u - 4.0d0*(1.0d0 + Sqrt(3.0d0))*v + Sqrt(2.0d0)*w)/ & 6457 (4.0d0*(3.0d0 + Sqrt(3.0d0))) 6458 EdgeBasis(6,3) = -(-Sqrt(2.0d0) + Sqrt(2.0d0)*u - Sqrt(2.0d0)*(2.0d0 + Sqrt(3.0d0))*v + & 6459 w + Sqrt(3.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6460 CurlBasis(6,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6461 CurlBasis(6,2) = -1.0d0/(2.0d0*Sqrt(6.0d0)) 6462 CurlBasis(6,3) = -1.0d0/Sqrt(3.0d0) 6463 ELSE 6464 EdgeBasis(5,1) = -((3.0d0 + 2.0d0*Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w))/ & 6465 (12.0d0*(1.0d0 + Sqrt(3.0d0))) 6466 EdgeBasis(5,2) = (4.0d0 - 4.0d0*u - 4.0d0*(1.0d0 + Sqrt(3.0d0))*v + Sqrt(2.0d0)*w)/ & 6467 (4.0d0*(3.0d0 + Sqrt(3.0d0))) 6468 EdgeBasis(5,3) = (-Sqrt(2.0d0) + Sqrt(2.0d0)*u - Sqrt(2.0d0)*(2.0d0 + Sqrt(3.0d0))*v + & 6469 w + Sqrt(3.0d0)*w)/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6470 CurlBasis(5,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6471 CurlBasis(5,2) = 1.0d0/(2.0d0*Sqrt(6.0d0)) 6472 CurlBasis(5,3) = 1.0d0/Sqrt(3.0d0) 6473 6474 EdgeBasis(6,1) = -((-3.0d0 + Sqrt(3.0d0))*(4.0d0*v - Sqrt(2.0d0)*w))/24.0d0 6475 EdgeBasis(6,2) = (4.0d0*(3.0d0 + Sqrt(3.0d0))*u + 8.0d0*Sqrt(3.0d0)*v + & 6476 (3.0d0 + Sqrt(3.0d0))*(-4.0d0 + Sqrt(2.0d0)*w))/24.0d0 6477 EdgeBasis(6,3) = (3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0) - Sqrt(2.0d0)*(3.0d0 + Sqrt(3.0d0))*u + & 6478 Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*v - 2.0d0*Sqrt(3.0d0)*w)/24.0d0 6479 CurlBasis(6,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6480 CurlBasis(6,2) = 1.0d0/(2.0d0*Sqrt(6.0d0)) 6481 CurlBasis(6,3) = 1.0d0/Sqrt(3.0d0) 6482 END IF 6483 6484 !------------------------------------------------- 6485 ! Two basis functions defined on the edge 14. 6486 !------------------------------------------------- 6487 i = EdgeMap(4,1) 6488 j = EdgeMap(4,2) 6489 ni = Element % NodeIndexes(i) 6490 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6491 nj = Element % NodeIndexes(j) 6492 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6493 IF (nj<ni) THEN 6494 ! The sign and order of basis functions are reverted as 6495 ! compared with the other possibility 6496 EdgeBasis(7,1) = -((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6497 EdgeBasis(7,2) = -((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6498 EdgeBasis(7,3) = -(-3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0) - Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*u + & 6499 Sqrt(2.0d0)*(-1.0d0 + Sqrt(3.0d0))*v + 2.0d0*Sqrt(3.0d0)*w)/8.0d0 6500 CurlBasis(7,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6501 CurlBasis(7,2) = -Sqrt(1.5d0)/2.0d0 6502 CurlBasis(7,3) = 0.0d0 6503 6504 EdgeBasis(8,1) = -((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6505 EdgeBasis(8,2) = -((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6506 EdgeBasis(8,3) = -((-3.0d0 + Sqrt(3.0d0))*w - (Sqrt(2.0d0)*(3.0d0 + 2.0d0*Sqrt(3.0d0))* & 6507 (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(3.0d0 + Sqrt(3.0d0)))/ & 6508 (8.0d0*Sqrt(3.0d0)) 6509 CurlBasis(8,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6510 CurlBasis(8,2) = -(3.0d0*(Sqrt(2.0d0) + Sqrt(6.0d0)))/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6511 CurlBasis(8,3) = 0.0d0 6512 ELSE 6513 EdgeBasis(7,1) = ((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6514 EdgeBasis(7,2) = ((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6515 EdgeBasis(7,3) = ((-3.0d0 + Sqrt(3.0d0))*w - (Sqrt(2.0d0)*(3.0d0 + 2.0d0*Sqrt(3.0d0))* & 6516 (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(3.0d0 + Sqrt(3.0d0)))/ & 6517 (8.0d0*Sqrt(3.0d0)) 6518 CurlBasis(7,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6519 CurlBasis(7,2) = (3.0d0*(Sqrt(2.0d0) + Sqrt(6.0d0)))/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6520 CurlBasis(7,3) = 0.0d0 6521 6522 EdgeBasis(8,1) = ((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6523 EdgeBasis(8,2) = ((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6524 EdgeBasis(8,3) = (-3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0) - Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*u + & 6525 Sqrt(2.0d0)*(-1.0d0 + Sqrt(3.0d0))*v + 2.0d0*Sqrt(3.0d0)*w)/8.0d0 6526 CurlBasis(8,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6527 CurlBasis(8,2) = Sqrt(1.5d0)/2.0d0 6528 CurlBasis(8,3) = 0.0d0 6529 END IF 6530 6531 !------------------------------------------------- 6532 ! Two basis functions defined on the edge 24. 6533 !------------------------------------------------- 6534 i = EdgeMap(5,1) 6535 j = EdgeMap(5,2) 6536 ni = Element % NodeIndexes(i) 6537 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6538 nj = Element % NodeIndexes(j) 6539 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6540 IF (nj<ni) THEN 6541 ! The sign and order of basis functions are reverted as 6542 ! compared with the other possibility 6543 EdgeBasis(9,1) = ((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6544 EdgeBasis(9,2) = -((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6545 EdgeBasis(9,3) = -(-3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0) + Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*u + & 6546 Sqrt(2.0d0)*(-1.0d0 + Sqrt(3.0d0))*v + 2.0d0*Sqrt(3.0d0)*w)/8.0d0 6547 CurlBasis(9,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6548 CurlBasis(9,2) = Sqrt(1.5d0)/2.0d0 6549 CurlBasis(9,3) = 0.0d0 6550 6551 EdgeBasis(10,1) = ((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6552 EdgeBasis(10,2) = -((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6553 EdgeBasis(10,3) = -((-3.0d0 + Sqrt(3.0d0))*w - (Sqrt(2.0d0)*(3.0d0 + 2.0d0*Sqrt(3.0d0))*& 6554 (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/& 6555 (3.0d0 + Sqrt(3.0d0)))/(8.0d0*Sqrt(3.0d0)) 6556 CurlBasis(10,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6557 CurlBasis(10,2) = -(-3.0d0*(Sqrt(2.0d0) + Sqrt(6.0d0)))/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6558 CurlBasis(10,3) = 0.0d0 6559 ELSE 6560 EdgeBasis(9,1) = -((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6561 EdgeBasis(9,2) = ((-3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6562 EdgeBasis(9,3) = ((-3.0d0 + Sqrt(3.0d0))*w - (Sqrt(2.0d0)*(3.0d0 + 2.0d0*Sqrt(3.0d0))*& 6563 (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/& 6564 (3.0d0 + Sqrt(3.0d0)))/(8.0d0*Sqrt(3.0d0)) 6565 CurlBasis(9,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6566 CurlBasis(9,2) = (-3.0d0*(Sqrt(2.0d0) + Sqrt(6.0d0)))/(4.0d0*(3.0d0 + Sqrt(3.0d0))) 6567 CurlBasis(9,3) = 0.0d0 6568 6569 EdgeBasis(10,1) = -((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(2.0d0)) 6570 EdgeBasis(10,2) = ((3.0d0 + Sqrt(3.0d0))*w)/(4.0d0*Sqrt(6.0d0)) 6571 EdgeBasis(10,3) = (-3.0d0*Sqrt(2.0d0) + Sqrt(6.0d0) + Sqrt(2.0d0)*(-3.0d0 + Sqrt(3.0d0))*u + & 6572 Sqrt(2.0d0)*(-1.0d0 + Sqrt(3.0d0))*v + 2.0d0*Sqrt(3.0d0)*w)/8.0d0 6573 CurlBasis(10,1) = -1.0d0/(2.0d0*Sqrt(2.0d0)) 6574 CurlBasis(10,2) = -Sqrt(1.5d0)/2.0d0 6575 CurlBasis(10,3) = 0.0d0 6576 END IF 6577 6578 !------------------------------------------------- 6579 ! Two basis functions defined on the edge 34. 6580 !------------------------------------------------- 6581 i = EdgeMap(6,1) 6582 j = EdgeMap(6,2) 6583 ni = Element % NodeIndexes(i) 6584 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6585 nj = Element % NodeIndexes(j) 6586 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6587 IF (nj<ni) THEN 6588 ! The sign and order of basis functions are reverted as 6589 ! compared with the other possibility 6590 EdgeBasis(11,1) = 0.0d0 6591 EdgeBasis(11,2) = ((1.0d0 + Sqrt(3.0d0))*w)/(2.0d0*Sqrt(2.0d0)) 6592 EdgeBasis(11,3) = -(6.0d0*Sqrt(2.0d0)*v - 4.0d0*Sqrt(6.0d0)*v - 3.0d0*w + & 6593 3.0d0*Sqrt(3.0d0)*w)/(12.0d0 - 4.0d0*Sqrt(3.0d0)) 6594 CurlBasis(11,1) = -1.0d0/Sqrt(2.0d0) 6595 CurlBasis(11,2) = 0.0d0 6596 CurlBasis(11,3) = 0.0d0 6597 6598 EdgeBasis(12,1) = 0.0d0 6599 EdgeBasis(12,2) = ((-3.0d0 + Sqrt(3.0d0))*w)/(2.0d0*Sqrt(6.0d0)) 6600 EdgeBasis(12,3) = -((Sqrt(2.0d0) + Sqrt(6.0d0))*v - Sqrt(3.0d0)*w)/4.0d0 6601 CurlBasis(12,1) = -1.0d0/Sqrt(2.0d0) 6602 CurlBasis(12,2) = 0.0d0 6603 CurlBasis(12,3) = 0.0d0 6604 ELSE 6605 EdgeBasis(11,1) = 0.0d0 6606 EdgeBasis(11,2) = -((-3.0d0 + Sqrt(3.0d0))*w)/(2.0d0*Sqrt(6.0d0)) 6607 EdgeBasis(11,3) = ((Sqrt(2.0d0) + Sqrt(6.0d0))*v - Sqrt(3.0d0)*w)/4.0d0 6608 CurlBasis(11,1) = 1.0d0/Sqrt(2.0d0) 6609 CurlBasis(11,2) = 0.0d0 6610 CurlBasis(11,3) = 0.0d0 6611 6612 EdgeBasis(12,1) = 0.0d0 6613 EdgeBasis(12,2) = -((1.0d0 + Sqrt(3.0d0))*w)/(2.0d0*Sqrt(2.0d0)) 6614 EdgeBasis(12,3) = (6.0d0*Sqrt(2.0d0)*v - 4.0d0*Sqrt(6.0d0)*v - 3.0d0*w + & 6615 3.0d0*Sqrt(3.0d0)*w)/(12.0d0 - 4.0d0*Sqrt(3.0d0)) 6616 CurlBasis(12,1) = 1.0d0/Sqrt(2.0d0) 6617 CurlBasis(12,2) = 0.0d0 6618 CurlBasis(12,3) = 0.0d0 6619 END IF 6620 6621 ELSE 6622 6623 !------------------------------------------------------------- 6624 ! The optimal/Nedelec basis functions of the first kind. We employ 6625 ! a hierarchic basis, so the lowest-order basis functions are 6626 ! also utilized in the construction of the second-order basis. 6627 ! The first the edge ... 6628 !------------------------------------------------------------- 6629 i = EdgeMap(1,1) 6630 j = EdgeMap(1,2) 6631 ni = Element % NodeIndexes(i) 6632 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6633 nj = Element % NodeIndexes(j) 6634 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6635 EdgeBasis(1,1) = (6.0d0 - 2.0d0*Sqrt(3.0d0)*v - Sqrt(6.0d0)*w)/24.0d0 6636 EdgeBasis(1,2) = u/(4.0d0*Sqrt(3.0d0)) 6637 EdgeBasis(1,3) = u/(4.0d0*Sqrt(6.0d0)) 6638 CurlBasis(1,1) = 0.0d0 6639 CurlBasis(1,2) = -1.0d0/(2.0d0*Sqrt(6.0d0)) 6640 CurlBasis(1,3) = 1.0d0/(2.0d0*Sqrt(3.0d0)) 6641 IF (nj<ni) THEN 6642 EdgeBasis(1,:) = -EdgeBasis(1,:) 6643 CurlBasis(1,:) = -CurlBasis(1,:) 6644 END IF 6645 IF (SecondOrder) THEN 6646 EdgeBasis(2,1) = -(u*(-6.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/4.0d0 6647 EdgeBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0 6648 EdgeBasis(2,3) = (Sqrt(1.5d0)*u**2)/2.0d0 6649 CurlBasis(2,1) = 0.0d0 6650 CurlBasis(2,2) = (-3.0d0*Sqrt(1.5d0)*u)/2.0d0 6651 CurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0 6652 END IF 6653 6654 !------------------------------------------------- 6655 ! Basis functions associated with the second edge: 6656 !------------------------------------------------- 6657 IF (SecondOrder) THEN 6658 k = 3 6659 EdgeBasis(4,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*(4.0d0*v - Sqrt(2.0d0)*w))/16.0d0 6660 EdgeBasis(4,2) = -((1.0d0 + u - Sqrt(3.0d0)*v)*& 6661 (4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 3.0d0*Sqrt(2.0d0)*w))/16.0d0 6662 EdgeBasis(4,3) = -((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*& 6663 (-1.0d0 - u + Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0)) 6664 CurlBasis(4,1) = (-9.0d0*(1.0d0 + u - Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0)) 6665 CurlBasis(4,2) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/(8.0d0*Sqrt(2.0d0)) 6666 CurlBasis(4,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0 6667 ELSE 6668 k = 2 6669 END IF 6670 6671 i = EdgeMap(2,1) 6672 j = EdgeMap(2,2) 6673 ni = Element % NodeIndexes(i) 6674 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6675 nj = Element % NodeIndexes(j) 6676 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6677 EdgeBasis(k,1) = (-4.0d0*v + Sqrt(2.0d0)*w)/(16.0d0*Sqrt(3.0d0)) 6678 EdgeBasis(k,2) = (4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 3.0d0*Sqrt(2.0d0)*w)/48.0d0 6679 EdgeBasis(k,3) = -(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)/(24.0d0*Sqrt(2.0d0)) 6680 CurlBasis(k,1) = 1.0d0/(4.0d0*Sqrt(2.0d0)) 6681 CurlBasis(k,2) = 1.0d0/(4.0d0*Sqrt(6.0d0)) 6682 CurlBasis(k,3) = 1.0d0/(2.0d0*Sqrt(3.0d0)) 6683 IF (nj<ni) THEN 6684 EdgeBasis(k,:) = -EdgeBasis(k,:) 6685 CurlBasis(k,:) = -CurlBasis(k,:) 6686 END IF 6687 6688 !------------------------------------------------- 6689 ! Basis functions associated with the third edge: 6690 !------------------------------------------------- 6691 IF (SecondOrder) THEN 6692 k = 5 6693 EdgeBasis(6,1) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v)*& 6694 (4.0d0*v - Sqrt(2.0d0)*w))/16.0d0 6695 EdgeBasis(6,2) = -((-1.0d0 + u + Sqrt(3.0d0)*v)*& 6696 (-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + 3.0d0*Sqrt(2.0d0)*w))/16.0d0 6697 EdgeBasis(6,3) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v)*& 6698 (-1.0d0 + u + Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0)) 6699 CurlBasis(6,1) = (9.0d0*(-1.0d0 + u + Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0)) 6700 CurlBasis(6,2) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/(8.0d0*Sqrt(2.0d0)) 6701 CurlBasis(6,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 6702 ELSE 6703 k = 3 6704 END IF 6705 6706 i = EdgeMap(3,1) 6707 j = EdgeMap(3,2) 6708 ni = Element % NodeIndexes(i) 6709 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6710 nj = Element % NodeIndexes(j) 6711 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6712 EdgeBasis(k,1) = (-4.0d0*v + Sqrt(2.0d0)*w)/(16.0d0*Sqrt(3.0d0)) 6713 EdgeBasis(k,2) = (-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + 3.0d0*Sqrt(2.0d0)*w)/48.0d0 6714 EdgeBasis(k,3) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - 3.0d0*Sqrt(2.0d0)*v)/48.0d0 6715 CurlBasis(k,1) = -1.0d0/(4.0d0*Sqrt(2.0d0)) 6716 CurlBasis(k,2) = 1.0d0/(4.0d0*Sqrt(6.0d0)) 6717 CurlBasis(k,3) = 1.0d0/(2.0d0*Sqrt(3.0d0)) 6718 IF (nj<ni) THEN 6719 EdgeBasis(k,:) = -EdgeBasis(k,:) 6720 CurlBasis(k,:) = -CurlBasis(k,:) 6721 END IF 6722 6723 !------------------------------------------------- 6724 ! Basis functions associated with the fourth edge: 6725 !------------------------------------------------- 6726 IF (SecondOrder) THEN 6727 k = 7 6728 EdgeBasis(8,1) = (3.0d0*w*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + 4.0d0*w))/16.0d0 6729 EdgeBasis(8,2) = (w*(-3.0d0*Sqrt(2.0d0) + 3.0d0*Sqrt(2.0d0)*u + Sqrt(6.0d0)*v + & 6730 4.0d0*Sqrt(3.0d0)*w))/16.0d0 6731 EdgeBasis(8,3) = -((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v)*& 6732 (-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v + 2.0d0*Sqrt(6.0d0)*w))/(8.0d0*Sqrt(2.0d0)) 6733 CurlBasis(8,1) = (-3.0d0*(-3.0d0*Sqrt(2.0d0) + 3.0d0*Sqrt(2.0d0)*u + & 6734 Sqrt(6.0d0)*v + 4.0d0*Sqrt(3.0d0)*w))/16.0d0 6735 CurlBasis(8,2) = (9.0d0*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + 4.0d0*w))/16.0d0 6736 CurlBasis(8,3) = 0.0d0 6737 ELSE 6738 k = 4 6739 END IF 6740 6741 i = EdgeMap(4,1) 6742 j = EdgeMap(4,2) 6743 ni = Element % NodeIndexes(i) 6744 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6745 nj = Element % NodeIndexes(j) 6746 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6747 EdgeBasis(k,1) = (Sqrt(1.5d0)*w)/8.0d0 6748 EdgeBasis(k,2) = w/(8.0d0*Sqrt(2.0d0)) 6749 EdgeBasis(k,3) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)/16.0d0 6750 CurlBasis(k,1) = -1.0d0/(4.0d0*Sqrt(2.0d0)) 6751 CurlBasis(k,2) = Sqrt(1.5d0)/4.0d0 6752 CurlBasis(k,3) = 0.0d0 6753 IF (nj<ni) THEN 6754 EdgeBasis(k,:) = -EdgeBasis(k,:) 6755 CurlBasis(k,:) = -CurlBasis(k,:) 6756 END IF 6757 6758 !------------------------------------------------- 6759 ! Basis functions associated with the fifth edge: 6760 !------------------------------------------------- 6761 IF (SecondOrder) THEN 6762 k = 9 6763 EdgeBasis(10,1) = (3.0d0*(Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 4.0d0*w)*w)/16.0d0 6764 EdgeBasis(10,2) = (w*(-3.0d0*Sqrt(2.0d0) - 3.0d0*Sqrt(2.0d0)*u + & 6765 Sqrt(6.0d0)*v + 4.0d0*Sqrt(3.0d0)*w))/16.0d0 6766 EdgeBasis(10,3) = ((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)*& 6767 (-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v + 2.0d0*Sqrt(6.0d0)*w))/16.0d0 6768 CurlBasis(10,1) = (3.0d0*(3.0d0*Sqrt(2.0d0) + 3.0d0*Sqrt(2.0d0)*u - & 6769 Sqrt(6.0d0)*v - 4.0d0*Sqrt(3.0d0)*w))/16.0d0 6770 CurlBasis(10,2) = (9.0d0*(Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 4.0d0*w))/16.0d0 6771 CurlBasis(10,3) = 0.0d0 6772 ELSE 6773 k = 5 6774 END IF 6775 6776 i = EdgeMap(5,1) 6777 j = EdgeMap(5,2) 6778 ni = Element % NodeIndexes(i) 6779 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6780 nj = Element % NodeIndexes(j) 6781 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6782 EdgeBasis(k,1) = -(Sqrt(1.5d0)*w)/8.0d0 6783 EdgeBasis(k,2) = w/(8.0d0*Sqrt(2.0d0)) 6784 EdgeBasis(k,3) = (Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)/16.0d0 6785 CurlBasis(k,1) = -1.0d0/(4.0d0*Sqrt(2.0d0)) 6786 CurlBasis(k,2) = -Sqrt(1.5d0)/4.0d0 6787 CurlBasis(k,3) = 0.0d0 6788 IF (nj<ni) THEN 6789 EdgeBasis(k,:) = -EdgeBasis(k,:) 6790 CurlBasis(k,:) = -CurlBasis(k,:) 6791 END IF 6792 6793 !------------------------------------------------- 6794 ! Basis functions associated with the sixth edge: 6795 !------------------------------------------------- 6796 IF (SecondOrder) THEN 6797 k = 11 6798 EdgeBasis(12,1) = 0.0d0 6799 EdgeBasis(12,2) = (Sqrt(3.0d0)*(Sqrt(2.0d0)*v - 2.0d0*w)*w)/4.0d0 6800 EdgeBasis(12,3) = (Sqrt(1.5d0)*v*(-v + Sqrt(2.0d0)*w))/2.0d0 6801 CurlBasis(12,1) = (-3.0d0*(Sqrt(6.0d0)*v - 2.0d0*Sqrt(3.0d0)*w))/4.0d0 6802 CurlBasis(12,2) = 0.0d0 6803 CurlBasis(12,3) = 0.0d0 6804 ELSE 6805 k = 6 6806 END IF 6807 6808 i = EdgeMap(6,1) 6809 j = EdgeMap(6,2) 6810 ni = Element % NodeIndexes(i) 6811 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 6812 nj = Element % NodeIndexes(j) 6813 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 6814 EdgeBasis(k,1) = 0.0d0 6815 EdgeBasis(k,2) = -w/(4.0d0*Sqrt(2.0d0)) 6816 EdgeBasis(k,3) = v/(4.0d0*Sqrt(2.0d0)) 6817 CurlBasis(k,1) = 1.0d0/(2.0d0*Sqrt(2.0d0)) 6818 CurlBasis(k,2) = 0.0d0 6819 CurlBasis(k,3) = 0.0d0 6820 IF (nj<ni) THEN 6821 EdgeBasis(k,:) = -EdgeBasis(k,:) 6822 CurlBasis(k,:) = -CurlBasis(k,:) 6823 END IF 6824 6825 ! ------------------------------------------------------------- 6826 ! Finally scale the lowest-order basis functions so that 6827 ! (b,t) = 1 when the integration is done over the element edge. 6828 ! ------------------------------------------------------------- 6829 IF (SecondOrder) THEN 6830 DO k=1,6 6831 EdgeBasis(2*(k-1)+1,:) = 2.0d0 * EdgeBasis(2*(k-1)+1,:) 6832 CurlBasis(2*(k-1)+1,:) = 2.0d0 * CurlBasis(2*(k-1)+1,:) 6833 END DO 6834 ELSE 6835 DO k=1,6 6836 EdgeBasis(k,:) = 2.0d0 * EdgeBasis(k,:) 6837 CurlBasis(k,:) = 2.0d0 * CurlBasis(k,:) 6838 END DO 6839 END IF 6840 6841 IF (SecondOrder) THEN 6842 !------------------------------------------------- 6843 ! Two basis functions defined on the face 213: 6844 !------------------------------------------------- 6845 TriangleFaceMap(:) = (/ 2,1,3 /) 6846 Ind => Element % Nodeindexes 6847 6848 DO j=1,3 6849 FaceIndices(j) = Ind(TriangleFaceMap(j)) 6850 END DO 6851 IF (Parallel) THEN 6852 DO j=1,3 6853 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6854 END DO 6855 END IF 6856 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 6857 6858 WorkBasis(1,1) = ((4.0d0*v - Sqrt(2.0d0)*w)*& 6859 (-6.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(48.0d0*Sqrt(3.0d0)) 6860 WorkBasis(1,2) = -(u*(4.0d0*v - Sqrt(2.0d0)*w))/24.0d0 6861 WorkBasis(1,3) = (u*(-2.0d0*Sqrt(2.0d0)*v + w))/24.0d0 6862 WorkCurlBasis(1,1) = -u/(4.0d0*Sqrt(2.0d0)) 6863 WorkCurlBasis(1,2) = (Sqrt(6.0d0) + 3.0d0*Sqrt(2.0d0)*v - 3.0d0*w)/24.0d0 6864 WorkCurlBasis(1,3) = (Sqrt(3.0d0) - 3.0d0*v)/6.0d0 6865 6866 WorkBasis(2,1) = ((4.0d0*v - Sqrt(2.0d0)*w)*(-6.0d0 + 6.0d0*u + & 6867 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(96.0d0*Sqrt(3.0d0)) 6868 WorkBasis(2,2) = -((4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 3.0d0*Sqrt(2.0d0)*w)*& 6869 (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/288.0d0 6870 WorkBasis(2,3) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*& 6871 (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(144.0d0*Sqrt(2.0d0)) 6872 WorkCurlBasis(2,1) = -(-6.0d0 + 2.0d0*u + 2.0d0*Sqrt(3.0d0)*v + & 6873 Sqrt(6.0d0)*w)/(16.0d0*Sqrt(2.0d0)) 6874 WorkCurlBasis(2,2) = (2.0d0*Sqrt(3.0d0) - 6.0d0*Sqrt(3.0d0)*u + & 6875 6.0d0*v - 3.0d0*Sqrt(2.0d0)*w)/(48.0d0*Sqrt(2.0d0)) 6876 WorkCurlBasis(2,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0 6877 6878 WorkBasis(3,1) = -((4.0d0*v - Sqrt(2.0d0)*w)*(-6.0d0 - 6.0d0*u + & 6879 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(96.0d0*Sqrt(3.0d0)) 6880 WorkBasis(3,2) = ((-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + 3.0d0*Sqrt(2.0d0)*w)* & 6881 (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/288.0d0 6882 WorkBasis(3,3) = -((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v)* & 6883 (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(144.0d0*Sqrt(2.0d0)) 6884 WorkCurlBasis(3,1) = -(-6.0d0 - 2.0d0*u + 2.0d0*Sqrt(3.0d0)*v + & 6885 Sqrt(6.0d0)*w)/(16.0d0*Sqrt(2.0d0)) 6886 WorkCurlBasis(3,2) = (-2.0d0*Sqrt(3.0d0) - 6.0d0*Sqrt(3.0d0)*u - 6.0d0*v + & 6887 3.0d0*Sqrt(2.0d0)*w)/(48.0d0*Sqrt(2.0d0)) 6888 WorkCurlBasis(3,3) = (-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0 6889 6890 EdgeBasis(13,:) = D1 * WorkBasis(I1,:) 6891 CurlBasis(13,:) = D1 * WorkCurlBasis(I1,:) 6892 EdgeBasis(14,:) = D2 * WorkBasis(I2,:) 6893 CurlBasis(14,:) = D2 * WorkCurlBasis(I2,:) 6894 6895 !------------------------------------------------- 6896 ! Two basis functions defined on the face 124: 6897 !------------------------------------------------- 6898 TriangleFaceMap(:) = (/ 1,2,4 /) 6899 Ind => Element % Nodeindexes 6900 6901 DO j=1,3 6902 FaceIndices(j) = Ind(TriangleFaceMap(j)) 6903 END DO 6904 IF (Parallel) THEN 6905 DO j=1,3 6906 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6907 END DO 6908 END IF 6909 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 6910 6911 WorkBasis(1,1) = -(w*(-6.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(8.0d0*Sqrt(6.0d0)) 6912 WorkBasis(1,2) = (u*w)/(4.0d0*Sqrt(2.0d0)) 6913 WorkBasis(1,3) = (u*w)/8.0d0 6914 WorkCurlBasis(1,1) = -u/(4.0d0*Sqrt(2.0d0)) 6915 WorkCurlBasis(1,2) = (Sqrt(6.0d0) - Sqrt(2.0d0)*v - 3.0d0*w)/8.0d0 6916 WorkCurlBasis(1,3) = w/(2.0d0*Sqrt(2.0d0)) 6917 6918 WorkBasis(2,1) = -(w*(-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + & 6919 Sqrt(6.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 6920 WorkBasis(2,2) = (w*(1.0d0 + u - v/Sqrt(3.0d0) - w/Sqrt(6.0d0)))/(8.0d0*Sqrt(2.0d0)) 6921 WorkBasis(2,3) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v)* & 6922 (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(48.0d0*Sqrt(2.0d0)) 6923 WorkCurlBasis(2,1) = (-3.0d0*Sqrt(2.0d0) - Sqrt(2.0d0)*u + Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0 6924 WorkCurlBasis(2,2) = (Sqrt(6.0d0) + 3.0d0*Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 3.0d0*w)/16.0d0 6925 WorkCurlBasis(2,3) = w/(4.0d0*Sqrt(2.0d0)) 6926 6927 WorkBasis(3,1) = (w*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 6928 WorkBasis(3,2) = -(w*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(48.0d0*Sqrt(2.0d0)) 6929 WorkBasis(3,3) = -((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)*& 6930 (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/96.0d0 6931 WorkCurlBasis(3,1) = (-3.0d0*Sqrt(2.0d0) + Sqrt(2.0d0)*u + Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0 6932 WorkCurlBasis(3,2) = (-Sqrt(6.0d0) + 3.0d0*Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0 6933 WorkCurlBasis(3,3) = -w/(4.0d0*Sqrt(2.0d0)) 6934 6935 EdgeBasis(15,:) = D1 * WorkBasis(I1,:) 6936 CurlBasis(15,:) = D1 * WorkCurlBasis(I1,:) 6937 EdgeBasis(16,:) = D2 * WorkBasis(I2,:) 6938 CurlBasis(16,:) = D2 * WorkCurlBasis(I2,:) 6939 6940 !------------------------------------------------- 6941 ! Two basis functions defined on the face 234: 6942 !------------------------------------------------- 6943 TriangleFaceMap(:) = (/ 2,3,4 /) 6944 Ind => Element % Nodeindexes 6945 6946 DO j=1,3 6947 FaceIndices(j) = Ind(TriangleFaceMap(j)) 6948 END DO 6949 IF (Parallel) THEN 6950 DO j=1,3 6951 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6952 END DO 6953 END IF 6954 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 6955 6956 WorkBasis(1,1) = (w*(-2.0d0*Sqrt(2.0d0)*v + w))/16.0d0 6957 WorkBasis(1,2) = (w*(4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - & 6958 3.0d0*Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 6959 WorkBasis(1,3) = -((1.0d0 + u - Sqrt(3.0d0)*v)*w)/16.0d0 6960 WorkCurlBasis(1,1) = (-2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u + 3.0d0*Sqrt(3.0d0)*w)/16.0d0 6961 WorkCurlBasis(1,2) = (-2.0d0*Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0 6962 WorkCurlBasis(1,3) = w/(2.0d0*Sqrt(2.0d0)) 6963 6964 WorkBasis(2,1) = (w*(-2.0d0*Sqrt(2.0d0)*v + w))/16.0d0 6965 WorkBasis(2,2) = -(w*(-4.0d0*v + Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 6966 WorkBasis(2,3) = -((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)*& 6967 (-4.0d0*v + Sqrt(2.0d0)*w))/(32.0d0*Sqrt(3.0d0)) 6968 WorkCurlBasis(2,1) = (2.0d0*Sqrt(2.0d0) + 2.0d0*Sqrt(2.0d0)*u - & 6969 2.0d0*Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0 6970 WorkCurlBasis(2,2) = (-4.0d0*Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0 6971 WorkCurlBasis(2,3) = w/(4.0d0*Sqrt(2.0d0)) 6972 6973 WorkBasis(3,1) = 0.0d0 6974 WorkBasis(3,2) = (w*(-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0)) 6975 WorkBasis(3,3) = -(v*(-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0)) 6976 WorkCurlBasis(3,1) = (2.0d0*Sqrt(2.0d0) + 2.0d0*Sqrt(2.0d0)*u - Sqrt(6.0d0)*v - Sqrt(3.0d0)*w)/8.0d0 6977 WorkCurlBasis(3,2) = -v/(4.0d0*Sqrt(2.0d0)) 6978 WorkCurlBasis(3,3) = -w/(4.0d0*Sqrt(2.0d0)) 6979 6980 EdgeBasis(17,:) = D1 * WorkBasis(I1,:) 6981 CurlBasis(17,:) = D1 * WorkCurlBasis(I1,:) 6982 EdgeBasis(18,:) = D2 * WorkBasis(I2,:) 6983 CurlBasis(18,:) = D2 * WorkCurlBasis(I2,:) 6984 6985 !------------------------------------------------- 6986 ! Two basis functions defined on the face 314: 6987 !------------------------------------------------- 6988 TriangleFaceMap(:) = (/ 3,1,4 /) 6989 Ind => Element % Nodeindexes 6990 6991 DO j=1,3 6992 FaceIndices(j) = Ind(TriangleFaceMap(j)) 6993 END DO 6994 IF (Parallel) THEN 6995 DO j=1,3 6996 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 6997 END DO 6998 END IF 6999 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7000 7001 WorkBasis(1,1) = (w*(-2.0d0*Sqrt(2.0d0)*v + w))/16.0d0 7002 WorkBasis(1,2) = (w*(-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + & 7003 3.0d0*Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 7004 WorkBasis(1,3) = -((-1.0d0 + u + Sqrt(3.0d0)*v)*w)/16.0d0 7005 WorkCurlBasis(1,1) = (2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u - 3.0d0*Sqrt(3.0d0)*w)/16.0d0 7006 WorkCurlBasis(1,2) = (-2.0d0*Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0 7007 WorkCurlBasis(1,3) = w/(2.0d0*Sqrt(2.0d0)) 7008 7009 WorkBasis(2,1) = 0.0d0 7010 WorkBasis(2,2) = (w*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0)) 7011 WorkBasis(2,3) = -(v*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0)) 7012 WorkCurlBasis(2,1) = (2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u - Sqrt(6.0d0)*v - Sqrt(3.0d0)*w)/8.0d0 7013 WorkCurlBasis(2,2) = v/(4.0d0*Sqrt(2.0d0)) 7014 WorkCurlBasis(2,3) = w/(4.0d0*Sqrt(2.0d0)) 7015 7016 WorkBasis(3,1) = ((2.0d0*Sqrt(2.0d0)*v - w)*w)/16.0d0 7017 WorkBasis(3,2) = -(w*(-4.0d0*v + Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 7018 WorkBasis(3,3) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v)*& 7019 (-4.0d0*v + Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0)) 7020 WorkCurlBasis(3,1) = (2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u - & 7021 2.0d0*Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0 7022 WorkCurlBasis(3,2) = (4.0d0*Sqrt(2.0d0)*v - 3.0d0*w)/16.0d0 7023 WorkCurlBasis(3,3) = -w/(4.0d0*Sqrt(2.0d0)) 7024 7025 EdgeBasis(19,:) = D1 * WorkBasis(I1,:) 7026 CurlBasis(19,:) = D1 * WorkCurlBasis(I1,:) 7027 EdgeBasis(20,:) = D2 * WorkBasis(I2,:) 7028 CurlBasis(20,:) = D2 * WorkCurlBasis(I2,:) 7029 END IF 7030 END IF 7031 7032 CASE(6) 7033 !-------------------------------------------------------------- 7034 ! This branch is for handling pyramidic elements 7035 !-------------------------------------------------------------- 7036 EdgeMap => GetEdgeMap(6) 7037 Ind => Element % Nodeindexes 7038 7039 IF (SecondOrder) THEN 7040 EdgeSign = 1.0d0 7041 7042 LBasis(1) = 0.1D1 / 0.4D1 - u / 0.4D1 - v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 + & 7043 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 ) 7044 LBasis(2) = 0.1D1 / 0.4D1 + u / 0.4D1 - v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 - & 7045 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 ) 7046 LBasis(3) = 0.1D1 / 0.4D1 + u / 0.4D1 + v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 + & 7047 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 ) 7048 LBasis(4) = 0.1D1 / 0.4D1 - u / 0.4D1 + v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 - & 7049 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 ) 7050 LBasis(5) = w * sqrt(0.2D1) / 0.2D1 7051 7052 Beta(1) = 0.1D1 / 0.2D1 - u / 0.2D1 - w * sqrt(0.2D1) / 0.4D1 7053 Beta(2) = 0.1D1 / 0.2D1 - v / 0.2D1 - w * sqrt(0.2D1) / 0.4D1 7054 Beta(3) = 0.1D1 / 0.2D1 + u / 0.2D1 - w * sqrt(0.2D1) / 0.4D1 7055 Beta(4) = 0.1D1 / 0.2D1 + v / 0.2D1 - w * sqrt(0.2D1) / 0.4D1 7056 7057 ! Edge 12: 7058 !-------------------------------------------------------------- 7059 i = EdgeMap(1,1) 7060 j = EdgeMap(1,2) 7061 ni = Element % NodeIndexes(i) 7062 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7063 nj = Element % NodeIndexes(j) 7064 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7065 EdgeBasis(1,1) = 0.1D1 / 0.4D1 - v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 7066 EdgeBasis(1,2) = 0.0d0 7067 EdgeBasis(1,3) = sqrt(0.2D1) * u * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / & 7068 ((w * sqrt(0.2D1) - 0.2D1) * 0.8D1) 7069 CurlBasis(1,1) = sqrt(0.2D1) * u / ((w * sqrt(0.2D1) - 0.2D1) * 0.4D1) 7070 CurlBasis(1,2) = -sqrt(0.2D1) / 0.8D1 - sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / & 7071 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7072 CurlBasis(1,3) = 0.1D1 / 0.4D1 7073 IF (nj<ni) THEN 7074 EdgeBasis(1,:) = -EdgeBasis(1,:) 7075 CurlBasis(1,:) = -CurlBasis(1,:) 7076 EdgeSign(1) = -1.0d0 7077 END IF 7078 7079 EdgeBasis(2,1:3) = 3.0d0 * u * EdgeBasis(1,1:3) 7080 CurlBasis(2,1) = 0.3D1 / 0.4D1 * u ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) 7081 CurlBasis(2,2) = -0.3D1 / 0.8D1 * u * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) + & 7082 4.0D0 * v - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1) 7083 CurlBasis(2,3) = 0.3D1 / 0.4D1 * u 7084 7085 ! Edge 23: 7086 !-------------------------------------------------------------- 7087 k = 3 ! k=2 for first-order 7088 i = EdgeMap(2,1) 7089 j = EdgeMap(2,2) 7090 ni = Element % NodeIndexes(i) 7091 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7092 nj = Element % NodeIndexes(j) 7093 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7094 7095 EdgeBasis(k,1) = 0.0d0 7096 EdgeBasis(k,2) = 0.1D1 / 0.4D1 + u / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 7097 EdgeBasis(k,3) = sqrt(0.2D1) * v * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 7098 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7099 CurlBasis(k,1) = sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 7100 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) + sqrt(0.2D1) / 0.8D1 7101 CurlBasis(k,2) = sqrt(0.2D1) * v / ( (w * sqrt(0.2D1) - 0.2D1) * 0.4D1 ) 7102 CurlBasis(k,3) = 0.1D1 / 0.4D1 7103 IF (nj<ni) THEN 7104 EdgeBasis(k,:) = -EdgeBasis(k,:) 7105 CurlBasis(k,:) = -CurlBasis(k,:) 7106 EdgeSign(k) = -1.0d0 7107 END IF 7108 7109 EdgeBasis(k+1,1:3) = 3.0d0 * v * EdgeBasis(k,1:3) 7110 CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * v * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) - & 7111 4.0D0 * u - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1) 7112 CurlBasis(k+1,2) = 0.3D1 / 0.4D1 * v ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) 7113 CurlBasis(k+1,3) = 0.3D1 / 0.4D1 * v 7114 7115 ! Edge 43: 7116 !-------------------------------------------------------------- 7117 k = 5 ! k=3 for first-order 7118 i = EdgeMap(3,1) 7119 j = EdgeMap(3,2) 7120 ni = Element % NodeIndexes(i) 7121 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7122 nj = Element % NodeIndexes(j) 7123 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7124 7125 EdgeBasis(k,1) = 0.1D1 / 0.4D1 + v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 7126 EdgeBasis(k,2) = 0.0d0 7127 EdgeBasis(k,3) = sqrt(0.2D1) * u * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / & 7128 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7129 7130 CurlBasis(k,1) = -sqrt(0.2D1) * u / ( (w * sqrt(0.2D1) - 0.2D1) * 0.4D1 ) 7131 CurlBasis(k,2) = -sqrt(0.2D1) / 0.8D1 - sqrt(0.2D1) * (w * sqrt(0.2D1) - & 7132 2.0D0 * v - 0.2D1) / ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7133 CurlBasis(k,3) = -0.1D1 / 0.4D1 7134 IF (nj<ni) THEN 7135 EdgeBasis(k,:) = -EdgeBasis(k,:) 7136 CurlBasis(k,:) = -CurlBasis(k,:) 7137 EdgeSign(k) = -1.0d0 7138 END IF 7139 7140 EdgeBasis(k+1,1:3) = 3.0d0 * u * EdgeBasis(k,1:3) 7141 CurlBasis(k+1,1) = -0.3D1 / 0.4D1 * u ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) 7142 CurlBasis(k+1,2) = -0.3D1 / 0.8D1 * u * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) - & 7143 4.0D0 * v - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1) 7144 CurlBasis(k+1,3) = -0.3D1 / 0.4D1 * u 7145 7146 7147 ! Edge 14: 7148 !-------------------------------------------------------------- 7149 k = 7 ! k=4 for first-order 7150 i = EdgeMap(4,1) 7151 j = EdgeMap(4,2) 7152 ni = Element % NodeIndexes(i) 7153 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7154 nj = Element % NodeIndexes(j) 7155 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7156 7157 EdgeBasis(k,1) = 0.0d0 7158 EdgeBasis(k,2) = 0.1D1 / 0.4D1 - u / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 7159 EdgeBasis(k,3) = sqrt(0.2D1) * v * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / & 7160 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7161 7162 CurlBasis(k,1) = sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / ( (w * & 7163 sqrt(0.2D1) - 0.2D1) * 0.8D1 ) + sqrt(0.2D1) / 0.8D1 7164 CurlBasis(k,2) = -sqrt(0.2D1) * v / ( (w * sqrt(0.2D1) - 0.2D1) * 0.4D1 ) 7165 CurlBasis(k,3) = -0.1D1 / 0.4D1 7166 IF (nj<ni) THEN 7167 EdgeBasis(k,:) = -EdgeBasis(k,:) 7168 CurlBasis(k,:) = -CurlBasis(k,:) 7169 EdgeSign(k) = -1.0d0 7170 END IF 7171 7172 EdgeBasis(k+1,1:3) = 3.0d0 * v * EdgeBasis(k,1:3) 7173 CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * v * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) + & 7174 4.0D0 * u - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1) 7175 CurlBasis(k+1,2) = -0.3D1 / 0.4D1 * v ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) 7176 CurlBasis(k+1,3) = -0.3D1 / 0.4D1 * v 7177 7178 7179 ! Edge 15: 7180 !-------------------------------------------------------------- 7181 k = 9 ! k=5 for first-order 7182 i = EdgeMap(5,1) 7183 j = EdgeMap(5,2) 7184 ni = Element % NodeIndexes(i) 7185 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7186 nj = Element % NodeIndexes(j) 7187 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7188 7189 EdgeBasis(k,1) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / & 7190 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7191 EdgeBasis(k,2) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / & 7192 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7193 EdgeBasis(k,3) = -sqrt(0.2D1)/ 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w - & 7194 0.2D1 * sqrt(0.2D1) * u * w - & 7195 0.2D1 * sqrt(0.2D1) * v * w + u * w ** 2 + v * w ** 2 + 0.2D1 * w * sqrt(0.2D1) - & 7196 0.2D1 * u * v - w ** 2 + 0.2D1 * u + 0.2D1 * v - 0.2D1) / (w * sqrt(0.2D1) - 0.2D1) ** 2 7197 7198 CurlBasis(k,1) = (-sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * & 7199 u * w - 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 ) 7200 CurlBasis(k,2) = -(-sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * & 7201 v * w - 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 ) 7202 CurlBasis(k,3) = 0.0d0 7203 IF (nj<ni) THEN 7204 EdgeBasis(k,:) = -EdgeBasis(k,:) 7205 CurlBasis(k,:) = -CurlBasis(k,:) 7206 EdgeSign(k) = -1.0d0 7207 END IF 7208 7209 EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(1)+LBasis(3) ) 7210 7211 CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * (-0.9D1 * sqrt(0.2D1) * u * w ** 2 - & 7212 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 + & 7213 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w - & 7214 0.8D1 * u * v * w - 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) + & 7215 0.24D2 * u * w + 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - 0.16D2 * w) / & 7216 (w * sqrt(0.2D1) - 0.2D1)**2 7217 CurlBasis(k+1,2) = -0.3D1 / 0.8D1 * (-0.3D1 * sqrt(0.2D1) * u * w ** 2 - & 7218 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) + & 7219 0.4D1 * sqrt(0.2D1) * v ** 2 + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u* v * w - & 7220 0.4D1 * v ** 2 * w - 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) + & 7221 0.12D2 * u * w + 0.24D2 * v * w + 0.2D1 * sqrt(0.2D1) - 0.16D2 * w) / & 7222 (w * sqrt(0.2D1) - 0.2D1)**2 7223 CurlBasis(k+1,3) = 0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u - v) / (w * sqrt(0.2D1) - 0.2D1) 7224 7225 7226 ! Edge 25: 7227 !-------------------------------------------------------------- 7228 k = 11 ! k=6 for first-order 7229 i = EdgeMap(6,1) 7230 j = EdgeMap(6,2) 7231 ni = Element % NodeIndexes(i) 7232 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7233 nj = Element % NodeIndexes(j) 7234 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7235 7236 EdgeBasis(k,1) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / & 7237 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7238 EdgeBasis(k,2) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 7239 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7240 EdgeBasis(k,3) = sqrt(0.2D1)/ 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w - 0.2D1 * & 7241 sqrt(0.2D1) * u * w + 0.2D1 * sqrt(0.2D1) * v * w + u * w ** 2 - v * w ** 2 - & 7242 0.2D1 * w * sqrt(0.2D1) - 0.2D1 * u * v + w ** 2 + 0.2D1 * u - 0.2D1 * v + 0.2D1) / & 7243 (w * sqrt(0.2D1) - 0.2D1) ** 2 7244 CurlBasis(k,1) = -(sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * u * w + & 7245 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 ) 7246 CurlBasis(k,2) = (-sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * & 7247 v * w - 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 ) 7248 CurlBasis(k,3) = 0.0d0 7249 IF (nj<ni) THEN 7250 EdgeBasis(k,:) = -EdgeBasis(k,:) 7251 CurlBasis(k,:) = -CurlBasis(k,:) 7252 EdgeSign(k) = -1.0d0 7253 END IF 7254 7255 EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(2)+LBasis(4) ) 7256 7257 CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * (0.9D1 * sqrt(0.2D1) * u * w ** 2 - & 7258 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - & 7259 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u** 2 * w + & 7260 0.8D1 * u * v * w - 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) - & 7261 0.6D1 * v * sqrt(0.2D1) - 0.24D2 * u * w + 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - & 7262 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)**2 7263 CurlBasis(k+1,2) = -0.3D1 / 0.8D1 * (-0.3D1 * sqrt(0.2D1) * u * w ** 2 + & 7264 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) - & 7265 0.4D1 * sqrt(0.2D1) * v ** 2 - 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + & 7266 0.4D1 * v ** 2 * w + 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + & 7267 0.6D1 * v * sqrt(0.2D1) + 0.12D2 * u * w - 0.24D2 * v * w - 0.2D1 * sqrt(0.2D1) + & 7268 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)** 2 7269 CurlBasis(k+1,3) = 0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u + v) / (w * sqrt(0.2D1) - 0.2D1) 7270 7271 7272 ! Edge 35: 7273 !-------------------------------------------------------------- 7274 k = 13 ! k=7 for first-order 7275 i = EdgeMap(7,1) 7276 j = EdgeMap(7,2) 7277 ni = Element % NodeIndexes(i) 7278 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7279 nj = Element % NodeIndexes(j) 7280 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7281 7282 EdgeBasis(k,1) = -w * sqrt(0.2D1)/ 0.8D1 * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / & 7283 (w * sqrt(0.2D1) - 0.2D1) 7284 EdgeBasis(k,2) = -w * sqrt(0.2D1) / 0.8D1 * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 7285 (w * sqrt(0.2D1) - 0.2D1) 7286 EdgeBasis(k,3) = -sqrt(0.2D1)/ 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w + 0.2D1 * & 7287 sqrt(0.2D1) * u * w + 0.2D1 * sqrt(0.2D1) * v * w - u * w ** 2 - v * w ** 2 + & 7288 0.2D1 * w * sqrt(0.2D1) - 0.2D1 * u * v - w ** 2 - 0.2D1 * u - 0.2D1 * v - 0.2D1) / & 7289 (w * sqrt(0.2D1) - 0.2D1) ** 2 7290 CurlBasis(k,1) = (sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * u * w + & 7291 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 ) 7292 CurlBasis(k,2) = -(sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * & 7293 v * w + 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / & 7294 ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 ) 7295 CurlBasis(k,3) = 0.0d0 7296 IF (nj<ni) THEN 7297 EdgeBasis(k,:) = -EdgeBasis(k,:) 7298 CurlBasis(k,:) = -CurlBasis(k,:) 7299 EdgeSign(k) = -1.0d0 7300 END IF 7301 7302 EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(3)+LBasis(1) ) 7303 7304 CurlBasis(k+1,1) = -0.3D1 / 0.8D1 * (0.9D1 * sqrt(0.2D1) * u * w ** 2 + & 7305 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 + & 7306 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w - & 7307 0.8D1 * u * v * w - 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) + & 7308 0.6D1 * v * sqrt(0.2D1) - 0.24D2 * u * w - 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - & 7309 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)**2 7310 CurlBasis(k+1,2) = 0.3D1 / 0.8D1 * (0.3D1 * sqrt(0.2D1) * u * w ** 2 + & 7311 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) + & 7312 0.4D1 * sqrt(0.2D1) * v ** 2 + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u *v * w - & 7313 0.4D1 * v ** 2 * w - 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) + 0.6D1 * v * sqrt(0.2D1) - & 7314 0.12D2 * u * w - 0.24D2 * v * w + 0.2D1 * sqrt(0.2D1) - 0.16D2 * w) / & 7315 (w * sqrt(0.2D1) - 0.2D1) ** 2 7316 CurlBasis(k+1,3) = -0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u - v) / (w * sqrt(0.2D1) - 0.2D1) 7317 7318 7319 ! Edge 45: 7320 !-------------------------------------------------------------- 7321 k = 15 ! k=8 for first-order 7322 i = EdgeMap(8,1) 7323 j = EdgeMap(8,2) 7324 ni = Element % NodeIndexes(i) 7325 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7326 nj = Element % NodeIndexes(j) 7327 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7328 7329 EdgeBasis(k,1) = w * sqrt(0.2D1) / 0.8D1 * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / & 7330 (w * sqrt(0.2D1) - 0.2D1) 7331 EdgeBasis(k,2) = -w * sqrt(0.2D1) / 0.8D1 * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / & 7332 (w * sqrt(0.2D1) - 0.2D1) 7333 EdgeBasis(k,3) = sqrt(0.2D1) / 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w + & 7334 0.2D1 * sqrt(0.2D1) * u * w - 0.2D1 * sqrt(0.2D1) * v * w - u * w ** 2 + v * w ** 2 - & 7335 0.2D1 * w * sqrt(0.2D1) - 0.2D1 * u * v + w ** 2 - 0.2D1 * u + 0.2D1 * v + 0.2D1) / & 7336 (w * sqrt(0.2D1) - 0.2D1) ** 2 7337 CurlBasis(k,1) = -(-sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * u * w - & 7338 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1)** 2 * 0.2D1 ) 7339 CurlBasis(k,2) = (sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * v * w + & 7340 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1)** 2 * 0.2D1 ) 7341 CurlBasis(k,3) = 0.0d0 7342 IF (nj<ni) THEN 7343 EdgeBasis(k,:) = -EdgeBasis(k,:) 7344 CurlBasis(k,:) = -CurlBasis(k,:) 7345 EdgeSign(k) = -1.0d0 7346 END IF 7347 7348 EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(4)+LBasis(2) ) 7349 7350 CurlBasis(k+1,1) = -0.3D1 / 0.8D1 * (-0.9D1 * sqrt(0.2D1) * u * w ** 2 + & 7351 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - & 7352 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u** 2 * w + & 7353 0.8D1 * u * v * w - 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + & 7354 0.6D1 * v * sqrt(0.2D1) + 0.24D2 * u * w - 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - & 7355 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1) ** 2 7356 CurlBasis(k+1,2) = 0.3D1 / 0.8D1 * (0.3D1 * sqrt(0.2D1) * u * w ** 2 - & 7357 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) - & 7358 0.4D1 * sqrt(0.2D1) * v ** 2 - 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u *v * w + & 7359 0.4D1 * v ** 2 * w + 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) - & 7360 0.6D1 * v * sqrt(0.2D1) - 0.12D2 * u * w + 0.24D2 * v * w - 0.2D1 * sqrt(0.2D1) + & 7361 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)**2 7362 CurlBasis(k+1,3) = -0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u + v) / (w * sqrt(0.2D1) - 0.2D1) 7363 7364 7365 ! Square face: 7366 ! ------------------------------------------------------------------ 7367 SquareFaceMap(:) = (/ 1,2,3,4 /) 7368 7369 WorkBasis(1,1:3) = 2.0d0 * ( EdgeSign(1) * EdgeBasis(1,1:3) * Beta(4) + & 7370 EdgeSign(5) * EdgeBasis(5,1:3) * Beta(2) ) / (1.0d0 - LBasis(5)) 7371 WorkCurlBasis(1,1) = -0.2D1 * u * v * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) ** 2 7372 WorkCurlBasis(1,2) = -(sqrt(0.2D1) * w ** 2 + 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / & 7373 (w * sqrt(0.2D1) - 0.2D1) ** 2 7374 WorkCurlBasis(1,3) = -0.2D1 * v / (w * sqrt(0.2D1) - 0.2D1) 7375 7376 WorkBasis(2,1:3) = 3.0d0 * WorkBasis(1,1:3) * u 7377 WorkCurlBasis(2,1) = -0.6D1 * u ** 2 * sqrt(0.2D1) * v / (w * sqrt(0.2D1) - 0.2D1)** 2 7378 WorkCurlBasis(2,2) = 0.3D1 / 0.2D1 * u * (0.2D1 * sqrt(0.2D1) * v ** 2 - & 7379 0.3D1 * sqrt(0.2D1) * w ** 2 - 0.6D1 * sqrt(0.2D1) + 0.12D2 * w) / & 7380 (w * sqrt(0.2D1) - 0.2D1) ** 2 7381 WorkCurlBasis(2,3) = -0.6D1 * u * v / (w * sqrt(0.2D1) - 0.2D1) 7382 7383 WorkBasis(3,1:3) = 2.0d0 * ( EdgeSign(3) * EdgeBasis(3,1:3) * Beta(1) + & 7384 EdgeSign(7) * EdgeBasis(7,1:3) * Beta(3) ) / (1.0d0 - LBasis(5)) 7385 WorkCurlBasis(3,1) = (sqrt(0.2D1) * w ** 2 + 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / & 7386 (w * sqrt(0.2D1) - 0.2D1) ** 2 7387 WorkCurlBasis(3,2) = 0.2D1 * u * v * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) ** 2 7388 WorkCurlBasis(3,3) = 0.2D1 * u / (w * sqrt(0.2D1) - 0.2D1) 7389 7390 WorkBasis(4,1:3) = 3.0d0 * WorkBasis(3,1:3) * v 7391 WorkCurlBasis(4,1) = -0.3D1 / 0.2D1 * v * (0.2D1 * sqrt(0.2D1) * u ** 2 - & 7392 0.3D1 * sqrt(0.2D1) * w ** 2 - 0.6D1 * sqrt(0.2D1) + 0.12D2 * w) / & 7393 (w * sqrt(0.2D1) - 0.2D1) ** 2 7394 WorkCurlBasis(4,2) = 0.6D1 * sqrt(0.2D1) * v ** 2 * u / (w * sqrt(0.2D1) - 0.2D1)**2 7395 WorkCurlBasis(4,3) = 0.6D1 * u * v / (w * sqrt(0.2D1) - 0.2D1) 7396 7397 ! ------------------------------------------------------------------- 7398 ! Finally apply an order change and sign reversions if needed. 7399 ! ------------------------------------------------------------------- 7400 DO j=1,4 7401 FaceIndices(j) = Ind(SquareFaceMap(j)) 7402 END DO 7403 IF (Parallel) THEN 7404 DO j=1,4 7405 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 7406 END DO 7407 END IF 7408 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7409 7410 EdgeBasis(17,:) = D1 * WorkBasis(2*(I1-1)+1,:) 7411 CurlBasis(17,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 7412 EdgeBasis(18,:) = WorkBasis(2*(I1-1)+2,:) 7413 CurlBasis(18,:) = WorkCurlBasis(2*(I1-1)+2,:) 7414 EdgeBasis(19,:) = D2 * WorkBasis(2*(I2-1)+1,:) 7415 CurlBasis(19,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 7416 EdgeBasis(20,:) = WorkBasis(2*(I2-1)+2,:) 7417 CurlBasis(20,:) = WorkCurlBasis(2*(I2-1)+2,:) 7418 7419 7420 !------------------------------------------------- 7421 ! Two basis functions defined on the face 125: 7422 !------------------------------------------------- 7423 TriangleFaceMap(:) = (/ 1,2,5 /) 7424 7425 DO j=1,3 7426 FaceIndices(j) = Ind(TriangleFaceMap(j)) 7427 END DO 7428 IF (Parallel) THEN 7429 DO j=1,3 7430 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 7431 END DO 7432 END IF 7433 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7434 7435 WorkBasis(1,1:3) = LBasis(5) * EdgeSign(1) * EdgeBasis(1,1:3) 7436 WorkCurlBasis(1,1) = w * u / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1 7437 WorkCurlBasis(1,2) = (-0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - & 7438 0.4D1 * v * w - 0.2D1 * sqrt(0.2D1) + 0.8D1 * w) / & 7439 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7440 WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1 7441 7442 WorkBasis(2,1:3) = Beta(3) * EdgeSign(9) * EdgeBasis(9,1:3) 7443 WorkCurlBasis(2,1) = (sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - & 7444 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 - & 7445 0.2D1 * u * w - 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / & 7446 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7447 WorkCurlBasis(2,2) = -(-0.3D1 * sqrt(0.2D1) * u * w ** 2 + 0.2D1 * sqrt(0.2D1) * & 7448 v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) - 0.7D1 * sqrt(0.2D1) * w ** 2 - & 7449 0.8D1 * u * v * w + 0.3D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + 0.2D1 * v * sqrt(0.2D1) + & 7450 0.12D2 * u * w - 0.6D1 * v * w - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / & 7451 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1)**2 ) 7452 WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / & 7453 ( (w * sqrt(0.2D1) - 0.2D1) * 0.16D2 ) 7454 7455 WorkBasis(3,1:3) = Beta(1) * EdgeSign(11) * EdgeBasis(11,1:3) 7456 WorkCurlBasis(3,1) = (-sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - & 7457 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 + & 7458 0.2D1 * u * w - 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / & 7459 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1)** 2 ) 7460 WorkCurlBasis(3,2) = -(-0.3D1 * sqrt(0.2D1) * u * w ** 2 - 0.2D1 * sqrt(0.2D1) * v * w ** 2 + & 7461 0.6D1 * u * v * sqrt(0.2D1) + 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w - & 7462 0.3D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) - 0.2D1 * v * sqrt(0.2D1) + 0.12D2 * u * w + & 7463 0.6D1 * v * w + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / & 7464 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1)**2 ) 7465 WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 7466 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7467 7468 EdgeBasis(21,:) = D1 * WorkBasis(I1,:) 7469 CurlBasis(21,:) = D1 * WorkCurlBasis(I1,:) 7470 EdgeBasis(22,:) = D2 * WorkBasis(I2,:) 7471 CurlBasis(22,:) = D2 * WorkCurlBasis(I2,:) 7472 7473 !------------------------------------------------- 7474 ! Two basis functions defined on the face 235: 7475 !------------------------------------------------- 7476 TriangleFaceMap(:) = (/ 2,3,5 /) 7477 7478 DO j=1,3 7479 FaceIndices(j) = Ind(TriangleFaceMap(j)) 7480 END DO 7481 IF (Parallel) THEN 7482 DO j=1,3 7483 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 7484 END DO 7485 END IF 7486 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7487 7488 WorkBasis(1,1:3) = LBasis(5) * EdgeSign(3) * EdgeBasis(3,1:3) 7489 WorkCurlBasis(1,1) = (0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.4D1 * u * w + & 7490 0.2D1 * sqrt(0.2D1) - 0.8D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) 7491 WorkCurlBasis(1,2) = w * v / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1 7492 WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1 7493 7494 WorkBasis(2,1:3) = Beta(4) * EdgeSign(11) * EdgeBasis(11,1:3) 7495 WorkCurlBasis(2,1) = -(0.2D1 * sqrt(0.2D1) * u * w ** 2 + 0.3D1 * sqrt(0.2D1) * v * w ** 2 + & 7496 0.6D1 * sqrt(0.2D1) * u * v + 0.7D1 * sqrt(0.2D1) * w** 2 - 0.8D1 * u * v * w - & 7497 0.3D1 * w ** 3 + 0.2D1 * u * sqrt(0.2D1) + 0.6D1 * v * sqrt(0.2D1) - 0.6D1 * u * w - & 7498 0.12D2 * w * v + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / & 7499 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2) 7500 WorkCurlBasis(2,2) = (sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - & 7501 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 - 0.2D1 * w * v - & 7502 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7503 WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / & 7504 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7505 7506 WorkBasis(3,1:3) = Beta(2) * EdgeSign(13) * EdgeBasis(13,1:3) 7507 WorkCurlBasis(3,1) = -(-0.2D1 * sqrt(0.2D1) * u * w ** 2 + 0.3D1 * sqrt(0.2D1) * v * w ** 2 + & 7508 0.6D1 * sqrt(0.2D1) * u * v - 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + & 7509 0.3D1 * w ** 3 - 0.2D1 * u * sqrt(0.2D1) + 0.6D1 * v * sqrt(0.2D1) + 0.6D1 * u * w - & 7510 0.12D2 * w * v - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / & 7511 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7512 WorkCurlBasis(3,2) = (-sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - & 7513 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 + 0.2D1 * w * v - & 7514 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7515 WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / & 7516 ( (w * sqrt(0.2D1) - 0.2D1) * 0.16D2 ) 7517 7518 EdgeBasis(23,:) = D1 * WorkBasis(I1,:) 7519 CurlBasis(23,:) = D1 * WorkCurlBasis(I1,:) 7520 EdgeBasis(24,:) = D2 * WorkBasis(I2,:) 7521 CurlBasis(24,:) = D2 * WorkCurlBasis(I2,:) 7522 7523 !------------------------------------------------- 7524 ! Two basis functions defined on the face 345: 7525 !------------------------------------------------- 7526 TriangleFaceMap(:) = (/ 3,4,5 /) 7527 7528 DO j=1,3 7529 FaceIndices(j) = Ind(TriangleFaceMap(j)) 7530 END DO 7531 IF (Parallel) THEN 7532 DO j=1,3 7533 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 7534 END DO 7535 END IF 7536 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7537 7538 WorkBasis(1,1:3) = -LBasis(5) * EdgeSign(5) * EdgeBasis(5,1:3) 7539 WorkCurlBasis(1,1) = w * u / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1 7540 WorkCurlBasis(1,2) = (0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.4D1 * w * v + & 7541 0.2D1 * sqrt(0.2D1) - 0.8D1 * w) / (0.8D1 * (w * sqrt(0.2D1)- 0.2D1) ) 7542 WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1 7543 7544 WorkBasis(2,1:3) = Beta(1) * EdgeSign(13) * EdgeBasis(13,1:3) 7545 WorkCurlBasis(2,1) = -(-sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - & 7546 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 + 0.2D1 * u * w - & 7547 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7548 WorkCurlBasis(2,2) = (0.3D1 * sqrt(0.2D1) * u * w ** 2 - 0.2D1 * sqrt(0.2D1) * v * w ** 2 + & 7549 0.6D1 * sqrt(0.2D1) * u * v - 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + & 7550 0.3D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) - 0.2D1 * v * sqrt(0.2D1) - 0.12D2 * u * w + & 7551 0.6D1 * w * v - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / & 7552 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7553 WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 7554 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7555 7556 WorkBasis(3,1:3) = Beta(3) * EdgeSign(15) * EdgeBasis(15,1:3) 7557 WorkCurlBasis(3,1) = -(sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - & 7558 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 - 0.2D1 * u * w - & 7559 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7560 WorkCurlBasis(3,2) = (0.3D1 * sqrt(0.2D1) * u * w ** 2 + 0.2D1 * sqrt(0.2D1) * v * w ** 2 + & 7561 0.6D1 * sqrt(0.2D1) * u * v + 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w - & 7562 0.3D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) + 0.2D1 * v * sqrt(0.2D1) - 0.12D2 * u * w - & 7563 0.6D1 * w * v + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / & 7564 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7565 WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / & 7566 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7567 7568 EdgeBasis(25,:) = D1 * WorkBasis(I1,:) 7569 CurlBasis(25,:) = D1 * WorkCurlBasis(I1,:) 7570 EdgeBasis(26,:) = D2 * WorkBasis(I2,:) 7571 CurlBasis(26,:) = D2 * WorkCurlBasis(I2,:) 7572 7573 !------------------------------------------------- 7574 ! Two basis functions defined on the face 415: 7575 !------------------------------------------------- 7576 TriangleFaceMap(:) = (/ 4,1,5 /) 7577 7578 DO j=1,3 7579 FaceIndices(j) = Ind(TriangleFaceMap(j)) 7580 END DO 7581 IF (Parallel) THEN 7582 DO j=1,3 7583 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 7584 END DO 7585 END IF 7586 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7587 7588 WorkBasis(1,1:3) = -LBasis(5) * EdgeSign(7) * EdgeBasis(7,1:3) 7589 WorkCurlBasis(1,1) = (-0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - & 7590 0.4D1 * u * w - 0.2D1 * sqrt(0.2D1) + 0.8D1 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ) 7591 WorkCurlBasis(1,2) = w * v / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1 7592 WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1 7593 7594 WorkBasis(2,1:3) = Beta(2) * EdgeSign(15) * EdgeBasis(15,1:3) 7595 WorkCurlBasis(2,1) = (-0.2D1 * sqrt(0.2D1) * u * w ** 2 - 0.3D1 * sqrt(0.2D1) * v * w ** 2 + & 7596 0.6D1 * sqrt(0.2D1) * u * v + 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w - & 7597 0.3D1 * w ** 3 - 0.2D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) + 0.6D1 * u * w + & 7598 0.12D2 * w * v + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / & 7599 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7600 WorkCurlBasis(2,2) = -(-sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - & 7601 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 + 0.2D1 * w * v - & 7602 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7603 WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / & 7604 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7605 7606 WorkBasis(3,1:3) = Beta(4) * EdgeSign(9) * EdgeBasis(9,1:3) 7607 WorkCurlBasis(3,1) = (0.2D1 * sqrt(0.2D1) * u * w ** 2 - 0.3D1 * sqrt(0.2D1) * v * w ** 2 + & 7608 0.6D1 * sqrt(0.2D1) * u * v - 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + & 7609 0.3D1 * w ** 3 + 0.2D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) - 0.6D1 * u * w + & 7610 0.12D2 * w * v - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / & 7611 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7612 WorkCurlBasis(3,2) = -(sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - & 7613 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 - 0.2D1 * w * v - & 7614 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7615 WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / & 7616 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7617 7618 EdgeBasis(27,:) = D1 * WorkBasis(I1,:) 7619 CurlBasis(27,:) = D1 * WorkCurlBasis(I1,:) 7620 EdgeBasis(28,:) = D2 * WorkBasis(I2,:) 7621 CurlBasis(28,:) = D2 * WorkCurlBasis(I2,:) 7622 7623 7624 ! Finally three interior basis functions: 7625 ! ----------------------------------------------------------------------------------- 7626 EdgeBasis(29,1:3) = LBasis(5) * Beta(4) * EdgeSign(1) * EdgeBasis(1,1:3) 7627 CurlBasis(29,1) = u * v * w / (0.4D1 * (w * sqrt(0.2D1) - 0.2D1) ) 7628 CurlBasis(29,2) = (0.2D1 * sqrt(0.2D1) * v ** 2 - 0.9D1 * sqrt(0.2D1) * w ** 2 - & 7629 0.4D1 * v ** 2 * w + 0.4D1 * w ** 3 - 0.2D1 * sqrt(0.2D1) + 0.12D2 * w) / & 7630 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7631 CurlBasis(29,3) = sqrt(0.2D1) * v * w / 0.8D1 7632 7633 EdgeBasis(30,1:3) = LBasis(5) * Beta(3) * EdgeSign(7) * EdgeBasis(7,1:3) 7634 CurlBasis(30,1) = -(0.2D1 * sqrt(0.2D1) * u ** 2 - 0.9D1 * sqrt(0.2D1) * w **2 - & 7635 0.4D1 * u ** 2 * w + 0.4D1 * w ** 3 - 0.2D1 * sqrt(0.2D1) + 0.12D2 * w) / & 7636 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 7637 CurlBasis(30,2) = -u * v * w / (0.4D1* (w * sqrt(0.2D1) - 0.2D1) ) 7638 CurlBasis(30,3) = -sqrt(0.2D1) * u * w / 0.8D1 7639 7640 EdgeBasis(31,1:3) = Beta(3) * Beta(4) * EdgeSign(9) * EdgeBasis(9,1:3) 7641 CurlBasis(31,1) = (0.2D1 * sqrt(0.2D1) * u ** 2 * w ** 2 + 0.2D1 * sqrt(0.2D1) * u * v * w ** 2 -& 7642 0.2D1 * sqrt(0.2D1) * w ** 4 + 0.6D1 * sqrt(0.2D1) * u ** 2 * v - & 7643 0.11D2 * sqrt(0.2D1) * v * w ** 2 - 0.8D1 * u ** 2 * v * w + 0.4D1 * v * w ** 3 + & 7644 0.2D1 * sqrt(0.2D1) * u ** 2 - 0.15D2 * sqrt(0.2D1) * w ** 2 - 0.6D1 * u ** 2 * w - & 7645 0.4D1 * u * v * w + 0.13D2 * w ** 3 - 0.6D1 * v * sqrt(0.2D1) + 0.20D2 * w * v - & 7646 0.2D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7647 CurlBasis(31,2) = -(0.2D1 * sqrt(0.2D1) * u * v * w ** 2 + 0.2D1 * sqrt(0.2D1) * v ** 2 * w**2 - & 7648 0.2D1 * sqrt(0.2D1) * w ** 4 + 0.6D1 * sqrt(0.2D1) * u * v ** 2 - & 7649 0.11D2 * sqrt(0.2D1) * u * w ** 2 - 0.8D1 * u * v ** 2 * w + 0.4D1 * u * w ** 3 + & 7650 0.2D1 * sqrt(0.2D1) * v ** 2 - 0.15D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u * v * w - & 7651 0.6D1 * v ** 2 * w + 0.13D2 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + 0.20D2 * u *w - & 7652 0.2D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 7653 CurlBasis(31,3) = -(u - v) * w * sqrt(0.2D1) / 0.16D2 7654 7655 ELSE 7656 !----------------------------------------------------------------------------------------- 7657 ! The lowest-order pyramid from the optimal family. Now these basis functions are 7658 ! also contained in the set of hierarchic basis functions, so this branch could be 7659 ! removed by making some code modifications (to do?). 7660 !----------------------------------------------------------------------------------------- 7661 i = EdgeMap(1,1) 7662 j = EdgeMap(1,2) 7663 ni = Element % NodeIndexes(i) 7664 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7665 nj = Element % NodeIndexes(j) 7666 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7667 EdgeBasis(1,1) = (v*(-1 + (2*v)/(2 - Sqrt(2.0d0)*w)))/4.0d0 7668 EdgeBasis(1,2) = 0.0d0 7669 EdgeBasis(1,3) = (u*v*(-Sqrt(2.0d0) + Sqrt(2.0d0)*v + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7670 CurlBasis(1,1) = (u*(-Sqrt(2.0d0) + 2*Sqrt(2.0d0)*v + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7671 CurlBasis(1,2) = (v*(Sqrt(2.0d0) - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7672 CurlBasis(1,3) = (-2 + 4*v + Sqrt(2.0d0)*w)/(-8 + 4*Sqrt(2.0d0)*w) 7673 IF (nj<ni) THEN 7674 EdgeBasis(1,:) = -EdgeBasis(1,:) 7675 CurlBasis(1,:) = -CurlBasis(1,:) 7676 END IF 7677 7678 i = EdgeMap(2,1) 7679 j = EdgeMap(2,2) 7680 ni = Element % NodeIndexes(i) 7681 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7682 nj = Element % NodeIndexes(j) 7683 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7684 EdgeBasis(2,1) = 0.0d0 7685 EdgeBasis(2,2) = (u*(1 + (2*u)/(2 - Sqrt(2.0d0)*w)))/4.0d0 7686 EdgeBasis(2,3) = (u*v*(Sqrt(2.0d0) + Sqrt(2.0d0)*u - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7687 CurlBasis(2,1) = (u*(Sqrt(2.0d0) - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7688 CurlBasis(2,2) = -(v*(Sqrt(2.0d0) + 2*Sqrt(2.0d0)*u - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7689 CurlBasis(2,3) = (2 + 4*u - Sqrt(2.0d0)*w)/(8 - 4*Sqrt(2.0d0)*w) 7690 IF (nj<ni) THEN 7691 EdgeBasis(2,:) = -EdgeBasis(2,:) 7692 CurlBasis(2,:) = -CurlBasis(2,:) 7693 END IF 7694 7695 i = EdgeMap(3,1) 7696 j = EdgeMap(3,2) 7697 ni = Element % NodeIndexes(i) 7698 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7699 nj = Element % NodeIndexes(j) 7700 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7701 EdgeBasis(3,1) = (v*(1 + (2*v)/(2 - Sqrt(2.0d0)*w)))/4.0d0 7702 EdgeBasis(3,2) = 0.0d0 7703 EdgeBasis(3,3) = (u*v*(Sqrt(2.0d0) + Sqrt(2.0d0)*v - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7704 CurlBasis(3,1) = (u*(Sqrt(2.0d0) + 2*Sqrt(2.0d0)*v - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7705 CurlBasis(3,2) = (v*(-Sqrt(2.0d0) + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7706 CurlBasis(3,3) = (2 + 4*v - Sqrt(2.0d0)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7707 IF (nj<ni) THEN 7708 EdgeBasis(3,:) = -EdgeBasis(3,:) 7709 CurlBasis(3,:) = -CurlBasis(3,:) 7710 END IF 7711 7712 i = EdgeMap(4,1) 7713 j = EdgeMap(4,2) 7714 ni = Element % NodeIndexes(i) 7715 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7716 nj = Element % NodeIndexes(j) 7717 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7718 EdgeBasis(4,1) = 0.0d0 7719 EdgeBasis(4,2) = (u*(-1 + (2*u)/(2 - Sqrt(2.0d0)*w)))/4.0d0 7720 EdgeBasis(4,3) = (u*v*(-Sqrt(2.0d0) + Sqrt(2.0d0)*u + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7721 CurlBasis(4,1) = (u*(-Sqrt(2.0d0) + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7722 CurlBasis(4,2) = -(v*(-Sqrt(2.0d0) + 2*Sqrt(2.0d0)*u + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7723 CurlBasis(4,3) = (2 - 4*u - Sqrt(2.0d0)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7724 IF (nj<ni) THEN 7725 EdgeBasis(4,:) = -EdgeBasis(4,:) 7726 CurlBasis(4,:) = -CurlBasis(4,:) 7727 END IF 7728 7729 i = EdgeMap(5,1) 7730 j = EdgeMap(5,2) 7731 ni = Element % NodeIndexes(i) 7732 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7733 nj = Element % NodeIndexes(j) 7734 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7735 EdgeBasis(5,1) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*v + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7736 EdgeBasis(5,2) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*u + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7737 EdgeBasis(5,3) = (u*(-2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - 2*w) + 4*w - Sqrt(2.0d0)*w**2) - & 7738 (-1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2))/(4.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7739 CurlBasis(5,1) = (-2*Sqrt(2.0d0) + 2*u*(Sqrt(2.0d0) - w) + 4*w - Sqrt(2.0d0)*w**2)/ & 7740 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7741 CurlBasis(5,2) = (2*Sqrt(2.0d0) - 2*Sqrt(2.0d0)*v - 4*w + 2*v*w + Sqrt(2.0d0)*w**2)/ & 7742 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7743 CurlBasis(5,3) = 0.0d0 7744 IF (nj<ni) THEN 7745 EdgeBasis(5,:) = -EdgeBasis(5,:) 7746 CurlBasis(5,:) = -CurlBasis(5,:) 7747 END IF 7748 7749 i = EdgeMap(6,1) 7750 j = EdgeMap(6,2) 7751 ni = Element % NodeIndexes(i) 7752 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7753 nj = Element % NodeIndexes(j) 7754 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7755 EdgeBasis(6,1) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*v + w))/(8.0d0 - 4*Sqrt(2.0d0)*w) 7756 EdgeBasis(6,2) = (w*(-Sqrt(2.0d0) - Sqrt(2.0d0)*u + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7757 EdgeBasis(6,3) = (-((-1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2)) + & 7758 u*(2*Sqrt(2.0d0) - 2*Sqrt(2.0d0)*v - 4*w + 4*v*w + Sqrt(2.0d0)*w**2))/ & 7759 (4.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7760 CurlBasis(6,1) = -(2*Sqrt(2.0d0) + 2*u*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ & 7761 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7762 CurlBasis(6,2) = (-2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - w) + 4*w - Sqrt(2.0d0)*w**2)/ & 7763 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7764 CurlBasis(6,3) = 0.0d0 7765 IF (nj<ni) THEN 7766 EdgeBasis(6,:) = -EdgeBasis(6,:) 7767 CurlBasis(6,:) = -CurlBasis(6,:) 7768 END IF 7769 7770 i = EdgeMap(7,1) 7771 j = EdgeMap(7,2) 7772 ni = Element % NodeIndexes(i) 7773 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7774 nj = Element % NodeIndexes(j) 7775 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7776 EdgeBasis(7,1) = ((Sqrt(2.0d0) + Sqrt(2.0d0)*v - w)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7777 EdgeBasis(7,2) = ((Sqrt(2.0d0) + Sqrt(2.0d0)*u - w)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7778 EdgeBasis(7,3) = ((1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2) + & 7779 u*(2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - 2*w) - 4*w + Sqrt(2.0d0)*w**2))/ & 7780 (4.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7781 CurlBasis(7,1) = (2*Sqrt(2.0d0) + 2*u*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ & 7782 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7783 CurlBasis(7,2) = -(2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ & 7784 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 7785 CurlBasis(7,3) = 0.0d0 7786 IF (nj<ni) THEN 7787 EdgeBasis(7,:) = -EdgeBasis(7,:) 7788 CurlBasis(7,:) = -CurlBasis(7,:) 7789 END IF 7790 7791 i = EdgeMap(8,1) 7792 j = EdgeMap(8,2) 7793 ni = Element % NodeIndexes(i) 7794 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7795 nj = Element % NodeIndexes(j) 7796 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7797 EdgeBasis(8,1) = (w*(-Sqrt(2.0d0) - Sqrt(2.0d0)*v + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w) 7798 EdgeBasis(8,2) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*u + w))/(8.0d0 - 4*Sqrt(2.0d0)*w) 7799 EdgeBasis(8,3) = ((1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2) - & 7800 u*(2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - 2*w) - 4*w + Sqrt(2.0d0)*w**2))/ & 7801 (4.0d0*(-2.0d0 + Sqrt(2.0d0)*w)**2) 7802 CurlBasis(8,1) = (2*Sqrt(2.0d0) - 2*Sqrt(2.0d0)*u - 4*w + 2*u*w + Sqrt(2.0d0)*w**2)/ & 7803 (2.0d0*(-2.0d0 + Sqrt(2.0d0)*w)**2) 7804 CurlBasis(8,2) = (2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ & 7805 (2.0d0*(-2.0d0 + Sqrt(2.0d0)*w)**2) 7806 CurlBasis(8,3) = 0.0d0 7807 IF (nj<ni) THEN 7808 EdgeBasis(8,:) = -EdgeBasis(8,:) 7809 CurlBasis(8,:) = -CurlBasis(8,:) 7810 END IF 7811 7812 ! ------------------------------------------------------------------ 7813 ! The last two basis functions are associated with the square face. 7814 ! We first create the basis function in the default order without 7815 ! sign reversions. 7816 ! ------------------------------------------------------------------ 7817 SquareFaceMap(:) = (/ 1,2,3,4 /) 7818 Ind => Element % Nodeindexes 7819 7820 WorkBasis(1,1) = (2.0d0 - 2*v**2 - 2*Sqrt(2.0d0)*w + w**2)/(4.0d0 - 2*Sqrt(2.0d0)*w) 7821 WorkBasis(1,2) = 0.0d0 7822 WorkBasis(1,3) = (u*(1.0d0 - (4*v**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2))/(2.0d0*Sqrt(2.0d0)) 7823 WorkCurlBasis(1,1) = (-2*Sqrt(2.0d0)*u*v)/(-2.0d0 + Sqrt(2.0d0)*w)**2 7824 WorkCurlBasis(1,2) = (-2*Sqrt(2.0d0) + 4*w - Sqrt(2.0d0)*w**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2 7825 WorkCurlBasis(1,3) = (2.0d0*v)/(2.0d0 - Sqrt(2.0d0)*w) 7826 7827 WorkBasis(2,1) = 0.0d0 7828 WorkBasis(2,2) = (2.0d0 - 2*u**2 - 2*Sqrt(2.0d0)*w + w**2)/(4.0d0 - 2*Sqrt(2.0d0)*w) 7829 WorkBasis(2,3) = (v*(1.0d0 - (4*u**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2))/(2.0d0*Sqrt(2.0d0)) 7830 WorkCurlBasis(2,1) = (2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2 7831 WorkCurlBasis(2,2) = (2*Sqrt(2.0d0)*u*v)/(-2.0d0 + Sqrt(2.0d0)*w)**2 7832 WorkCurlBasis(2,3) = (2*u)/(-2.0d0 + Sqrt(2.0d0)*w) 7833 7834 ! ------------------------------------------------------------------- 7835 ! Finally apply an order change and sign reversions if needed. 7836 ! ------------------------------------------------------------------- 7837 DO j=1,4 7838 FaceIndices(j) = Ind(SquareFaceMap(j)) 7839 END DO 7840 IF (Parallel) THEN 7841 DO j=1,4 7842 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 7843 END DO 7844 END IF 7845 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 7846 7847 EdgeBasis(9,:) = D1 * WorkBasis(I1,:) 7848 CurlBasis(9,:) = D1 * WorkCurlBasis(I1,:) 7849 EdgeBasis(10,:) = D2 * WorkBasis(I2,:) 7850 CurlBasis(10,:) = D2 * WorkCurlBasis(I2,:) 7851 END IF 7852 7853 CASE(7) 7854 !-------------------------------------------------------------- 7855 ! This branch is for handling prismatic (or wedge) elements 7856 !-------------------------------------------------------------- 7857 EdgeMap => GetEdgeMap(7) 7858 Ind => Element % Nodeindexes 7859 7860 IF (SecondOrder) THEN 7861 !--------------------------------------------------------------- 7862 ! The second-order element from the Nedelec's first family 7863 ! (note that the lowest-order prism element is from a different 7864 ! family). This element may not be optimally accurate if 7865 ! the physical element is not affine. 7866 !-------------------------------------------------------------- 7867 h1 = 0.5d0 * (1-w) 7868 dh1 = -0.5d0 7869 h2 = 0.5d0 * (1+w) 7870 dh2 = 0.5d0 7871 h3 = h1 * h2 7872 dh3 = -0.5d0 * w 7873 7874 ! --------------------------------------------------------- 7875 ! The first and fourth edges ... 7876 !-------------------------------------------------------- 7877 ! The corresponding basis functions for the triangle: 7878 !-------------------------------------------------------- 7879 WorkBasis(1,1) = (3.0d0 - Sqrt(3.0d0)*v)/6.0d0 7880 WorkBasis(1,2) = u/(2.0d0*Sqrt(3.0d0)) 7881 WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) 7882 WorkBasis(2,1) = -(u*(-3.0d0 + Sqrt(3.0d0)*v))/2.0d0 7883 WorkBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0 7884 WorkCurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0 7885 7886 i = EdgeMap(1,1) 7887 j = EdgeMap(1,2) 7888 ni = Element % NodeIndexes(i) 7889 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7890 nj = Element % NodeIndexes(j) 7891 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7892 EdgeBasis(1,1:2) = WorkBasis(1,1:2) * h1 7893 CurlBasis(1,1) = -WorkBasis(1,2) * dh1 7894 CurlBasis(1,2) = WorkBasis(1,1) * dh1 7895 CurlBasis(1,3) = WorkCurlBasis(1,3) * h1 7896 EdgeBasis(2,1:2) = WorkBasis(2,1:2) * h1 7897 CurlBasis(2,1) = -WorkBasis(2,2) * dh1 7898 CurlBasis(2,2) = WorkBasis(2,1) * dh1 7899 CurlBasis(2,3) = WorkCurlBasis(2,3) * h1 7900 IF (nj<ni) THEN 7901 EdgeBasis(1,1:2) = -EdgeBasis(1,1:2) 7902 CurlBasis(1,1:3) = -CurlBasis(1,1:3) 7903 END IF 7904 7905 i = EdgeMap(4,1) 7906 j = EdgeMap(4,2) 7907 ni = Element % NodeIndexes(i) 7908 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7909 nj = Element % NodeIndexes(j) 7910 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7911 EdgeBasis(7,1:2) = WorkBasis(1,1:2) * h2 7912 CurlBasis(7,1) = -WorkBasis(1,2) * dh2 7913 CurlBasis(7,2) = WorkBasis(1,1) * dh2 7914 CurlBasis(7,3) = WorkCurlBasis(1,3) * h2 7915 EdgeBasis(8,1:2) = WorkBasis(2,1:2) * h2 7916 CurlBasis(8,1) = -WorkBasis(2,2) * dh2 7917 CurlBasis(8,2) = WorkBasis(2,1) * dh2 7918 CurlBasis(8,3) = WorkCurlBasis(2,3) * h2 7919 IF (nj<ni) THEN 7920 EdgeBasis(7,1:2) = -EdgeBasis(7,1:2) 7921 CurlBasis(7,1:3) = -CurlBasis(7,1:3) 7922 END IF 7923 7924 ! --------------------------------------------------------- 7925 ! The second and fifth edges ... 7926 !-------------------------------------------------------- 7927 ! The corresponding basis functions for the triangle: 7928 !-------------------------------------------------------- 7929 WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0)) 7930 WorkBasis(1,2) = (1 + u)/(2.0d0*Sqrt(3.0d0)) 7931 WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) 7932 WorkBasis(2,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*v)/4.0d0 7933 WorkBasis(2,2) = (Sqrt(3.0d0)*(1.0d0 + u)*(-1.0d0 - u + Sqrt(3.0d0)*v))/4.0d0 7934 WorkCurlBasis(2,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0 7935 7936 i = EdgeMap(2,1) 7937 j = EdgeMap(2,2) 7938 ni = Element % NodeIndexes(i) 7939 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7940 nj = Element % NodeIndexes(j) 7941 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7942 EdgeBasis(3,1:2) = WorkBasis(1,1:2) * h1 7943 CurlBasis(3,1) = -WorkBasis(1,2) * dh1 7944 CurlBasis(3,2) = WorkBasis(1,1) * dh1 7945 CurlBasis(3,3) = WorkCurlBasis(1,3) * h1 7946 EdgeBasis(4,1:2) = WorkBasis(2,1:2) * h1 7947 CurlBasis(4,1) = -WorkBasis(2,2) * dh1 7948 CurlBasis(4,2) = WorkBasis(2,1) * dh1 7949 CurlBasis(4,3) = WorkCurlBasis(2,3) * h1 7950 IF (nj<ni) THEN 7951 EdgeBasis(3,1:2) = -EdgeBasis(3,1:2) 7952 CurlBasis(3,1:3) = -CurlBasis(3,1:3) 7953 END IF 7954 7955 i = EdgeMap(5,1) 7956 j = EdgeMap(5,2) 7957 ni = Element % NodeIndexes(i) 7958 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7959 nj = Element % NodeIndexes(j) 7960 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7961 EdgeBasis(9,1:2) = WorkBasis(1,1:2) * h2 7962 CurlBasis(9,1) = -WorkBasis(1,2) * dh2 7963 CurlBasis(9,2) = WorkBasis(1,1) * dh2 7964 CurlBasis(9,3) = WorkCurlBasis(1,3) * h2 7965 EdgeBasis(10,1:2) = WorkBasis(2,1:2) * h2 7966 CurlBasis(10,1) = -WorkBasis(2,2) * dh2 7967 CurlBasis(10,2) = WorkBasis(2,1) * dh2 7968 CurlBasis(10,3) = WorkCurlBasis(2,3) * h2 7969 IF (nj<ni) THEN 7970 EdgeBasis(9,1:2) = -EdgeBasis(9,1:2) 7971 CurlBasis(9,1:3) = -CurlBasis(9,1:3) 7972 END IF 7973 7974 ! --------------------------------------------------------- 7975 ! The third and sixth edges ... 7976 !-------------------------------------------------------- 7977 ! The corresponding basis functions for the triangle: 7978 !-------------------------------------------------------- 7979 WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0)) 7980 WorkBasis(1,2) = (-1 + u)/(2.0d0*Sqrt(3.0d0)) 7981 WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) 7982 WorkBasis(2,1) = (v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 7983 WorkBasis(2,2) = -(Sqrt(3.0d0)*(-1.0d0 + u)*(-1.0d0 + u + Sqrt(3.0d0)*v))/4.0d0 7984 WorkCurlBasis(2,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 7985 7986 i = EdgeMap(3,1) 7987 j = EdgeMap(3,2) 7988 ni = Element % NodeIndexes(i) 7989 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 7990 nj = Element % NodeIndexes(j) 7991 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 7992 EdgeBasis(5,1:2) = WorkBasis(1,1:2) * h1 7993 CurlBasis(5,1) = -WorkBasis(1,2) * dh1 7994 CurlBasis(5,2) = WorkBasis(1,1) * dh1 7995 CurlBasis(5,3) = WorkCurlBasis(1,3) * h1 7996 EdgeBasis(6,1:2) = WorkBasis(2,1:2) * h1 7997 CurlBasis(6,1) = -WorkBasis(2,2) * dh1 7998 CurlBasis(6,2) = WorkBasis(2,1) * dh1 7999 CurlBasis(6,3) = WorkCurlBasis(2,3) * h1 8000 IF (nj<ni) THEN 8001 EdgeBasis(5,1:2) = -EdgeBasis(5,1:2) 8002 CurlBasis(5,1:3) = -CurlBasis(5,1:3) 8003 END IF 8004 8005 i = EdgeMap(6,1) 8006 j = EdgeMap(6,2) 8007 ni = Element % NodeIndexes(i) 8008 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8009 nj = Element % NodeIndexes(j) 8010 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8011 EdgeBasis(11,1:2) = WorkBasis(1,1:2) * h2 8012 CurlBasis(11,1) = -WorkBasis(1,2) * dh2 8013 CurlBasis(11,2) = WorkBasis(1,1) * dh2 8014 CurlBasis(11,3) = WorkCurlBasis(1,3) * h2 8015 EdgeBasis(12,1:2) = WorkBasis(2,1:2) * h2 8016 CurlBasis(12,1) = -WorkBasis(2,2) * dh2 8017 CurlBasis(12,2) = WorkBasis(2,1) * dh2 8018 CurlBasis(12,3) = WorkCurlBasis(2,3) * h2 8019 IF (nj<ni) THEN 8020 EdgeBasis(11,1:2) = -EdgeBasis(11,1:2) 8021 CurlBasis(11,1:3) = -CurlBasis(11,1:3) 8022 END IF 8023 8024 ! ------------------------------------------------------- 8025 ! The edges 14, 25 and 36 8026 !-------------------------------------------------------- 8027 DO q = 1,3 8028 i = EdgeMap(6+q,1) 8029 j = EdgeMap(6+q,2) 8030 ni = Element % NodeIndexes(i) 8031 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8032 nj = Element % NodeIndexes(j) 8033 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8034 8035 grad(1:2) = dTriangleNodalPBasis(q, u, v) 8036 EdgeBasis(12+(q-1)*2+1,3) = 0.5d0 * TriangleNodalPBasis(q, u, v) 8037 CurlBasis(12+(q-1)*2+1,1) = 0.5d0* grad(2) 8038 CurlBasis(12+(q-1)*2+1,2) = -0.5d0* grad(1) 8039 EdgeBasis(12+(q-1)*2+2,3) = 3.0d0 * EdgeBasis(12+(q-1)*2+1,3) * w 8040 CurlBasis(12+(q-1)*2+2,1) = 1.5d0 * grad(2) * w 8041 CurlBasis(12+(q-1)*2+2,2) = -1.5d0 * grad(1) * w 8042 8043 IF (nj<ni) THEN 8044 EdgeBasis(12+(q-1)*2+1,3) = -EdgeBasis(12+(q-1)*2+1,3) 8045 CurlBasis(12+(q-1)*2+1,1:2) = -CurlBasis(12+(q-1)*2+1,1:2) 8046 END IF 8047 END DO 8048 8049 !------------------------------------------------- 8050 ! Two basis functions defined on the face 123: 8051 !------------------------------------------------- 8052 TriangleFaceMap(:) = (/ 1,2,3 /) 8053 8054 DO j=1,3 8055 FaceIndices(j) = Ind(TriangleFaceMap(j)) 8056 END DO 8057 IF (Parallel) THEN 8058 DO j=1,3 8059 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8060 END DO 8061 END IF 8062 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8063 8064 WorkBasis(1,1) = ((Sqrt(3.0d0) - v)*v)/6.0d0 8065 WorkBasis(1,2) = (u*v)/6.0d0 8066 WorkCurlBasis(1,3) = (-Sqrt(3.0d0) + 3.0d0*v)/6.0d0 8067 WorkBasis(2,1) = (v*(1.0d0 + u - v/Sqrt(3.0d0)))/(4.0d0*Sqrt(3.0d0)) 8068 WorkBasis(2,2) = ((-1.0d0 + u)*(-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) 8069 WorkCurlBasis(2,3) =(-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0 8070 WorkBasis(3,1) = (v*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) 8071 WorkBasis(3,2) = -((1.0d0 + u)*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) 8072 WorkCurlBasis(3,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0 8073 8074 EdgeBasis(19,1:2) = D1 * WorkBasis(I1,1:2) * h1 8075 CurlBasis(19,1) = -D1 * WorkBasis(I1,2) * dh1 8076 CurlBasis(19,2) = D1 * WorkBasis(I1,1) * dh1 8077 CurlBasis(19,3) = D1 * WorkCurlBasis(I1,3) * h1 8078 8079 EdgeBasis(20,1:2) = D2 * WorkBasis(I2,1:2) * h1 8080 CurlBasis(20,1) = -D2 * WorkBasis(I2,2) * dh1 8081 CurlBasis(20,2) = D2 * WorkBasis(I2,1) * dh1 8082 CurlBasis(20,3) = D2 * WorkCurlBasis(I2,3) * h1 8083 8084 !------------------------------------------------- 8085 ! Two basis functions defined on the face 456: 8086 !------------------------------------------------- 8087 TriangleFaceMap(:) = (/ 4,5,6 /) 8088 8089 DO j=1,3 8090 FaceIndices(j) = Ind(TriangleFaceMap(j)) 8091 END DO 8092 IF (Parallel) THEN 8093 DO j=1,3 8094 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8095 END DO 8096 END IF 8097 CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8098 8099 EdgeBasis(21,1:2) = D1 * WorkBasis(I1,1:2) * h2 8100 CurlBasis(21,1) = -D1 * WorkBasis(I1,2) * dh2 8101 CurlBasis(21,2) = D1 * WorkBasis(I1,1) * dh2 8102 CurlBasis(21,3) = D1 * WorkCurlBasis(I1,3) * h2 8103 8104 EdgeBasis(22,1:2) = D2 * WorkBasis(I2,1:2) * h2 8105 CurlBasis(22,1) = -D2 * WorkBasis(I2,2) * dh2 8106 CurlBasis(22,2) = D2 * WorkBasis(I2,1) * dh2 8107 CurlBasis(22,3) = D2 * WorkCurlBasis(I2,3) * h2 8108 8109 !------------------------------------------------- 8110 ! Four basis functions defined on the face 1254: 8111 !------------------------------------------------- 8112 SquareFaceMap(:) = (/ 1,2,5,4 /) 8113 WorkBasis = 0.0d0 8114 WorkCurlBasis = 0.0d0 8115 8116 WorkBasis(1,1) = (3.0d0 - Sqrt(3.0d0)*v)/6.0d0 * 4.0d0 * h3 8117 WorkBasis(1,2) = u/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3 8118 WorkCurlBasis(1,1) = -WorkBasis(1,2)/h3 * dh3 8119 WorkCurlBasis(1,2) = WorkBasis(1,1)/h3 * dh3 8120 WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) * 4.0d0 * h3 8121 WorkBasis(2,1) = -(u*(-3.0d0 + Sqrt(3.0d0)*v))/2.0d0 * 4.0d0 * h3 8122 WorkBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0 * 4.0d0 * h3 8123 WorkCurlBasis(2,1) = -WorkBasis(2,2)/h3 * dh3 8124 WorkCurlBasis(2,2) = WorkBasis(2,1)/h3 * dh3 8125 WorkCurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0 * 4.0d0 * h3 8126 8127 WorkBasis(3,3) = 2.0d0 * TriangleNodalPBasis(1, u, v) * TriangleNodalPBasis(2, u, v) 8128 grad(1:2) = dTriangleNodalPBasis(1, u, v) * TriangleNodalPBasis(2, u, v) + & 8129 TriangleNodalPBasis(1, u, v) * dTriangleNodalPBasis(2, u, v) 8130 WorkCurlBasis(3,1) = 2.0d0 * grad(2) 8131 WorkCurlBasis(3,2) = -2.0d0 * grad(1) 8132 WorkBasis(4,3) = 3.0d0 * WorkBasis(3,3) * w 8133 WorkCurlBasis(4,1) = 6.0d0 * grad(2) * w 8134 WorkCurlBasis(4,2) = -6.0d0 * grad(1) * w 8135 8136 DO j=1,4 8137 FaceIndices(j) = Ind(SquareFaceMap(j)) 8138 END DO 8139 IF (Parallel) THEN 8140 DO j=1,4 8141 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8142 END DO 8143 END IF 8144 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8145 8146 EdgeBasis(23,:) = D1 * WorkBasis(2*(I1-1)+1,:) 8147 CurlBasis(23,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 8148 EdgeBasis(24,:) = WorkBasis(2*(I1-1)+2,:) 8149 CurlBasis(24,:) = WorkCurlBasis(2*(I1-1)+2,:) 8150 EdgeBasis(25,:) = D2 * WorkBasis(2*(I2-1)+1,:) 8151 CurlBasis(25,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 8152 EdgeBasis(26,:) = WorkBasis(2*(I2-1)+2,:) 8153 CurlBasis(26,:) = WorkCurlBasis(2*(I2-1)+2,:) 8154 8155 !------------------------------------------------- 8156 ! Four basis functions defined on the face 2365: 8157 !------------------------------------------------- 8158 SquareFaceMap(:) = (/ 2,3,6,5 /) 8159 WorkBasis = 0.0d0 8160 WorkCurlBasis = 0.0d0 8161 8162 WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3 8163 WorkBasis(1,2) = (1 + u)/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3 8164 WorkCurlBasis(1,1) = -WorkBasis(1,2)/h3 * dh3 8165 WorkCurlBasis(1,2) = WorkBasis(1,1)/h3 * dh3 8166 WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) * 4.0d0 * h3 8167 WorkBasis(2,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*v)/4.0d0 * 4.0d0 * h3 8168 WorkBasis(2,2) = (Sqrt(3.0d0)*(1.0d0 + u)*(-1.0d0 - u + Sqrt(3.0d0)*v))/4.0d0 * 4.0d0 * h3 8169 WorkCurlBasis(2,1) = -WorkBasis(2,2)/h3 * dh3 8170 WorkCurlBasis(2,2) = WorkBasis(2,1)/h3 * dh3 8171 WorkCurlBasis(2,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0 * 4.0d0 * h3 8172 8173 WorkBasis(3,3) = 2.0d0 * TriangleNodalPBasis(2, u, v) * TriangleNodalPBasis(3, u, v) 8174 grad(1:2) = dTriangleNodalPBasis(2, u, v) * TriangleNodalPBasis(3, u, v) + & 8175 TriangleNodalPBasis(2, u, v) * dTriangleNodalPBasis(3, u, v) 8176 WorkCurlBasis(3,1) = 2.0d0 * grad(2) 8177 WorkCurlBasis(3,2) = -2.0d0 * grad(1) 8178 WorkBasis(4,3) = 3.0d0 * WorkBasis(3,3) * w 8179 WorkCurlBasis(4,1) = 6.0d0 * grad(2) * w 8180 WorkCurlBasis(4,2) = -6.0d0 * grad(1) * w 8181 8182 DO j=1,4 8183 FaceIndices(j) = Ind(SquareFaceMap(j)) 8184 END DO 8185 IF (Parallel) THEN 8186 DO j=1,4 8187 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8188 END DO 8189 END IF 8190 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8191 8192 EdgeBasis(27,:) = D1 * WorkBasis(2*(I1-1)+1,:) 8193 CurlBasis(27,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 8194 EdgeBasis(28,:) = WorkBasis(2*(I1-1)+2,:) 8195 CurlBasis(28,:) = WorkCurlBasis(2*(I1-1)+2,:) 8196 EdgeBasis(29,:) = D2 * WorkBasis(2*(I2-1)+1,:) 8197 CurlBasis(29,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 8198 EdgeBasis(30,:) = WorkBasis(2*(I2-1)+2,:) 8199 CurlBasis(30,:) = WorkCurlBasis(2*(I2-1)+2,:) 8200 8201 !------------------------------------------------- 8202 ! Four basis functions defined on the face 3146: 8203 !------------------------------------------------- 8204 SquareFaceMap(:) = (/ 3,1,4,6 /) 8205 WorkBasis = 0.0d0 8206 WorkCurlBasis = 0.0d0 8207 8208 WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3 8209 WorkBasis(1,2) = (-1 + u)/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3 8210 WorkCurlBasis(1,1) = -WorkBasis(1,2)/h3 * dh3 8211 WorkCurlBasis(1,2) = WorkBasis(1,1)/h3 * dh3 8212 WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) * 4.0d0 * h3 8213 WorkBasis(2,1) = (v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 * 4.0d0 * h3 8214 WorkBasis(2,2) = -(Sqrt(3.0d0)*(-1.0d0 + u)*(-1.0d0 + u + Sqrt(3.0d0)*v))/4.0d0 * 4.0d0 * h3 8215 WorkCurlBasis(2,1) = -WorkBasis(2,2)/h3 * dh3 8216 WorkCurlBasis(2,2) = WorkBasis(2,1)/h3 * dh3 8217 WorkCurlBasis(2,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 * 4.0d0 * h3 8218 8219 WorkBasis(3,3) = 2.0d0 * TriangleNodalPBasis(3, u, v) * TriangleNodalPBasis(1, u, v) 8220 grad(1:2) = dTriangleNodalPBasis(3, u, v) * TriangleNodalPBasis(1, u, v) + & 8221 TriangleNodalPBasis(3, u, v) * dTriangleNodalPBasis(1, u, v) 8222 WorkCurlBasis(3,1) = 2.0d0 * grad(2) 8223 WorkCurlBasis(3,2) = -2.0d0 * grad(1) 8224 WorkBasis(4,3) = 3.0d0 * WorkBasis(3,3) * w 8225 WorkCurlBasis(4,1) = 6.0d0 * grad(2) * w 8226 WorkCurlBasis(4,2) = -6.0d0 * grad(1) * w 8227 8228 DO j=1,4 8229 FaceIndices(j) = Ind(SquareFaceMap(j)) 8230 END DO 8231 IF (Parallel) THEN 8232 DO j=1,4 8233 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8234 END DO 8235 END IF 8236 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8237 8238 EdgeBasis(31,:) = D1 * WorkBasis(2*(I1-1)+1,:) 8239 CurlBasis(31,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 8240 EdgeBasis(32,:) = WorkBasis(2*(I1-1)+2,:) 8241 CurlBasis(32,:) = WorkCurlBasis(2*(I1-1)+2,:) 8242 EdgeBasis(33,:) = D2 * WorkBasis(2*(I2-1)+1,:) 8243 CurlBasis(33,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 8244 EdgeBasis(34,:) = WorkBasis(2*(I2-1)+2,:) 8245 CurlBasis(34,:) = WorkCurlBasis(2*(I2-1)+2,:) 8246 8247 !------------------------------------------------- 8248 ! Two basis functions associated with the interior 8249 !------------------------------------------------- 8250 EdgeBasis(35,1) = (v*(1.0d0 + u - v/Sqrt(3.0d0)))/(4.0d0*Sqrt(3.0d0)) * h3 8251 EdgeBasis(35,2) = ((-1.0d0 + u)*(-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) * h3 8252 CurlBasis(35,1) = -EdgeBasis(35,2)/h3 * dh3 8253 CurlBasis(35,2) = EdgeBasis(35,1)/h3 * dh3 8254 CurlBasis(35,3) = (-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0 * h3 8255 8256 EdgeBasis(36,1) = (v*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) * h3 8257 EdgeBasis(36,2) = -((1.0d0 + u)*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) * h3 8258 CurlBasis(36,1) = -EdgeBasis(36,2)/h3 * dh3 8259 CurlBasis(36,2) = EdgeBasis(36,1)/h3 * dh3 8260 CurlBasis(36,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0 * h3 8261 8262 ELSE 8263 !-------------------------------------------------------------- 8264 ! The lowest-order element from the optimal family. The optimal 8265 ! accuracy is obtained also for non-affine meshes. 8266 ! ------------------------------------------------------------- 8267 ! First nine basis functions associated with the edges 8268 ! ------------------------------------------------------------- 8269 i = EdgeMap(1,1) 8270 j = EdgeMap(1,2) 8271 ni = Element % NodeIndexes(i) 8272 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8273 nj = Element % NodeIndexes(j) 8274 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8275 EdgeBasis(1,1) = -((-3.0d0 + Sqrt(3.0d0)*v)*(-1.0d0 + w)*w)/12.0d0 8276 EdgeBasis(1,2) = (u*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0)) 8277 EdgeBasis(1,3) = 0.0d0 8278 CurlBasis(1,1) = (u*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8279 CurlBasis(1,2) = -((-3.0d0 + Sqrt(3.0d0)*v)*(-1.0d0 + 2*w))/12.0d0 8280 CurlBasis(1,3) = ((-1.0d0 + w)*w)/(2.0d0*Sqrt(3.0d0)) 8281 IF (nj<ni) THEN 8282 EdgeBasis(1,:) = -EdgeBasis(1,:) 8283 CurlBasis(1,:) = -CurlBasis(1,:) 8284 END IF 8285 8286 i = EdgeMap(2,1) 8287 j = EdgeMap(2,2) 8288 ni = Element % NodeIndexes(i) 8289 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8290 nj = Element % NodeIndexes(j) 8291 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8292 EdgeBasis(2,1) = -(v*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0)) 8293 EdgeBasis(2,2) = ((1.0d0 + u)*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0)) 8294 EdgeBasis(2,3) = 0.0d0 8295 CurlBasis(2,1) = ((1.0d0 + u)*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8296 CurlBasis(2,2) = (v*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8297 CurlBasis(2,3) = ((-1.0d0 + w)*w)/(2.0d0*Sqrt(3.0d0)) 8298 IF (nj<ni) THEN 8299 EdgeBasis(2,:) = -EdgeBasis(2,:) 8300 CurlBasis(2,:) = -CurlBasis(2,:) 8301 END IF 8302 8303 i = EdgeMap(3,1) 8304 j = EdgeMap(3,2) 8305 ni = Element % NodeIndexes(i) 8306 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8307 nj = Element % NodeIndexes(j) 8308 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8309 EdgeBasis(3,1) = -(v*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0)) 8310 EdgeBasis(3,2) = ((-1.0d0 + u)*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0)) 8311 EdgeBasis(3,3) = 0.0d0 8312 CurlBasis(3,1) = ((-1.0d0 + u)*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8313 CurlBasis(3,2) = (v*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8314 CurlBasis(3,3) = ((-1.0d0 + w)*w)/(2.0d0*Sqrt(3.0d0)) 8315 IF (nj<ni) THEN 8316 EdgeBasis(3,:) = -EdgeBasis(3,:) 8317 CurlBasis(3,:) = -CurlBasis(3,:) 8318 END IF 8319 8320 i = EdgeMap(4,1) 8321 j = EdgeMap(4,2) 8322 ni = Element % NodeIndexes(i) 8323 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8324 nj = Element % NodeIndexes(j) 8325 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8326 EdgeBasis(4,1) = -((-3.0d0 + Sqrt(3.0d0)*v)*w*(1.0d0 + w))/12.0d0 8327 EdgeBasis(4,2) = (u*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0)) 8328 EdgeBasis(4,3) = 0.0d0 8329 CurlBasis(4,1) = -(u*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8330 CurlBasis(4,2) = -((-3.0d0 + Sqrt(3.0d0)*v)*(1.0d0 + 2.0d0*w))/12.0d0 8331 CurlBasis(4,3) = (w*(1.0d0 + w))/(2.0d0*Sqrt(3.0d0)) 8332 IF (nj<ni) THEN 8333 EdgeBasis(4,:) = -EdgeBasis(4,:) 8334 CurlBasis(4,:) = -CurlBasis(4,:) 8335 END IF 8336 8337 i = EdgeMap(5,1) 8338 j = EdgeMap(5,2) 8339 ni = Element % NodeIndexes(i) 8340 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8341 nj = Element % NodeIndexes(j) 8342 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8343 EdgeBasis(5,1) = -(v*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0)) 8344 EdgeBasis(5,2) = ((1.0d0 + u)*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0)) 8345 EdgeBasis(5,3) = 0.0d0 8346 CurlBasis(5,1) = -((1.0d0 + u)*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8347 CurlBasis(5,2) = -(v*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8348 CurlBasis(5,3) = (w*(1.0d0 + w))/(2.0d0*Sqrt(3.0d0)) 8349 IF (nj<ni) THEN 8350 EdgeBasis(5,:) = -EdgeBasis(5,:) 8351 CurlBasis(5,:) = -CurlBasis(5,:) 8352 END IF 8353 8354 i = EdgeMap(6,1) 8355 j = EdgeMap(6,2) 8356 ni = Element % NodeIndexes(i) 8357 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8358 nj = Element % NodeIndexes(j) 8359 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8360 EdgeBasis(6,1) = -(v*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0)) 8361 EdgeBasis(6,2) = ((-1.0d0 + u)*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0)) 8362 EdgeBasis(6,3) = 0.0d0 8363 CurlBasis(6,1) = -((-1.0d0 + u)*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8364 CurlBasis(6,2) = -(v*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0)) 8365 CurlBasis(6,3) = (w*(1.0d0 + w))/(2.0d0*Sqrt(3.0d0)) 8366 IF (nj<ni) THEN 8367 EdgeBasis(6,:) = -EdgeBasis(6,:) 8368 CurlBasis(6,:) = -CurlBasis(6,:) 8369 END IF 8370 8371 i = EdgeMap(7,1) 8372 j = EdgeMap(7,2) 8373 ni = Element % NodeIndexes(i) 8374 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8375 nj = Element % NodeIndexes(j) 8376 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8377 EdgeBasis(7,1) = 0.0d0 8378 EdgeBasis(7,2) = 0.0d0 8379 EdgeBasis(7,3) = (3*u**2 + v*(-Sqrt(3.0d0) + v) + u*(-3.0d0 + 2*Sqrt(3.0d0)*v))/12.0d0 8380 CurlBasis(7,1) = (-Sqrt(3.0d0) + 2*Sqrt(3.0d0)*u + 2*v)/12.0d0 8381 CurlBasis(7,2) = (3.0d0 - 6*u - 2*Sqrt(3.0d0)*v)/12.0d0 8382 CurlBasis(7,3) = 0.0d0 8383 IF (nj<ni) THEN 8384 EdgeBasis(7,:) = -EdgeBasis(7,:) 8385 CurlBasis(7,:) = -CurlBasis(7,:) 8386 END IF 8387 8388 i = EdgeMap(8,1) 8389 j = EdgeMap(8,2) 8390 ni = Element % NodeIndexes(i) 8391 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8392 nj = Element % NodeIndexes(j) 8393 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8394 EdgeBasis(8,1) = 0.0d0 8395 EdgeBasis(8,2) = 0.0d0 8396 EdgeBasis(8,3) = (3*u**2 + v*(-Sqrt(3.0d0) + v) + u*(3.0d0 - 2*Sqrt(3.0d0)*v))/12.0d0 8397 CurlBasis(8,1) = (-Sqrt(3.0d0) - 2*Sqrt(3.0d0)*u + 2*v)/12.0d0 8398 CurlBasis(8,2) = (-3.0d0 - 6*u + 2*Sqrt(3.0d0)*v)/12.0d0 8399 CurlBasis(8,3) = 0.0d0 8400 IF (nj<ni) THEN 8401 EdgeBasis(8,:) = -EdgeBasis(8,:) 8402 CurlBasis(8,:) = -CurlBasis(8,:) 8403 END IF 8404 8405 i = EdgeMap(9,1) 8406 j = EdgeMap(9,2) 8407 ni = Element % NodeIndexes(i) 8408 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8409 nj = Element % NodeIndexes(j) 8410 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8411 EdgeBasis(9,1) = 0.0d0 8412 EdgeBasis(9,2) = 0.0d0 8413 EdgeBasis(9,3) = (v*(-Sqrt(3.0d0) + 2*v))/6.0d0 8414 CurlBasis(9,1) = (-Sqrt(3.0d0) + 4*v)/6.0d0 8415 CurlBasis(9,2) = 0.0d0 8416 CurlBasis(9,3) = 0.0d0 8417 IF (nj<ni) THEN 8418 EdgeBasis(9,:) = -EdgeBasis(9,:) 8419 CurlBasis(9,:) = -CurlBasis(9,:) 8420 END IF 8421 8422 ! --------------------------------------------------------------------- 8423 ! Additional six basis functions on the square faces (two per face). 8424 ! --------------------------------------------------------------------- 8425 PrismSquareFaceMap(1,:) = (/ 1,2,5,4 /) 8426 PrismSquareFaceMap(2,:) = (/ 2,3,6,5 /) 8427 PrismSquareFaceMap(3,:) = (/ 3,1,4,6 /) 8428 8429 ! The first square face: 8430 WorkBasis(1,1) = ((-3.0d0 + Sqrt(3.0d0)*v)*(-1.0d0 + w**2))/6.0d0 8431 WorkBasis(1,2) = -(u*(-1.0d0 + w**2))/(2.0d0*Sqrt(3.0d0)) 8432 WorkBasis(1,3) = 0.0d0 8433 WorkCurlBasis(1,1) = (u*w)/Sqrt(3.0d0) 8434 WorkCurlBasis(1,2) = (-1.0d0 + v/Sqrt(3.0d0))*w 8435 WorkCurlBasis(1,3) = -((-1.0d0 + w**2)/Sqrt(3.0d0)) 8436 8437 WorkBasis(2,1) = 0.0d0 8438 WorkBasis(2,2) = 0.0d0 8439 WorkBasis(2,3) = (3.0d0 - 3*u**2 - 2*Sqrt(3.0d0)*v + v**2)/6.0d0 8440 WorkCurlBasis(2,1) = (-Sqrt(3.0d0) + v)/3.0d0 8441 WorkCurlBasis(2,2) = u 8442 WorkCurlBasis(2,3) = 0.0d0 8443 8444 DO j=1,4 8445 FaceIndices(j) = Ind(PrismSquareFaceMap(1,j)) 8446 END DO 8447 IF (Parallel) THEN 8448 DO j=1,4 8449 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8450 END DO 8451 END IF 8452 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8453 8454 EdgeBasis(10,:) = D1 * WorkBasis(I1,:) 8455 CurlBasis(10,:) = D1 * WorkCurlBasis(I1,:) 8456 EdgeBasis(11,:) = D2 * WorkBasis(I2,:) 8457 CurlBasis(11,:) = D2 * WorkCurlBasis(I2,:) 8458 8459 ! The second square face: 8460 WorkBasis(1,1) = (v*(-1.0d0 + w**2))/(2.0d0*Sqrt(3.0d0)) 8461 WorkBasis(1,2) = -((1.0d0 + u)*(-1.0d0 + w**2))/(2.0d0*Sqrt(3.0d0)) 8462 WorkBasis(1,3) = 0.0d0 8463 WorkCurlBasis(1,1) = ((1.0d0 + u)*w)/Sqrt(3.0d0) 8464 WorkCurlBasis(1,2) = (v*w)/Sqrt(3.0d0) 8465 WorkCurlBasis(1,3) = -((-1.0d0 + w**2)/Sqrt(3.0d0)) 8466 8467 WorkBasis(2,1) = 0.0d0 8468 WorkBasis(2,2) = 0.0d0 8469 WorkBasis(2,3) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - v)*v)/3.0d0 8470 WorkCurlBasis(2,1) = (Sqrt(3.0d0) + Sqrt(3.0d0)*u - 2*v)/3.0d0 8471 WorkCurlBasis(2,2) = -(v/Sqrt(3.0d0)) 8472 WorkCurlBasis(2,3) = 0.0d0 8473 8474 DO j=1,4 8475 FaceIndices(j) = Ind(PrismSquareFaceMap(2,j)) 8476 END DO 8477 IF (Parallel) THEN 8478 DO j=1,4 8479 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8480 END DO 8481 END IF 8482 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8483 8484 EdgeBasis(12,:) = D1 * WorkBasis(I1,:) 8485 CurlBasis(12,:) = D1 * WorkCurlBasis(I1,:) 8486 EdgeBasis(13,:) = D2 * WorkBasis(I2,:) 8487 CurlBasis(13,:) = D2 * WorkCurlBasis(I2,:) 8488 8489 ! The third square face: 8490 WorkBasis(1,1) = (v*(-1.0d0 + w**2))/(2.0d0*SQRT(3.0d0)) 8491 WorkBasis(1,2) = -((-1.0d0 + u)*(-1.0d0 + w**2))/(2.0d0*SQRT(3.0d0)) 8492 WorkBasis(1,3) = 0.0d0 8493 WorkCurlBasis(1,1) = ((-1.0d0 + u)*w)/SQRT(3.0d0) 8494 WorkCurlBasis(1,2) = (v*w)/SQRT(3.0d0) 8495 WorkCurlBasis(1,3) = -(-1.0d0 + w**2)/SQRT(3.0d0) 8496 8497 WorkBasis(2,1) = 0.0d0 8498 WorkBasis(2,2) = 0.0d0 8499 WorkBasis(2,3) = -(v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v))/3.0d0 8500 WorkCurlBasis(2,1) = (Sqrt(3.0d0) - Sqrt(3.0d0)*u - 2*v)/3.0d0 8501 WorkCurlBasis(2,2) = v/Sqrt(3.0d0) 8502 WorkCurlBasis(2,3) = 0.0d0 8503 8504 DO j=1,4 8505 FaceIndices(j) = Ind(PrismSquareFaceMap(3,j)) 8506 END DO 8507 IF (Parallel) THEN 8508 DO j=1,4 8509 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8510 END DO 8511 END IF 8512 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8513 8514 EdgeBasis(14,:) = D1 * WorkBasis(I1,:) 8515 CurlBasis(14,:) = D1 * WorkCurlBasis(I1,:) 8516 EdgeBasis(15,:) = D2 * WorkBasis(I2,:) 8517 CurlBasis(15,:) = D2 * WorkCurlBasis(I2,:) 8518 END IF 8519 8520 CASE(8) 8521 !-------------------------------------------------------------- 8522 ! This branch is for handling brick elements 8523 !-------------------------------------------------------------- 8524 EdgeMap => GetEdgeMap(8) 8525 Ind => Element % Nodeindexes 8526 8527 IF (SecondOrder) THEN 8528 !--------------------------------------------------------------- 8529 ! The second-order element from the Nedelec's first family 8530 ! (note that the lowest-order brick element is from a different 8531 ! family). This element may not be optimally accurate if 8532 ! the physical element is not affine. 8533 !-------------------------------------------------------------- 8534 8535 ! Edges 12 and 43 ... 8536 DO q=1,2 8537 k = 2*q-1 ! Edge number k: 1 ~ 12 and 3 ~ 43 8538 i = EdgeMap(k,1) 8539 j = EdgeMap(k,2) 8540 ni = Element % NodeIndexes(i) 8541 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8542 nj = Element % NodeIndexes(j) 8543 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8544 8545 EdgeBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(1,w) * LineNodalPBasis(q,v) 8546 CurlBasis(2*(k-1)+1,2) = 0.5d0 * (-0.5d0) * LineNodalPBasis(q,v) 8547 CurlBasis(2*(k-1)+1,3) = -0.5d0 * LineNodalPBasis(1,w) * dLineNodalPBasis(q,v) 8548 EdgeBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(1,w) * u * LineNodalPBasis(q,v) 8549 CurlBasis(2*(k-1)+2,2) = 1.5d0 * (-0.5d0) * u * LineNodalPBasis(q,v) 8550 CurlBasis(2*(k-1)+2,3) = -1.5d0 * LineNodalPBasis(1,w) * u * dLineNodalPBasis(q,v) 8551 IF (nj<ni) THEN 8552 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:) 8553 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:) 8554 END IF 8555 END DO 8556 8557 ! Edges 56 and 87 ... 8558 DO q=1,2 8559 k = 4 + 2*q-1 ! Edge number k: 5 ~ 56 and 7 ~ 87 8560 i = EdgeMap(k,1) 8561 j = EdgeMap(k,2) 8562 ni = Element % NodeIndexes(i) 8563 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8564 nj = Element % NodeIndexes(j) 8565 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8566 8567 EdgeBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(2,w) * LineNodalPBasis(q,v) 8568 CurlBasis(2*(k-1)+1,2) = 0.5d0 * 0.5d0 * LineNodalPBasis(q,v) 8569 CurlBasis(2*(k-1)+1,3) = -0.5d0 * LineNodalPBasis(2,w) * dLineNodalPBasis(q,v) 8570 EdgeBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(2,w) * u * LineNodalPBasis(q,v) 8571 CurlBasis(2*(k-1)+2,2) = 1.5d0 * 0.5d0 * u * LineNodalPBasis(q,v) 8572 CurlBasis(2*(k-1)+2,3) = -1.5d0 * LineNodalPBasis(2,w) * u * dLineNodalPBasis(q,v) 8573 IF (nj<ni) THEN 8574 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:) 8575 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:) 8576 END IF 8577 END DO 8578 8579 ! Edges 23 and 14 ... 8580 DO q=1,2 8581 k = 2*q ! Edge number k: 2 ~ 23 and 4 ~ 14 8582 i = EdgeMap(k,1) 8583 j = EdgeMap(k,2) 8584 ni = Element % NodeIndexes(i) 8585 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8586 nj = Element % NodeIndexes(j) 8587 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8588 8589 EdgeBasis(2*(k-1)+1,2) = 0.5d0 * LineNodalPBasis(1,w) * LineNodalPBasis(3-q,u) 8590 CurlBasis(2*(k-1)+1,1) = -0.5d0 * (-0.5d0) * LineNodalPBasis(3-q,u) 8591 CurlBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(1,w) * dLineNodalPBasis(3-q,u) 8592 EdgeBasis(2*(k-1)+2,2) = 1.5d0 * LineNodalPBasis(1,w) * v * LineNodalPBasis(3-q,u) 8593 CurlBasis(2*(k-1)+2,1) = -1.5d0 * (-0.5d0) * v * LineNodalPBasis(3-q,u) 8594 CurlBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(1,w) * v * dLineNodalPBasis(3-q,u) 8595 IF (nj<ni) THEN 8596 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:) 8597 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:) 8598 END IF 8599 END DO 8600 8601 ! Edges 67 and 58 ... 8602 DO q=1,2 8603 k = 4+2*q ! Edge number k: 6 ~ 67 and 8 ~ 58 8604 i = EdgeMap(k,1) 8605 j = EdgeMap(k,2) 8606 ni = Element % NodeIndexes(i) 8607 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8608 nj = Element % NodeIndexes(j) 8609 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8610 8611 EdgeBasis(2*(k-1)+1,2) = 0.5d0 * LineNodalPBasis(2,w) * LineNodalPBasis(3-q,u) 8612 CurlBasis(2*(k-1)+1,1) = -0.5d0 * 0.5d0 * LineNodalPBasis(3-q,u) 8613 CurlBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(2,w) * dLineNodalPBasis(3-q,u) 8614 EdgeBasis(2*(k-1)+2,2) = 1.5d0 * LineNodalPBasis(2,w) * v * LineNodalPBasis(3-q,u) 8615 CurlBasis(2*(k-1)+2,1) = -1.5d0 * 0.5d0 * v * LineNodalPBasis(3-q,u) 8616 CurlBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(2,w) * v * dLineNodalPBasis(3-q,u) 8617 IF (nj<ni) THEN 8618 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:) 8619 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:) 8620 END IF 8621 END DO 8622 8623 ! Edges 15 and 48 ... 8624 DO q=1,2 8625 k = 8+3*(q-1)+1 ! Edge number k: 9 ~ 15 and 12 ~ 48 8626 i = EdgeMap(k,1) 8627 j = EdgeMap(k,2) 8628 ni = Element % NodeIndexes(i) 8629 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8630 nj = Element % NodeIndexes(j) 8631 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8632 8633 EdgeBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(1,u) * LineNodalPBasis(q,v) 8634 CurlBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(1,u) * dLineNodalPBasis(q,v) 8635 CurlBasis(2*(k-1)+1,2) = -0.5d0 * dLineNodalPBasis(1,u) * LineNodalPBasis(q,v) 8636 EdgeBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(1,u) * w * LineNodalPBasis(q,v) 8637 CurlBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(1,u) * w * dLineNodalPBasis(q,v) 8638 CurlBasis(2*(k-1)+2,2) = -1.5d0 * dLineNodalPBasis(1,u) * w * LineNodalPBasis(q,v) 8639 IF (nj<ni) THEN 8640 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:) 8641 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:) 8642 END IF 8643 END DO 8644 8645 ! Edges 26 and 37 ... 8646 DO q=1,2 8647 k = 9+q ! Edge number k: 10 ~ 26 and 11 ~ 37 8648 i = EdgeMap(k,1) 8649 j = EdgeMap(k,2) 8650 ni = Element % NodeIndexes(i) 8651 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8652 nj = Element % NodeIndexes(j) 8653 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8654 8655 EdgeBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(2,u) * LineNodalPBasis(q,v) 8656 CurlBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(2,u) * dLineNodalPBasis(q,v) 8657 CurlBasis(2*(k-1)+1,2) = -0.5d0 * dLineNodalPBasis(2,u) * LineNodalPBasis(q,v) 8658 EdgeBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(2,u) * w * LineNodalPBasis(q,v) 8659 CurlBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(2,u) * w * dLineNodalPBasis(q,v) 8660 CurlBasis(2*(k-1)+2,2) = -1.5d0 * dLineNodalPBasis(2,u) * w * LineNodalPBasis(q,v) 8661 IF (nj<ni) THEN 8662 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:) 8663 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:) 8664 END IF 8665 END DO 8666 8667 ! --------------------------------------------------------------------- 8668 ! Additional basis functions on the square faces (four per face). 8669 ! --------------------------------------------------------------------- 8670 8671 ! Faces 1234 and 5678: 8672 DO q=1,2 8673 SELECT CASE(q) 8674 CASE(1) 8675 SquareFaceMap(:) = (/ 1,2,3,4 /) 8676 CASE(2) 8677 SquareFaceMap(:) = (/ 5,6,7,8 /) 8678 END SELECT 8679 8680 WorkBasis = 0.0d0 8681 WorkCurlBasis = 0.0d0 8682 8683 WorkBasis(1,1) = 2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * LineNodalPBasis(q,w) 8684 WorkCurlBasis(1,2) = 2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * dLineNodalPBasis(q,w) 8685 WorkCurlBasis(1,3) = v * LineNodalPBasis(q,w) 8686 8687 WorkBasis(2,1) = 12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * u * LineNodalPBasis(q,w) 8688 WorkCurlBasis(2,2) = 12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * u * dLineNodalPBasis(q,w) 8689 WorkCurlBasis(2,3) = -12.0d0 * (-0.5d0 * v) * u * dLineNodalPBasis(q,w) 8690 8691 WorkBasis(3,2) = 2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * LineNodalPBasis(q,w) 8692 WorkCurlBasis(3,1) = -2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * dLineNodalPBasis(q,w) 8693 WorkCurlBasis(3,3) = -u * LineNodalPBasis(q,w) 8694 8695 WorkBasis(4,2) = 12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * v * LineNodalPBasis(q,w) 8696 WorkCurlBasis(4,1) = -12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * v * dLineNodalPBasis(q,w) 8697 WorkCurlBasis(4,3) = 12.0d0 * (-0.5d0 * u) * v * LineNodalPBasis(q,w) 8698 8699 DO j=1,4 8700 FaceIndices(j) = Ind(SquareFaceMap(j)) 8701 END DO 8702 IF (Parallel) THEN 8703 DO j=1,4 8704 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8705 END DO 8706 END IF 8707 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8708 8709 k = 24 8710 EdgeBasis(k+4*(q-1)+1,:) = D1 * WorkBasis(2*(I1-1)+1,:) 8711 CurlBasis(k+4*(q-1)+1,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 8712 EdgeBasis(k+4*(q-1)+2,:) = WorkBasis(2*(I1-1)+2,:) 8713 CurlBasis(k+4*(q-1)+2,:) = WorkCurlBasis(2*(I1-1)+2,:) 8714 EdgeBasis(k+4*(q-1)+3,:) = D2 * WorkBasis(2*(I2-1)+1,:) 8715 CurlBasis(k+4*(q-1)+3,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 8716 EdgeBasis(k+4*(q-1)+4,:) = WorkBasis(2*(I2-1)+2,:) 8717 CurlBasis(k+4*(q-1)+4,:) = WorkCurlBasis(2*(I2-1)+2,:) 8718 END DO 8719 8720 ! Faces 1265 and 4378: 8721 DO q=1,2 8722 SELECT CASE(q) 8723 CASE(1) 8724 SquareFaceMap(:) = (/ 1,2,6,5 /) 8725 k = 32 8726 CASE(2) 8727 SquareFaceMap(:) = (/ 4,3,7,8 /) 8728 k = 40 8729 END SELECT 8730 8731 WorkBasis = 0.0d0 8732 WorkCurlBasis = 0.0d0 8733 8734 WorkBasis(1,1) = 2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * LineNodalPBasis(q,v) 8735 WorkCurlBasis(1,2) = 2.0d0 * (-0.5d0 * w) * LineNodalPBasis(q,v) 8736 WorkCurlBasis(1,3) = -2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * dLineNodalPBasis(q,v) 8737 8738 WorkBasis(2,1) = 12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * LineNodalPBasis(q,v) 8739 WorkCurlBasis(2,2) = 12.0d0 * (-0.5d0 * w) * u * LineNodalPBasis(q,v) 8740 WorkCurlBasis(2,3) = -12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * dLineNodalPBasis(q,v) 8741 8742 WorkBasis(3,3) = 2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * LineNodalPBasis(q,v) 8743 WorkCurlBasis(3,1) = 2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * dLineNodalPBasis(q,v) 8744 WorkCurlBasis(3,2) = u * LineNodalPBasis(q,v) 8745 8746 WorkBasis(4,3) = 12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * w * LineNodalPBasis(q,v) 8747 WorkCurlBasis(4,1) = 12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * w * dLineNodalPBasis(q,v) 8748 WorkCurlBasis(4,2) = -12.0d0 * (-0.5d0 * u) * w * LineNodalPBasis(q,v) 8749 8750 DO j=1,4 8751 FaceIndices(j) = Ind(SquareFaceMap(j)) 8752 END DO 8753 IF (Parallel) THEN 8754 DO j=1,4 8755 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8756 END DO 8757 END IF 8758 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8759 8760 EdgeBasis(k+1,:) = D1 * WorkBasis(2*(I1-1)+1,:) 8761 CurlBasis(k+1,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 8762 EdgeBasis(k+2,:) = WorkBasis(2*(I1-1)+2,:) 8763 CurlBasis(k+2,:) = WorkCurlBasis(2*(I1-1)+2,:) 8764 EdgeBasis(k+3,:) = D2 * WorkBasis(2*(I2-1)+1,:) 8765 CurlBasis(k+3,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 8766 EdgeBasis(k+4,:) = WorkBasis(2*(I2-1)+2,:) 8767 CurlBasis(k+4,:) = WorkCurlBasis(2*(I2-1)+2,:) 8768 END DO 8769 8770 ! Faces 2376 and 1485: 8771 DO q=1,2 8772 SELECT CASE(q) 8773 CASE(1) 8774 SquareFaceMap(:) = (/ 1,4,8,5 /) 8775 k = 44 8776 CASE(2) 8777 SquareFaceMap(:) = (/ 2,3,7,6 /) 8778 k = 36 8779 END SELECT 8780 8781 WorkBasis = 0.0d0 8782 WorkCurlBasis = 0.0d0 8783 8784 WorkBasis(1,2) = 2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * LineNodalPBasis(q,u) 8785 WorkCurlBasis(1,1) = -2.0d0 * (-0.5d0 * w) * LineNodalPBasis(q,u) 8786 WorkCurlBasis(1,3) = 2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * dLineNodalPBasis(q,u) 8787 8788 WorkBasis(2,2) = 12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * LineNodalPBasis(q,u) 8789 WorkCurlBasis(2,1) = -12.0d0 * (-0.5d0 * w) * v * LineNodalPBasis(q,u) 8790 WorkCurlBasis(2,3) = 12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * dLineNodalPBasis(q,u) 8791 8792 WorkBasis(3,3) = 2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * LineNodalPBasis(q,u) 8793 WorkCurlBasis(3,1) = 2.0d0 * (-0.5d0 * v) * LineNodalPBasis(q,u) 8794 WorkCurlBasis(3,2) = -2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * dLineNodalPBasis(q,u) 8795 8796 WorkBasis(4,3) = 12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * LineNodalPBasis(q,u) 8797 WorkCurlBasis(4,1) = 12.0d0 * (-0.5d0 * v) * w * LineNodalPBasis(q,u) 8798 WorkCurlBasis(4,2) = -12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * dLineNodalPBasis(q,u) 8799 8800 DO j=1,4 8801 FaceIndices(j) = Ind(SquareFaceMap(j)) 8802 END DO 8803 IF (Parallel) THEN 8804 DO j=1,4 8805 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 8806 END DO 8807 END IF 8808 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 8809 8810 EdgeBasis(k+1,:) = D1 * WorkBasis(2*(I1-1)+1,:) 8811 CurlBasis(k+1,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:) 8812 EdgeBasis(k+2,:) = WorkBasis(2*(I1-1)+2,:) 8813 CurlBasis(k+2,:) = WorkCurlBasis(2*(I1-1)+2,:) 8814 EdgeBasis(k+3,:) = D2 * WorkBasis(2*(I2-1)+1,:) 8815 CurlBasis(k+3,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:) 8816 EdgeBasis(k+4,:) = WorkBasis(2*(I2-1)+2,:) 8817 CurlBasis(k+4,:) = WorkCurlBasis(2*(I2-1)+2,:) 8818 END DO 8819 8820 ! Interior basis functions, two per coordinate direction: 8821 8822 EdgeBasis(49,1) = 8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * & 8823 LineNodalPBasis(1,v) * LineNodalPBasis(2,v) 8824 CurlBasis(49,2) = 8.0d0 * (-0.5d0 * w) * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) 8825 CurlBasis(49,3) = -8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * (-0.5d0 * v) 8826 8827 EdgeBasis(50,1) = 24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * & 8828 LineNodalPBasis(1,v) * LineNodalPBasis(2,v) 8829 CurlBasis(50,2) = 24.0d0 * (-0.5d0 * w) * u * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) 8830 CurlBasis(50,3) = -24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * (-0.5d0 * v) 8831 8832 8833 EdgeBasis(51,2) = 8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * & 8834 LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8835 CurlBasis(51,1) = -8.0d0 * (-0.5d0 * w) * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8836 CurlBasis(51,3) = 8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * (-0.5d0 * u) 8837 8838 EdgeBasis(52,2) = 24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * & 8839 LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8840 CurlBasis(52,1) = -24.0d0 * (-0.5d0 * w) * v * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8841 CurlBasis(52,3) = 24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * (-0.5d0 * u) 8842 8843 EdgeBasis(53,3) = 8.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * & 8844 LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8845 CurlBasis(53,1) = 8.0d0 * (-0.5d0 * v) * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8846 CurlBasis(53,2) = -8.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * (-0.5d0 * u) 8847 8848 EdgeBasis(54,3) = 24.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * & 8849 LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8850 CurlBasis(54,1) = 24.0d0 * (-0.5d0 * v) * w * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) 8851 CurlBasis(54,2) = -24.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * (-0.5d0 * u) 8852 8853 ELSE 8854 !-------------------------------------------------------------- 8855 ! The lowest-order element from the optimal family. The optimal 8856 ! accuracy is obtained also for non-affine meshes. 8857 ! ------------------------------------------------------------- 8858 ! First twelwe basis functions associated with the edges 8859 ! ------------------------------------------------------------- 8860 i = EdgeMap(1,1) 8861 j = EdgeMap(1,2) 8862 ni = Element % NodeIndexes(i) 8863 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8864 nj = Element % NodeIndexes(j) 8865 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8866 EdgeBasis(1,1) = ((-1.0d0 + v)*v*(-1.0d0 + w)*w)/8.0d0 8867 EdgeBasis(1,2) = 0.0d0 8868 EdgeBasis(1,3) = 0.0d0 8869 CurlBasis(1,1) = 0.0d0 8870 CurlBasis(1,2) = ((-1.0d0 + v)*v*(-1.0d0 + 2*w))/8.0d0 8871 CurlBasis(1,3) = -((-1.0d0 + 2*v)*(-1.0d0 + w)*w)/8.0d0 8872 IF (nj<ni) THEN 8873 EdgeBasis(1,:) = -EdgeBasis(1,:) 8874 CurlBasis(1,:) = -CurlBasis(1,:) 8875 END IF 8876 8877 i = EdgeMap(2,1) 8878 j = EdgeMap(2,2) 8879 ni = Element % NodeIndexes(i) 8880 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8881 nj = Element % NodeIndexes(j) 8882 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8883 EdgeBasis(2,1) = 0.0d0 8884 EdgeBasis(2,2) = (u*(1.0d0 + u)*(-1.0d0 + w)*w)/8.0d0 8885 EdgeBasis(2,3) = 0.0d0 8886 CurlBasis(2,1) = -(u*(1.0d0 + u)*(-1.0d0 + 2*w))/8.0d0 8887 CurlBasis(2,2) = 0.0d0 8888 CurlBasis(2,3) = ((1.0d0 + 2*u)*(-1.0d0 + w)*w)/8.0d0 8889 IF (nj<ni) THEN 8890 EdgeBasis(2,:) = -EdgeBasis(2,:) 8891 CurlBasis(2,:) = -CurlBasis(2,:) 8892 END IF 8893 8894 i = EdgeMap(3,1) 8895 j = EdgeMap(3,2) 8896 ni = Element % NodeIndexes(i) 8897 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8898 nj = Element % NodeIndexes(j) 8899 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8900 EdgeBasis(3,1) = (v*(1.0d0 + v)*(-1.0d0 + w)*w)/8.0d0 8901 EdgeBasis(3,2) = 0.0d0 8902 EdgeBasis(3,3) = 0.0d0 8903 CurlBasis(3,1) = 0.0d0 8904 CurlBasis(3,2) = (v*(1.0d0 + v)*(-1.0d0 + 2*w))/8.0d0 8905 CurlBasis(3,3) = -((1.0d0 + 2*v)*(-1.0d0 + w)*w)/8.0d0 8906 IF (nj<ni) THEN 8907 EdgeBasis(3,:) = -EdgeBasis(3,:) 8908 CurlBasis(3,:) = -CurlBasis(3,:) 8909 END IF 8910 8911 i = EdgeMap(4,1) 8912 j = EdgeMap(4,2) 8913 ni = Element % NodeIndexes(i) 8914 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8915 nj = Element % NodeIndexes(j) 8916 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8917 EdgeBasis(4,1) = 0.0d0 8918 EdgeBasis(4,2) = ((-1.0d0 + u)*u*(-1.0d0 + w)*w)/8.0d0 8919 EdgeBasis(4,3) = 0.0d0 8920 CurlBasis(4,1) = -((-1.0d0 + u)*u*(-1.0d0 + 2*w))/8.0d0 8921 CurlBasis(4,2) = 0.0d0 8922 CurlBasis(4,3) = ((-1.0d0 + 2*u)*(-1.0d0 + w)*w)/8.0d0 8923 IF (nj<ni) THEN 8924 EdgeBasis(4,:) = -EdgeBasis(4,:) 8925 CurlBasis(4,:) = -CurlBasis(4,:) 8926 END IF 8927 8928 i = EdgeMap(5,1) 8929 j = EdgeMap(5,2) 8930 ni = Element % NodeIndexes(i) 8931 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8932 nj = Element % NodeIndexes(j) 8933 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8934 EdgeBasis(5,1) = ((-1.0d0 + v)*v*w*(1.0d0 + w))/8.0d0 8935 EdgeBasis(5,2) = 0.0d0 8936 EdgeBasis(5,3) = 0.0d0 8937 CurlBasis(5,1) = 0.0d0 8938 CurlBasis(5,2) = ((-1.0d0 + v)*v*(1.0d0 + 2*w))/8.0d0 8939 CurlBasis(5,3) = -((-1.0d0 + 2*v)*w*(1.0d0 + w))/8.0d0 8940 IF (nj<ni) THEN 8941 EdgeBasis(5,:) = -EdgeBasis(5,:) 8942 CurlBasis(5,:) = -CurlBasis(5,:) 8943 END IF 8944 8945 i = EdgeMap(6,1) 8946 j = EdgeMap(6,2) 8947 ni = Element % NodeIndexes(i) 8948 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8949 nj = Element % NodeIndexes(j) 8950 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8951 EdgeBasis(6,1) = 0.0d0 8952 EdgeBasis(6,2) = (u*(1.0d0 + u)*w*(1.0d0 + w))/8.0d0 8953 EdgeBasis(6,3) = 0.0d0 8954 CurlBasis(6,1) = -(u*(1.0d0 + u)*(1.0d0 + 2*w))/8.0d0 8955 CurlBasis(6,2) = 0.0d0 8956 CurlBasis(6,3) = ((1.0d0 + 2*u)*w*(1.0d0 + w))/8.0d0 8957 IF (nj<ni) THEN 8958 EdgeBasis(6,:) = -EdgeBasis(6,:) 8959 CurlBasis(6,:) = -CurlBasis(6,:) 8960 END IF 8961 8962 i = EdgeMap(7,1) 8963 j = EdgeMap(7,2) 8964 ni = Element % NodeIndexes(i) 8965 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8966 nj = Element % NodeIndexes(j) 8967 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8968 EdgeBasis(7,1) = (v*(1.0d0 + v)*w*(1.0d0 + w))/8.0d0 8969 EdgeBasis(7,2) = 0.0d0 8970 EdgeBasis(7,3) = 0.0d0 8971 CurlBasis(7,1) = 0.0d0 8972 CurlBasis(7,2) = (v*(1.0d0 + v)*(1.0d0 + 2*w))/8.0d0 8973 CurlBasis(7,3) = -((1.0d0 + 2*v)*w*(1.0d0 + w))/8.0d0 8974 IF (nj<ni) THEN 8975 EdgeBasis(7,:) = -EdgeBasis(7,:) 8976 CurlBasis(7,:) = -CurlBasis(7,:) 8977 END IF 8978 8979 i = EdgeMap(8,1) 8980 j = EdgeMap(8,2) 8981 ni = Element % NodeIndexes(i) 8982 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 8983 nj = Element % NodeIndexes(j) 8984 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 8985 EdgeBasis(8,1) = 0.0d0 8986 EdgeBasis(8,2) = ((-1.0d0 + u)*u*w*(1.0d0 + w))/8.0d0 8987 EdgeBasis(8,3) = 0.0d0 8988 CurlBasis(8,1) = -((-1.0d0 + u)*u*(1.0d0 + 2*w))/8.0d0 8989 CurlBasis(8,2) = 0.0d0 8990 CurlBasis(8,3) = ((-1.0d0 + 2*u)*w*(1.0d0 + w))/8.0d0 8991 IF (nj<ni) THEN 8992 EdgeBasis(8,:) = -EdgeBasis(8,:) 8993 CurlBasis(8,:) = -CurlBasis(8,:) 8994 END IF 8995 8996 i = EdgeMap(9,1) 8997 j = EdgeMap(9,2) 8998 ni = Element % NodeIndexes(i) 8999 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9000 nj = Element % NodeIndexes(j) 9001 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9002 EdgeBasis(9,1) = 0.0d0 9003 EdgeBasis(9,2) = 0.0d0 9004 EdgeBasis(9,3) = ((-1.0d0 + u)*u*(-1.0d0 + v)*v)/8.0d0 9005 CurlBasis(9,1) = ((-1.0d0 + u)*u*(-1.0d0 + 2*v))/8.0d0 9006 CurlBasis(9,2) = -((-1.0d0 + 2*u)*(-1.0d0 + v)*v)/8.0d0 9007 CurlBasis(9,3) = 0.0d0 9008 IF (nj<ni) THEN 9009 EdgeBasis(9,:) = -EdgeBasis(9,:) 9010 CurlBasis(9,:) = -CurlBasis(9,:) 9011 END IF 9012 9013 i = EdgeMap(10,1) 9014 j = EdgeMap(10,2) 9015 ni = Element % NodeIndexes(i) 9016 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9017 nj = Element % NodeIndexes(j) 9018 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9019 EdgeBasis(10,1) = 0.0d0 9020 EdgeBasis(10,2) = 0.0d0 9021 EdgeBasis(10,3) = (u*(1.0d0 + u)*(-1.0d0 + v)*v)/8.0d0 9022 CurlBasis(10,1) = (u*(1.0d0 + u)*(-1.0d0 + 2*v))/8.0d0 9023 CurlBasis(10,2) = -((1.0d0 + 2*u)*(-1.0d0 + v)*v)/8.0d0 9024 CurlBasis(10,3) = 0.0d0 9025 IF (nj<ni) THEN 9026 EdgeBasis(10,:) = -EdgeBasis(10,:) 9027 CurlBasis(10,:) = -CurlBasis(10,:) 9028 END IF 9029 9030 i = EdgeMap(11,1) 9031 j = EdgeMap(11,2) 9032 ni = Element % NodeIndexes(i) 9033 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9034 nj = Element % NodeIndexes(j) 9035 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9036 EdgeBasis(11,1) = 0.0d0 9037 EdgeBasis(11,2) = 0.0d0 9038 EdgeBasis(11,3) = (u*(1.0d0 + u)*v*(1.0d0 + v))/8.0d0 9039 CurlBasis(11,1) = (u*(1.0d0 + u)*(1.0d0 + 2*v))/8.0d0 9040 CurlBasis(11,2) = -((1.0d0 + 2*u)*v*(1.0d0 + v))/8.0d0 9041 CurlBasis(11,3) = 0.0d0 9042 IF (nj<ni) THEN 9043 EdgeBasis(11,:) = -EdgeBasis(11,:) 9044 CurlBasis(11,:) = -CurlBasis(11,:) 9045 END IF 9046 9047 i = EdgeMap(12,1) 9048 j = EdgeMap(12,2) 9049 ni = Element % NodeIndexes(i) 9050 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9051 nj = Element % NodeIndexes(j) 9052 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9053 EdgeBasis(12,1) = 0.0d0 9054 EdgeBasis(12,2) = 0.0d0 9055 EdgeBasis(12,3) = ((-1.0d0 + u)*u*v*(1.0d0 + v))/8.0d0 9056 CurlBasis(12,1) = ((-1.0d0 + u)*u*(1.0d0 + 2*v))/8.0d0 9057 CurlBasis(12,2) = -((-1.0d0 + 2*u)*v*(1.0d0 + v))/8.0d0 9058 CurlBasis(12,3) = 0.0d0 9059 IF (nj<ni) THEN 9060 EdgeBasis(12,:) = -EdgeBasis(12,:) 9061 CurlBasis(12,:) = -CurlBasis(12,:) 9062 END IF 9063 9064 ! --------------------------------------------------------------------- 9065 ! Additional twelwe basis functions on the square faces (two per face). 9066 ! --------------------------------------------------------------------- 9067 BrickFaceMap(1,:) = (/ 1,2,3,4 /) 9068 BrickFaceMap(2,:) = (/ 5,6,7,8 /) 9069 BrickFaceMap(3,:) = (/ 1,2,6,5 /) 9070 BrickFaceMap(4,:) = (/ 2,3,7,6 /) 9071 BrickFaceMap(5,:) = (/ 4,3,7,8 /) 9072 BrickFaceMap(6,:) = (/ 1,4,8,5 /) 9073 9074 ! The first face: 9075 WorkBasis(1,1) = -((-1.0d0 + v**2)*(-1.0d0 + w)*w)/4.0d0 9076 WorkBasis(1,2) = 0.0d0 9077 WorkBasis(1,3) = 0.0d0 9078 WorkCurlBasis(1,1) = 0.0d0 9079 WorkCurlBasis(1,2) = -((-1.0d0 + v**2)*(-1.0d0 + 2*w))/4.0d0 9080 WorkCurlBasis(1,3) = (v*(-1.0d0 + w)*w)/2.0d0 9081 9082 WorkBasis(2,1) = 0.0d0 9083 WorkBasis(2,2) = -((-1.0d0 + u**2)*(-1.0d0 + w)*w)/4.0d0 9084 WorkBasis(2,3) = 0.0d0 9085 WorkCurlBasis(2,1) = ((-1.0d0 + u**2)*(-1.0d0 + 2*w))/4.0d0 9086 WorkCurlBasis(2,2) = 0.0d0 9087 WorkCurlBasis(2,3) = -(u*(-1.0d0 + w)*w)/2.0d0 9088 9089 DO j=1,4 9090 FaceIndices(j) = Ind(BrickFaceMap(1,j)) 9091 END DO 9092 IF (Parallel) THEN 9093 DO j=1,4 9094 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9095 END DO 9096 END IF 9097 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9098 9099 EdgeBasis(13,:) = D1 * WorkBasis(I1,:) 9100 CurlBasis(13,:) = D1 * WorkCurlBasis(I1,:) 9101 EdgeBasis(14,:) = D2 * WorkBasis(I2,:) 9102 CurlBasis(14,:) = D2 * WorkCurlBasis(I2,:) 9103 9104 ! The second face: 9105 WorkBasis(1,1) = -((-1.0d0 + v**2)*w*(1.0d0 + w))/4.0d0 9106 WorkBasis(1,2) = 0.0d0 9107 WorkBasis(1,3) = 0.0d0 9108 WorkCurlBasis(1,1) = 0.0d0 9109 WorkCurlBasis(1,2) = -((-1.0d0 + v**2)*(1.0d0 + 2*w))/4.0d0 9110 WorkCurlBasis(1,3) = (v*w*(1.0d0 + w))/2.0d0 9111 9112 WorkBasis(2,1) = 0.0d0 9113 WorkBasis(2,2) = -((-1.0d0 + u**2)*w*(1.0d0 + w))/4.0d0 9114 WorkBasis(2,3) = 0.0d0 9115 WorkCurlBasis(2,1) = ((-1.0d0 + u**2)*(1.0d0 + 2*w))/4.0d0 9116 WorkCurlBasis(2,2) = 0.0d0 9117 WorkCurlBasis(2,3) = -(u*w*(1.0d0 + w))/2.0d0 9118 9119 DO j=1,4 9120 FaceIndices(j) = Ind(BrickFaceMap(2,j)) 9121 END DO 9122 IF (Parallel) THEN 9123 DO j=1,4 9124 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9125 END DO 9126 END IF 9127 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9128 9129 EdgeBasis(15,:) = D1 * WorkBasis(I1,:) 9130 CurlBasis(15,:) = D1 * WorkCurlBasis(I1,:) 9131 EdgeBasis(16,:) = D2 * WorkBasis(I2,:) 9132 CurlBasis(16,:) = D2 * WorkCurlBasis(I2,:) 9133 9134 ! The third face: 9135 WorkBasis(1,1) = -((-1.0d0 + v)*v*(-1.0d0 + w**2))/4.0d0 9136 WorkBasis(1,2) = 0.0d0 9137 WorkBasis(1,3) = 0.0d0 9138 WorkCurlBasis(1,1) = 0.0d0 9139 WorkCurlBasis(1,2) = -((-1.0d0 + v)*v*w)/2.0d0 9140 WorkCurlBasis(1,3) = ((-1.0d0 + 2*v)*(-1.0d0 + w**2))/4.0d0 9141 9142 WorkBasis(2,1) = 0.0d0 9143 WorkBasis(2,2) = 0.0d0 9144 WorkBasis(2,3) = -((-1.0d0 + u**2)*(-1.0d0 + v)*v)/4.0d0 9145 WorkCurlBasis(2,1) = -((-1.0d0 + u**2)*(-1.0d0 + 2*v))/4.0d0 9146 WorkCurlBasis(2,2) = (u*(-1.0d0 + v)*v)/2.0d0 9147 WorkCurlBasis(2,3) = 0.0d0 9148 9149 DO j=1,4 9150 FaceIndices(j) = Ind(BrickFaceMap(3,j)) 9151 END DO 9152 IF (Parallel) THEN 9153 DO j=1,4 9154 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9155 END DO 9156 END IF 9157 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9158 9159 EdgeBasis(17,:) = D1 * WorkBasis(I1,:) 9160 CurlBasis(17,:) = D1 * WorkCurlBasis(I1,:) 9161 EdgeBasis(18,:) = D2 * WorkBasis(I2,:) 9162 CurlBasis(18,:) = D2 * WorkCurlBasis(I2,:) 9163 9164 ! The fourth face: 9165 WorkBasis(1,1) = 0.0d0 9166 WorkBasis(1,2) = -(u*(1.0d0 + u)*(-1.0d0 + w**2))/4.0d0 9167 WorkBasis(1,3) = 0.0d0 9168 WorkCurlBasis(1,1) = (u*(1.0d0 + u)*w)/2.0d0 9169 WorkCurlBasis(1,2) = 0.0d0 9170 WorkCurlBasis(1,3) = -((1.0d0 + 2*u)*(-1.0d0 + w**2))/4.0d0 9171 9172 WorkBasis(2,1) = 0.0d0 9173 WorkBasis(2,2) = 0.0d0 9174 WorkBasis(2,3) = -(u*(1.0d0 + u)*(-1 + v**2))/4.0d0 9175 WorkCurlBasis(2,1) = -(u*(1.0d0 + u)*v)/2.0d0 9176 WorkCurlBasis(2,2) = ((1.0d0 + 2*u)*(-1.0d0 + v**2))/4.0d0 9177 WorkCurlBasis(2,3) = 0.0d0 9178 9179 DO j=1,4 9180 FaceIndices(j) = Ind(BrickFaceMap(4,j)) 9181 END DO 9182 IF (Parallel) THEN 9183 DO j=1,4 9184 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9185 END DO 9186 END IF 9187 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9188 9189 EdgeBasis(19,:) = D1 * WorkBasis(I1,:) 9190 CurlBasis(19,:) = D1 * WorkCurlBasis(I1,:) 9191 EdgeBasis(20,:) = D2 * WorkBasis(I2,:) 9192 CurlBasis(20,:) = D2 * WorkCurlBasis(I2,:) 9193 9194 ! The fifth face: 9195 WorkBasis(1,1) = -(v*(1.0d0 + v)*(-1.0d0 + w**2))/4.0d0 9196 WorkBasis(1,2) = 0.0d0 9197 WorkBasis(1,3) = 0.0d0 9198 WorkCurlBasis(1,1) = 0.0d0 9199 WorkCurlBasis(1,2) = -(v*(1.0d0 + v)*w)/2.0d0 9200 WorkCurlBasis(1,3) = ((1.0d0 + 2*v)*(-1.0d0 + w**2))/4.0d0 9201 9202 WorkBasis(2,1) = 0.0d0 9203 WorkBasis(2,2) = 0.0d0 9204 WorkBasis(2,3) = -((-1.0d0 + u**2)*v*(1.0d0 + v))/4.0d0 9205 WorkCurlBasis(2,1) = -((-1.0d0 + u**2)*(1.0d0 + 2*v))/4.0d0 9206 WorkCurlBasis(2,2) = (u*v*(1.0d0 + v))/2.0d0 9207 WorkCurlBasis(2,3) = 0.0d0 9208 9209 DO j=1,4 9210 FaceIndices(j) = Ind(BrickFaceMap(5,j)) 9211 END DO 9212 IF (Parallel) THEN 9213 DO j=1,4 9214 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9215 END DO 9216 END IF 9217 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9218 9219 EdgeBasis(21,:) = D1 * WorkBasis(I1,:) 9220 CurlBasis(21,:) = D1 * WorkCurlBasis(I1,:) 9221 EdgeBasis(22,:) = D2 * WorkBasis(I2,:) 9222 CurlBasis(22,:) = D2 * WorkCurlBasis(I2,:) 9223 9224 ! The sixth face: 9225 WorkBasis(1,1) = 0.0d0 9226 WorkBasis(1,2) = -((-1.0d0 + u)*u*(-1.0d0 + w**2))/4.0d0 9227 WorkBasis(1,3) = 0.0d0 9228 WorkCurlBasis(1,1) = ((-1.0d0 + u)*u*w)/2.0d0 9229 WorkCurlBasis(1,2) = 0.0d0 9230 WorkCurlBasis(1,3) = -((-1.0d0 + 2*u)*(-1.0d0 + w**2))/4.0d0 9231 9232 WorkBasis(2,1) = 0.0d0 9233 WorkBasis(2,2) = 0.0d0 9234 WorkBasis(2,3) = -((-1.0d0 + u)*u*(-1.0d0 + v**2))/4.0d0 9235 WorkCurlBasis(2,1) = -((-1.0d0 + u)*u*v)/2.0d0 9236 WorkCurlBasis(2,2) = ((-1.0d0 + 2*u)*(-1.0d0 + v**2))/4.0d0 9237 WorkCurlBasis(2,3) = 0.0d0 9238 9239 DO j=1,4 9240 FaceIndices(j) = Ind(BrickFaceMap(6,j)) 9241 END DO 9242 IF (Parallel) THEN 9243 DO j=1,4 9244 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9245 END DO 9246 END IF 9247 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9248 9249 EdgeBasis(23,:) = D1 * WorkBasis(I1,:) 9250 CurlBasis(23,:) = D1 * WorkCurlBasis(I1,:) 9251 EdgeBasis(24,:) = D2 * WorkBasis(I2,:) 9252 CurlBasis(24,:) = D2 * WorkCurlBasis(I2,:) 9253 9254 ! ------------------------------------------------------------------------ 9255 ! Additional basis functions on the element interior (three per element) 9256 ! ----------------------------------------------------------------------- 9257 EdgeBasis(25,1) = ((-1.0d0 + v**2)*(-1.0d0 + w**2))/2.0d0 9258 EdgeBasis(25,2) = 0.0d0 9259 EdgeBasis(25,3) = 0.0d0 9260 CurlBasis(25,1) = 0.0d0 9261 CurlBasis(25,2) = (-1.0d0 + v**2)*w 9262 CurlBasis(25,3) = v - v*w**2 9263 9264 EdgeBasis(26,1) = 0.0d0 9265 EdgeBasis(26,2) = ((-1.0d0 + u**2)*(-1.0d0 + w**2))/2.0d0 9266 EdgeBasis(26,3) = 0.0d0 9267 CurlBasis(26,1) = w - u**2*w 9268 CurlBasis(26,2) = 0.0d0 9269 CurlBasis(26,3) = u*(-1 + w**2) 9270 9271 EdgeBasis(27,1) = 0.0d0 9272 EdgeBasis(27,2) = 0.0d0 9273 EdgeBasis(27,3) = ((-1.0d0 + u**2)*(-1.0d0 + v**2))/2.0d0 9274 CurlBasis(27,1) = (-1.0d0 + u**2)*v 9275 CurlBasis(27,2) = u - u*v**2 9276 CurlBasis(27,3) = 0.0d0 9277 END IF 9278 9279 CASE DEFAULT 9280 CALL Fatal('ElementDescription::EdgeElementInfo','Unsupported element type') 9281 END SELECT 9282 END IF 9283 9284 IF (cdim == dim) THEN 9285 !-------------------------------------------------------------------------------- 9286 ! To optimize computation, this branch avoids calling the ElementMetric function 9287 ! since all necessary data has already been found via PiolaTransformationData. 9288 !------------------------------------------------------------------------------- 9289 IF (PerformPiolaTransform) THEN 9290 DO j=1,DOFs 9291 DO k=1,dim 9292 B(k) = SUM( LG(k,1:dim) * EdgeBasis(j,1:dim) ) 9293 END DO 9294 EdgeBasis(j,1:dim) = B(1:dim) 9295 9296 IF (dim == 2) THEN 9297 CurlBasis(j,3) = 1.0d0/DetF * CurlBasis(j,3) 9298 ELSE 9299 DO k=1,dim 9300 B(k) = 1.0d0/DetF * SUM( LF(k,1:dim) * CurlBasis(j,1:dim) ) 9301 END DO 9302 CurlBasis(j,1:dim) = B(1:dim) 9303 END IF 9304 END DO 9305 ! Make the returned value DetF to act as a metric term for integration 9306 ! over the volume of the element: 9307 DetF = ABS(DetF) 9308 END IF 9309 9310 ! ---------------------------------------------------------------------- 9311 ! Get global first derivatives of the nodal basis functions if wanted: 9312 ! ---------------------------------------------------------------------- 9313 IF ( PRESENT(dBasisdx) ) THEN 9314 dBasisdx = 0.0d0 9315 DO i=1,n 9316 DO j=1,dim 9317 DO k=1,dim 9318 dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LG(j,k) 9319 END DO 9320 END DO 9321 END DO 9322 END IF 9323 ELSE 9324 ! ---------------------------------------------------------------------- 9325 ! We should enter this branch in the case of 2-D elements (dim=2) 9326 ! embedded in the three-dimensional space (cdim=3). The following function 9327 ! defines LG to be the transpose of the pseudoinverse of F = LF. 9328 ! ---------------------------------------------------------------------- 9329 IF (PerformPiolaTransform .OR. PRESENT(dBasisdx) .OR. ApplyTraceMapping) THEN 9330 IF ( .NOT. ElementMetric( n, Element, Nodes, & 9331 ElmMetric, detJ, dLBasisdx, LG ) ) THEN 9332 stat = .FALSE. 9333 RETURN 9334 END IF 9335 END IF 9336 9337 IF (ApplyTraceMapping) THEN 9338 ! Perform operation b -> b x n. The resulting field transforms under the usual 9339 ! Piola transform (like div-conforming field). For a general surface element 9340 ! embedded in 3D we return B(f(p))=1/sqrt(a) F(b x n) where a is the determinant of 9341 ! the metric tensor, F=[a1 a2] with a1 and a2 surface basis vectors and (b x n) is 9342 ! considered to be 2-vector (the trivial component ignored). Note that asking simultaneously 9343 ! for the curl of the basis is not an expected combination. 9344 DO j=1,DOFs 9345 WorkBasis(1,1:2) = EdgeBasis(j,1:2) 9346 EdgeBasis(j,1) = WorkBasis(1,2) 9347 EdgeBasis(j,2) = -WorkBasis(1,1) 9348 END DO 9349 IF (PerformPiolaTransform) THEN 9350 DO j=1,DOFs 9351 DO k=1,cdim 9352 B(k) = SUM( LF(k,1:dim) * EdgeBasis(j,1:dim) ) / DetJ 9353 END DO 9354 EdgeBasis(j,1:cdim) = B(1:cdim) 9355 END DO 9356 END IF 9357 ELSE 9358 IF (PerformPiolaTransform) THEN 9359 DO j=1,DOFs 9360 DO k=1,cdim 9361 B(k) = SUM( LG(k,1:dim) * EdgeBasis(j,1:dim) ) 9362 END DO 9363 EdgeBasis(j,1:cdim) = B(1:cdim) 9364 ! The returned spatial curl in the case cdim=3 and dim=2 handled here 9365 ! has limited usability. This handles only a transformation of 9366 ! the type x_3 = p_3: 9367 CurlBasis(j,3) = 1.0d0/DetJ * CurlBasis(j,3) 9368 END DO 9369 END IF 9370 END IF 9371 9372 ! Make the returned value DetF to act as a metric term for integration 9373 ! over the volume of the element: 9374 DetF = DetJ 9375 9376 ! ---------------------------------------------------------------------- 9377 ! Get global first derivatives of the nodal basis functions if wanted: 9378 ! ---------------------------------------------------------------------- 9379 IF ( PRESENT(dBasisdx) ) THEN 9380 dBasisdx = 0.0d0 9381 DO i=1,n 9382 DO j=1,cdim 9383 DO k=1,dim 9384 dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LG(j,k) 9385 END DO 9386 END DO 9387 END DO 9388 END IF 9389 9390 END IF 9391 9392 IF(PRESENT(F)) F = LF 9393 IF(PRESENT(G)) G = LG 9394 IF(PRESENT(RotBasis)) RotBasis(1:DOFs,:) = CurlBasis(1:DOFs,:) 9395!----------------------------------------------------------------------------- 9396 END FUNCTION EdgeElementInfo 9397!------------------------------------------------------------------------------ 9398 9399 9400 9401!---------------------------------------------------------------------------- 9402 SUBROUTINE TriangleFaceDofsOrdering(I1,I2,D1,D2,Ind) 9403!----------------------------------------------------------------------------- 9404! This is used for selecting what additional basis functions are associated 9405! with a triangular face in the case of second-order approximation. 9406! ---------------------------------------------------------------------------- 9407 INTEGER :: I1, I2, Ind(4) 9408 REAL(KIND=dp) :: D1, D2 9409!--------------------------------------------------------------------------- 9410 INTEGER :: k, A 9411! -------------------------------------------------------------------------- 9412 D1 = 1.0d0 9413 D2 = 1.0d0 9414 IF ( Ind(1) < Ind(2) ) THEN 9415 k = 1 9416 ELSE 9417 k = 2 9418 END IF 9419 IF ( Ind(k) > Ind(3) ) THEN 9420 k = 3 9421 END IF 9422 A = k 9423 9424 SELECT CASE(A) 9425 CASE(1) 9426 IF (Ind(3) > Ind(2)) THEN 9427 ! C = 3 9428 I1 = 1 9429 I2 = 2 9430 ELSE 9431 ! C = 2 9432 I1 = 2 9433 I2 = 1 9434 END IF 9435 CASE(2) 9436 IF (Ind(3) > Ind(1)) THEN 9437 ! C = 3 9438 I1 = 1 9439 I2 = 3 9440 D1 = -1.0d0 9441 ELSE 9442 ! C = 1 9443 I1 = 3 9444 I2 = 1 9445 D2 = -1.0d0 9446 END IF 9447 CASE(3) 9448 IF (Ind(2) > Ind(1)) THEN 9449 ! C = 2 9450 I1 = 2 9451 I2 = 3 9452 ELSE 9453 ! C = 1 9454 I1 = 3 9455 I2 = 2 9456 END IF 9457 D1 = -1.0d0 9458 D2 = -1.0d0 9459 CASE DEFAULT 9460 CALL Fatal('ElementDescription::TriangleFaceDofsOrdering','Erratic square face Indices') 9461 END SELECT 9462!--------------------------------------------------------- 9463 END SUBROUTINE TriangleFaceDofsOrdering 9464!----------------------------------------------------------- 9465 9466 9467!------------------------------------------------------------- 9468 SUBROUTINE TriangleFaceDofsOrdering2(t,s,Ind) 9469!------------------------------------------------------------------------------- 9470! Returns two unit vectors t and s for spanning constant vector fields 9471! defined on a triangular face. As a rule for orientation, the vector t is defined 9472! as t = Grad L_B - Grad L_A where L_A and L_B are the Lagrange basis functions 9473! associated with the nodes that has the smallest global indices A and B (A<B). 9474! Then s = Sqrt(3)* grad L_C, with C corresponding to the largest global index. 9475!------------------------------------------------------------------------------- 9476 INTEGER :: Ind(4) 9477 REAL(KIND=dp) :: t(3), s(3) 9478!---------------------------------------------------------- 9479 INTEGER :: k, A 9480! ------------------------------------------------------------------- 9481 t = 0.0d0 9482 s = 0.0d0 9483 9484 IF ( Ind(1) < Ind(2) ) THEN 9485 k = 1 9486 ELSE 9487 k = 2 9488 END IF 9489 IF ( Ind(k) > Ind(3) ) THEN 9490 k = 3 9491 END IF 9492 A = k 9493 9494 SELECT CASE(A) 9495 CASE(1) 9496 IF ( Ind(2) < Ind(3) ) THEN ! B=2, tangent = AB = 12 9497 t(1) = 1.0d0 9498 t(2) = 0.0 9499 s(1) = 0.0d0 9500 s(2) = 1.0d0 9501 ELSE ! B=3, tangent = AB = 13 9502 t(1) = 0.5d0 9503 t(2) = Sqrt(3.0d0)/2.0d0 9504 s(1) = Sqrt(3.0d0)/2.0d0 9505 s(2) = -0.5d0 9506 END IF 9507 CASE(2) 9508 IF ( Ind(1) < Ind(3) ) THEN ! B=1, tangent = AB = 21 9509 t(1) = -1.0d0 9510 t(2) = 0.0 9511 s(1) = 0.0d0 9512 s(2) = 1.0d0 9513 ELSE ! B=3, tangent = AB = 23 9514 t(1) = -0.5d0 9515 t(2) = Sqrt(3.0d0)/2.0d0 9516 s(1) = -Sqrt(3.0d0)/2.0d0 9517 s(2) = -0.5d0 9518 END IF 9519 CASE(3) 9520 IF ( Ind(1) < Ind(2) ) THEN ! B=1, tangent = AB = 31 9521 t(1) = -0.5d0 9522 t(2) = -Sqrt(3.0d0)/2.0d0 9523 s(1) = Sqrt(3.0d0)/2.0d0 9524 s(2) = -0.5d0 9525 ELSE ! B=2, tangent = AB = 32 9526 t(1) = 0.5d0 9527 t(2) = -Sqrt(3.0d0)/2.0d0 9528 s(1) = -Sqrt(3.0d0)/2.0d0 9529 s(2) = -0.5d0 9530 END IF 9531 CASE DEFAULT 9532 CALL Fatal('ElementDescription::TriangleFaceDofsOrdering','Erratic square face Indices') 9533 END SELECT 9534!--------------------------------------------------------- 9535 END SUBROUTINE TriangleFaceDofsOrdering2 9536!----------------------------------------------------------- 9537 9538 9539!--------------------------------------------------------- 9540 SUBROUTINE SquareFaceDofsOrdering(I1,I2,D1,D2,Ind) 9541!----------------------------------------------------------- 9542 INTEGER :: I1, I2, Ind(4) 9543 REAL(KIND=dp) :: D1, D2 9544!---------------------------------------------------------- 9545 INTEGER :: i, j, k, l, A 9546! ------------------------------------------------------------------- 9547! Find input for applying an order change and sign reversions to two 9548! basis functions associated with a square face. To this end, 9549! find nodes A, B, C such that A has the minimal global index, 9550! AB and AC are edges, with C having the largest global index. 9551! Then AB gives the positive direction for the first face DOF and 9552! AC gives the positive direction for the second face DOF. 9553! REMARK: This convention must be followed when creating basis 9554! functions for other element types which are intended to be compatible 9555! with the element type to which this rule is applied. 9556! ------------------------------------------------------------------- 9557 i = 1 9558 j = 2 9559 IF ( Ind(i) < Ind(j) ) THEN 9560 k = i 9561 ELSE 9562 k = j 9563 END IF 9564 i = 4 9565 j = 3 9566 IF ( Ind(i) < Ind(j) ) THEN 9567 l = i 9568 ELSE 9569 l = j 9570 END IF 9571 IF ( Ind(k) > Ind(l) ) THEN 9572 k = l 9573 END IF 9574 A = k 9575 9576 SELECT CASE(A) 9577 CASE(1) 9578 IF ( Ind(2) < Ind(4) ) THEN 9579 I1 = 1 9580 I2 = 2 9581 D1 = 1.0d0 9582 D2 = 1.0d0 9583 ELSE 9584 I1 = 2 9585 I2 = 1 9586 D1 = 1.0d0 9587 D2 = 1.0d0 9588 END IF 9589 CASE(2) 9590 IF ( Ind(3) < Ind(1) ) THEN 9591 I1 = 2 9592 I2 = 1 9593 D1 = 1.0d0 9594 D2 = -1.0d0 9595 ELSE 9596 I1 = 1 9597 I2 = 2 9598 D1 = -1.0d0 9599 D2 = 1.0d0 9600 END IF 9601 CASE(3) 9602 IF ( Ind(4) < Ind(2) ) THEN 9603 I1 = 1 9604 I2 = 2 9605 D1 = -1.0d0 9606 D2 = -1.0d0 9607 ELSE 9608 I1 = 2 9609 I2 = 1 9610 D1 = -1.0d0 9611 D2 = -1.0d0 9612 END IF 9613 CASE(4) 9614 IF ( Ind(1) < Ind(3) ) THEN 9615 I1 = 2 9616 I2 = 1 9617 D1 = -1.0d0 9618 D2 = 1.0d0 9619 ELSE 9620 I1 = 1 9621 I2 = 2 9622 D1 = 1.0d0 9623 D2 = -1.0d0 9624 END IF 9625 CASE DEFAULT 9626 CALL Fatal('ElementDescription::SquareFaceDofsOrdering','Erratic square face Indices') 9627 END SELECT 9628!---------------------------------------------------------- 9629 END SUBROUTINE SquareFaceDofsOrdering 9630!---------------------------------------------------------- 9631 9632!---------------------------------------------------------------------------------- 9633!> Returns data for rearranging H(curl)-conforming basis functions so that 9634!> compatibility with the convention for defining global DOFs is attained. 9635!> If n basis function value have already been tabulated in the default order 9636!> as BasisArray(1:n,:), then SignVec(1:n) * BasisArray(PermVec(1:n),:) gives 9637!> the basis vector values corresponding to the global DOFs. 9638!> TO DO: support for second-order basis functions, triangles and quads missing 9639!------------------------------------------------------------------------------------ 9640 SUBROUTINE ReorderingAndSignReversionsData(Element,Nodes,PermVec,SignVec) 9641!------------------------------------------------------------------------------------- 9642 IMPLICIT NONE 9643 9644 TYPE(Element_t), TARGET :: Element !< Element structure 9645 TYPE(Nodes_t) :: Nodes !< Data corresponding to the classic element nodes 9646 INTEGER :: PermVec(:) !< At exit the permution vector for performing reordering 9647 REAL(KIND=dp) :: SignVec(:) !< At exit the vector for performing sign changes 9648!--------------------------------------------------------------------------------------------------- 9649 TYPE(Mesh_t), POINTER :: Mesh 9650 INTEGER, POINTER :: EdgeMap(:,:), Ind(:) 9651 INTEGER :: SquareFaceMap(4), BrickFaceMap(6,4), PrismSquareFaceMap(3,4), DOFs, i, j, k 9652 INTEGER :: FaceIndices(4), I1, I2, ni, nj 9653 REAL(KIND=dp) :: D1, D2 9654 LOGICAL :: Parallel 9655!--------------------------------------------------------------------------------------------------- 9656 Mesh => CurrentModel % Solver % Mesh 9657 !Parallel = ParEnv % PEs>1 9658 Parallel = ASSOCIATED(Mesh % ParallelInfo % Interface) 9659 9660 SignVec = 1.0d0 9661 Ind => Element % Nodeindexes 9662 9663 SELECT CASE( Element % TYPE % ElementCode / 100 ) 9664 !CASE(3) needs to be done 9665 9666 !CASE(4) needs to be done 9667 9668 CASE(5) 9669 ! NOTE: The Nedelec second family is not yet supported 9670 EdgeMap => GetEdgeMap(5) 9671 DO k=1,6 9672 i = EdgeMap(k,1) 9673 j = EdgeMap(k,2) 9674 ni = Ind(i) 9675 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9676 nj = Ind(j) 9677 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9678 IF (nj<ni) SignVec(k) = -1.0d0 9679 PermVec(k) = k 9680 END DO 9681 9682 CASE(6) 9683 EdgeMap => GetEdgeMap(6) 9684 DO k=1,8 9685 i = EdgeMap(k,1) 9686 j = EdgeMap(k,2) 9687 ni = Ind(i) 9688 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9689 nj = Ind(j) 9690 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9691 IF (nj<ni) SignVec(k) = -1.0d0 9692 PermVec(k) = k 9693 END DO 9694 ! ----------------------------------------------------- 9695 ! Additional two basis functions on the square face 9696 ! ----------------------------------------------------- 9697 SquareFaceMap(:) = (/ 1,2,3,4 /) 9698 DO j=1,4 9699 FaceIndices(j) = Ind(SquareFaceMap(j)) 9700 END DO 9701 IF (Parallel) THEN 9702 DO j=1,4 9703 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9704 END DO 9705 END IF 9706 9707 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9708 i = 8 9709 PermVec(i+1) = i+I1 9710 PermVec(i+2) = i+I2 9711 SignVec(i+1) = D1 9712 SignVec(i+2) = D2 9713 9714 CASE(7) 9715 EdgeMap => GetEdgeMap(7) 9716 DO k=1,9 9717 i = EdgeMap(k,1) 9718 j = EdgeMap(k,2) 9719 ni = Ind(i) 9720 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9721 nj = Ind(j) 9722 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9723 IF (nj<ni) SignVec(k) = -1.0d0 9724 PermVec(k) = k 9725 END DO 9726 ! --------------------------------------------------------------------- 9727 ! Additional six basis functions on the square faces (two per face). 9728 ! --------------------------------------------------------------------- 9729 PrismSquareFaceMap(1,:) = (/ 1,2,5,4 /) 9730 PrismSquareFaceMap(2,:) = (/ 2,3,6,5 /) 9731 PrismSquareFaceMap(3,:) = (/ 3,1,4,6 /) 9732 DO k=1,3 9733 DO j=1,4 9734 FaceIndices(j) = Ind(PrismSquareFaceMap(k,j)) 9735 END DO 9736 IF (Parallel) THEN 9737 DO j=1,4 9738 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9739 END DO 9740 END IF 9741 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9742 i = 9+(k-1)*2 9743 PermVec(i+1) = i+I1 9744 PermVec(i+2) = i+I2 9745 SignVec(i+1) = D1 9746 SignVec(i+2) = D2 9747 END DO 9748 9749 CASE(8) 9750 EdgeMap => GetEdgeMap(8) 9751 DO k=1,12 9752 i = EdgeMap(k,1) 9753 j = EdgeMap(k,2) 9754 ni = Ind(i) 9755 IF (Parallel) ni=Mesh % ParallelInfo % GlobalDOFs(ni) 9756 nj = Ind(j) 9757 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9758 IF (nj<ni) SignVec(k) = -1.0d0 9759 PermVec(k) = k 9760 END DO 9761 ! --------------------------------------------------------------------- 9762 ! Additional twelwe basis functions on the square faces (two per face). 9763 ! --------------------------------------------------------------------- 9764 BrickFaceMap(1,:) = (/ 1,2,3,4 /) 9765 BrickFaceMap(2,:) = (/ 5,6,7,8 /) 9766 BrickFaceMap(3,:) = (/ 1,2,6,5 /) 9767 BrickFaceMap(4,:) = (/ 2,3,7,6 /) 9768 BrickFaceMap(5,:) = (/ 4,3,7,8 /) 9769 BrickFaceMap(6,:) = (/ 1,4,8,5 /) 9770 DO k=1,6 9771 DO j=1,4 9772 FaceIndices(j) = Ind(BrickFaceMap(k,j)) 9773 END DO 9774 IF (Parallel) THEN 9775 DO j=1,4 9776 FaceIndices(j) = Mesh % ParallelInfo % GlobalDOFs(FaceIndices(j)) 9777 END DO 9778 END IF 9779 CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices) 9780 i = 12+(k-1)*2 9781 PermVec(i+1) = i+I1 9782 PermVec(i+2) = i+I2 9783 SignVec(i+1) = D1 9784 SignVec(i+2) = D2 9785 END DO 9786 PermVec(25) = 25 9787 PermVec(26) = 26 9788 PermVec(27) = 27 9789 9790 CASE DEFAULT 9791 CALL Fatal('ElementDescription::ReorderingAndSignReversionsData','Unsupported element type') 9792 END SELECT 9793!---------------------------------------------------------- 9794 END SUBROUTINE ReorderingAndSignReversionsData 9795!---------------------------------------------------------- 9796 9797 9798! -------------------------------------------------------------------------------------- 9799!> This subroutine contains an older design for providing edge element basis functions 9800!> of the lowest-degree. Obtaining optimal accuracy with these elements may require that 9801!> the element map is affine, while the edge basis functions given by the newer design 9802!> (the function EdgeElementInfo) should also work on general meshes. 9803!------------------------------------------------------------------------ 9804 SUBROUTINE GetEdgeBasis( Element, WBasis, RotWBasis, Basis, dBasisdx ) 9805!------------------------------------------------------------------------ 9806 TYPE(Element_t),TARGET :: Element 9807 REAL(KIND=dp) :: WBasis(:,:), RotWBasis(:,:), Basis(:), dBasisdx(:,:) 9808!------------------------------------------------------------------------ 9809 TYPE(Element_t),POINTER :: Edge 9810 TYPE(Mesh_t), POINTER :: Mesh 9811 TYPE(Nodes_t), SAVE :: Nodes 9812 REAL(KIND=dp) :: u,v,w,dudx(3,3),du(3),Base,dBase(3),tBase(3), & 9813 rBase(3),triBase(3),dtriBase(3,3), G(3,3), F(3,3), detF, detG, & 9814 EdgeBasis(8,3), CurlBasis(8,3) 9815 LOGICAL :: Parallel,stat 9816 INTEGER :: i,j,k,n,nj,nk,i1,i2 9817 INTEGER, POINTER :: EdgeMap(:,:) 9818!------------------------------------------------------------------------ 9819 Mesh => CurrentModel % Solver % Mesh 9820 Parallel = ASSOCIATED(Mesh % ParallelInfo % Interface) 9821 9822 IF (Element % TYPE % BasisFunctionDegree>1) THEN 9823 CALL Fatal('GetEdgeBasis',"Can't handle but linear elements, sorry.") 9824 END IF 9825 9826 SELECT CASE(Element % TYPE % ElementCode / 100) 9827 CASE(4,7,8) 9828 n = Element % TYPE % NumberOfNodes 9829 u = SUM(Basis(1:n)*Element % TYPE % NodeU(1:n)) 9830 v = SUM(Basis(1:n)*Element % TYPE % NodeV(1:n)) 9831 w = SUM(Basis(1:n)*Element % TYPE % NodeW(1:n)) 9832 9833 dudx(1,:) = MATMUL(Element % TYPE % NodeU(1:n),dBasisdx(1:n,:)) 9834 dudx(2,:) = MATMUL(Element % TYPE % NodeV(1:n),dBasisdx(1:n,:)) 9835 dudx(3,:) = MATMUL(Element % TYPE % NodeW(1:n),dBasisdx(1:n,:)) 9836 9837 triBase(1) = 1-u-v 9838 triBase(2) = u 9839 triBase(3) = v 9840 9841 dtriBase(1,:) = -dudx(1,:)-dudx(2,:) 9842 dtriBase(2,:) = dudx(1,:) 9843 dtriBase(3,:) = dudx(2,:) 9844 CASE(6) 9845 n = Element % TYPE % NumberOfNodes 9846 u = SUM(Basis(1:n)*Element % TYPE % NodeU(1:n)) 9847 v = SUM(Basis(1:n)*Element % TYPE % NodeV(1:n)) 9848 w = SUM(Basis(1:n)*Element % TYPE % NodeW(1:n)) 9849 9850 G(1,:) = MATMUL(Element % TYPE % NodeU(1:n),dBasisdx(1:n,:)) 9851 G(2,:) = MATMUL(Element % TYPE % NodeV(1:n),dBasisdx(1:n,:)) 9852 G(3,:) = MATMUL(Element % TYPE % NodeW(1:n),dBasisdx(1:n,:)) 9853 9854 detG = G(1,1) * ( G(2,2)*G(3,3) - G(2,3)*G(3,2) ) + & 9855 G(1,2) * ( G(2,3)*G(3,1) - G(2,1)*G(3,3) ) + & 9856 G(1,3) * ( G(2,1)*G(3,2) - G(2,2)*G(3,1) ) 9857 detF = 1.0d0/detG 9858 CALL InvertMatrix3x3(G,F,detG) 9859 9860 !------------------------------------------------------------ 9861 ! The basis functions spanning the reference element space and 9862 ! their Curl with respect to the local coordinates 9863 ! ------------------------------------------------------------ 9864 EdgeBasis(1,1) = (1.0d0 - v - w)/4.0d0 9865 EdgeBasis(1,2) = 0.0d0 9866 EdgeBasis(1,3) = (u*(-1.0d0 + v + w))/(4.0d0*(-1.0d0 + w)) 9867 CurlBasis(1,1) = u/(4.0d0*(-1.0d0 + w)) 9868 CurlBasis(1,2) = -(-2.0d0 + v + 2.0d0*w)/(4.0d0*(-1.0d0 + w)) 9869 CurlBasis(1,3) = 0.25d0 9870 9871 EdgeBasis(2,1) = 0.0d0 9872 EdgeBasis(2,2) = (1.0d0 + u - w)/4.0d0 9873 EdgeBasis(2,3) = (v*(1.0d0 + u - w))/(4.0d0 - 4.0d0*w) 9874 CurlBasis(2,1) = (2.0d0 + u - 2.0d0*w)/(4.0d0 - 4.0d0*w) 9875 CurlBasis(2,2) = v/(4.0d0*(-1.0d0 + w)) 9876 CurlBasis(2,3) = 0.25d0 9877 9878 EdgeBasis(3,1) = (1.0d0 + v - w)/4.0d0 9879 EdgeBasis(3,2) = 0.0d0 9880 EdgeBasis(3,3) = (u*(1.0d0 + v - w))/(4.0d0 - 4.0d0*w) 9881 CurlBasis(3,1) = u/(4.0d0 - 4.0d0*w) 9882 CurlBasis(3,2) = (2.0d0 + v - 2.0d0*w)/(4.0d0*(-1.0d0 + w)) 9883 CurlBasis(3,3) = -0.25d0 9884 9885 EdgeBasis(4,1) = 0.0d0 9886 EdgeBasis(4,2) = (1.0d0 - u - w)/4.0d0 9887 EdgeBasis(4,3) = (v*(-1.0d0 + u + w))/(4.0d0*(-1.0d0 + w)) 9888 CurlBasis(4,1) = (-2.0d0 + u + 2.0d0*w)/(4.0d0*(-1.0d0 + w)) 9889 CurlBasis(4,2) = v/(4.0d0 - 4.0d0*w) 9890 CurlBasis(4,3) = -0.25d0 9891 9892 EdgeBasis(5,1) = (w*(-1.0d0 + v + w))/(4.0d0*(-1.0d0 + w)) 9893 EdgeBasis(5,2) = (w*(-1.0d0 + u + w))/(4.0d0*(-1.0d0 + w)) 9894 EdgeBasis(5,3) = (-((-1.0d0 + v)*(-1.0d0 + w)**2) + u*(v - (-1.0d0 + w)**2 - 2.0d0*v*w))/& 9895 (4.0d0*(-1.0d0 + w)**2) 9896 CurlBasis(5,1) = -(-1.0d0 + u + w)/(2.0d0*(-1.0d0 + w)) 9897 CurlBasis(5,2) = (-1.0d0 + v + w)/(2.0d0*(-1.0d0 + w)) 9898 CurlBasis(5,3) = 0.0d0 9899 9900 EdgeBasis(6,1) = -(w*(-1.0d0 + v + w))/(4.0d0*(-1.0d0 + w)) 9901 EdgeBasis(6,2) = (w*(-1.0d0 - u + w))/(4.0d0*(-1.0d0 + w)) 9902 EdgeBasis(6,3) = (-((-1.0d0 + v)*(-1.0d0 + w)**2) + u*((-1.0d0 + w)**2 + v*(-1.0d0 + 2.0d0*w)))/& 9903 (4.0d0*(-1.0d0 + w)**2) 9904 CurlBasis(6,1) = (1.0d0 + u - w)/(2.0d0*(-1.0d0 + w)) 9905 CurlBasis(6,2) = -(-1.0d0 + v + w)/(2.0d0*(-1.0d0 + w)) 9906 CurlBasis(6,3) = 0.0d0 9907 9908 EdgeBasis(7,1) = ((1.0d0 + v - w)*w)/(4.0d0*(-1.0d0 + w)) 9909 EdgeBasis(7,2) = ((1.0d0 + u - w)*w)/(4.0d0*(-1.0d0 + w)) 9910 EdgeBasis(7,3) = ((1.0d0 + v)*(-1.0d0 + w)**2 + u*(v + (-1.0d0 + w)**2 - 2.0d0*v*w))/& 9911 (4.0d0*(-1.0d0 + w)**2) 9912 CurlBasis(7,1) = (1.0d0 + u - w)/(2.0d0 - 2.0d0*w) 9913 CurlBasis(7,2) = (1.0d0 + v - w)/(2.0d0*(-1.0d0 + w)) 9914 CurlBasis(7,3) = 0.0d0 9915 9916 EdgeBasis(8,1) = (w*(-1.0d0 - v + w))/(4.0d0*(-1.0d0 + w)) 9917 EdgeBasis(8,2) = -(w*(-1.0d0 + u + w))/(4.0d0*(-1.0d0 + w)) 9918 EdgeBasis(8,3) = ((1.0d0 + v)*(-1.0d0 + w)**2 - u*(v + (-1.0d0 + w)**2 - 2.0d0*v*w))/& 9919 (4.0d0*(-1.0d0 + w)**2) 9920 CurlBasis(8,1) = (-1.0d0 + u + w)/(2.0d0*(-1.0d0 + w)) 9921 CurlBasis(8,2) = (1.0d0 + v - w)/(2.0d0 - 2.0d0*w) 9922 CurlBasis(8,3) = 0.0d0 9923 9924 END SELECT 9925 9926 EdgeMap => GetEdgeMap(Element % TYPE % ElementCode / 100) 9927 DO i=1,SIZE(Edgemap,1) 9928 j = EdgeMap(i,1); k = EdgeMap(i,2) 9929 9930 nj = Element % Nodeindexes(j) 9931 IF (Parallel) nj=Mesh % ParallelInfo % GlobalDOFs(nj) 9932 nk = Element % Nodeindexes(k) 9933 IF (Parallel) nk=Mesh % ParallelInfo % GlobalDOFs(nk) 9934 9935 SELECT CASE(Element % TYPE % ElementCode / 100) 9936 CASE(3,5) 9937 WBasis(i,:) = Basis(j)*dBasisdx(k,:) - Basis(k)*dBasisdx(j,:) 9938 9939 RotWBasis(i,1) = 2.0_dp * ( dBasisdx(j,2) * dBasisdx(k,3) - & 9940 dBasisdx(j,3) * dBasisdx(k,2) ) 9941 RotWBasis(i,2) = 2.0_dp * ( dBasisdx(j,3) * dBasisdx(k,1) - & 9942 dBasisdx(j,1) * dBasisdx(k,3) ) 9943 RotWBasis(i,3) = 2.0_dp * ( dBasisdx(j,1) * dBasisdx(k,2) - & 9944 dBasisdx(j,2) * dBasisdx(k,1) ) 9945 9946 CASE(6) 9947 !----------------------------------------------------------------------- 9948 ! Create the referential description of basis functions and their 9949 ! spatial curl on the physical element via applying the Piola transform: 9950 !----------------------------------------------------------------------- 9951 DO k=1,3 9952 WBasis(i,k) = SUM( G(1:3,k) * EdgeBasis(i,1:3) ) 9953 END DO 9954 DO k=1,3 9955 RotWBasis(i,k) = 1.0d0/DetF * SUM( F(k,1:3) * CurlBasis(i,1:3) ) 9956 END DO 9957 9958 CASE(7) 9959 SELECT CASE(i) 9960 CASE(1) 9961 j=1;k=2; Base=(1-w)/2; dBase=-dudx(3,:)/2 9962 CASE(2) 9963 j=2;k=3; Base=(1-w)/2; dBase=-dudx(3,:)/2 9964 CASE(3) 9965 j=3;k=1; Base=(1-w)/2; dBase=-dudx(3,:)/2 9966 CASE(4) 9967 j=1;k=2; Base=(1+w)/2; dBase= dudx(3,:)/2 9968 CASE(5) 9969 j=2;k=3; Base=(1+w)/2; dBase= dudx(3,:)/2 9970 CASE(6) 9971 j=3;k=1; Base=(1+w)/2; dBase= dudx(3,:)/2 9972 CASE(7) 9973 Base=triBase(1); dBase=dtriBase(1,:); du=dudx(3,:)/2 9974 CASE(8) 9975 Base=triBase(2); dBase=dtriBase(2,:); du=dudx(3,:)/2 9976 CASE(9) 9977 Base=triBase(3); dBase=dtriBase(3,:); du=dudx(3,:)/2 9978 END SELECT 9979 9980 IF(i<=6) THEN 9981 tBase = (triBase(j)*dtriBase(k,:)-triBase(k)*dtriBase(j,:)) 9982 rBase(1) = 2*Base*(dtriBase(j,2)*dtriBase(k,3)-dtriBase(k,2)*dtriBase(j,3)) + & 9983 dBase(2)*tBase(3) - dBase(3)*tBase(2) 9984 9985 rBase(2) = 2*Base*(dtriBase(j,3)*dtriBase(k,1)-dtriBase(k,3)*dtriBase(j,1)) + & 9986 dBase(3)*tBase(1) - dBase(1)*tBase(3) 9987 9988 rBase(3) = 2*Base*(dtriBase(j,1)*dtriBase(k,2)-dtriBase(k,1)*dtriBase(j,2)) + & 9989 dBase(1)*tBase(2) - dBase(2)*tBase(1) 9990 9991 RotWBasis(i,:)=rBase 9992 WBasis(i,:)=tBase*Base 9993 ELSE 9994 WBasis(i,:)=Base*du 9995 RotWBasis(i,1)=(dBase(2)*du(3) - dBase(3)*du(2)) 9996 RotWBasis(i,2)=(dBase(3)*du(1) - dBase(1)*du(3)) 9997 RotWBasis(i,3)=(dBase(1)*du(2) - dBase(2)*du(1)) 9998 END IF 9999 CASE(4) 10000 SELECT CASE(i) 10001 CASE(1) 10002 du=dudx(1,:); Base=(1-v)*(1-w) 10003 dBase(:)=-dudx(2,:)*(1-w)-(1-v)*dudx(3,:) 10004 CASE(2) 10005 du=dudx(2,:); Base=(1+u)*(1-w) 10006 dBase(:)= dudx(1,:)*(1-w)-(1+u)*dudx(3,:) 10007 CASE(3) 10008 du=-dudx(1,:); Base=(1+v)*(1-w) 10009 dBase(:)= dudx(2,:)*(1-w)-(1+v)*dudx(3,:) 10010 CASE(4) 10011 du=-dudx(2,:); Base=(1-u)*(1-w) 10012 dBase(:)=-dudx(1,:)*(1-w)-(1-u)*dudx(3,:) 10013 END SELECT 10014 10015 wBasis(i,:) = Base*du/n 10016 RotWBasis(i,1)=(dBase(2)*du(3) - dBase(3)*du(2))/n 10017 RotWBasis(i,2)=(dBase(3)*du(1) - dBase(1)*du(3))/n 10018 RotWBasis(i,3) = (dBase(1)*du(2) - dBase(2)*du(1))/n 10019 CASE(8) 10020 SELECT CASE(i) 10021 CASE(1) 10022 du=dudx(1,:); Base=(1-v)*(1-w) 10023 dBase(:)=-dudx(2,:)*(1-w)-(1-v)*dudx(3,:) 10024 CASE(2) 10025 du=dudx(2,:); Base=(1+u)*(1-w) 10026 dBase(:)= dudx(1,:)*(1-w)-(1+u)*dudx(3,:) 10027 CASE(3) 10028 du=dudx(1,:); Base=(1+v)*(1-w) 10029 dBase(:)= dudx(2,:)*(1-w)-(1+v)*dudx(3,:) 10030 CASE(4) 10031 du=dudx(2,:); Base=(1-u)*(1-w) 10032 dBase(:)=-dudx(1,:)*(1-w)-(1-u)*dudx(3,:) 10033 CASE(5) 10034 du=dudx(1,:); Base=(1-v)*(1+w) 10035 dBase(:)=-dudx(2,:)*(1+w)+(1-v)*dudx(3,:) 10036 CASE(6) 10037 du=dudx(2,:); Base=(1+u)*(1+w) 10038 dBase(:)= dudx(1,:)*(1+w)+(1+u)*dudx(3,:) 10039 CASE(7) 10040 du=dudx(1,:); Base=(1+v)*(1+w) 10041 dBase(:)= dudx(2,:)*(1+w)+(1+v)*dudx(3,:) 10042 CASE(8) 10043 du=dudx(2,:); Base=(1-u)*(1+w) 10044 dBase(:)=-dudx(1,:)*(1+w)+(1-u)*dudx(3,:) 10045 CASE(9) 10046 du=dudx(3,:); Base=(1-u)*(1-v) 10047 dBase(:)=-dudx(1,:)*(1-v)-(1-u)*dudx(2,:) 10048 CASE(10) 10049 du=dudx(3,:); Base=(1+u)*(1-v) 10050 dBase(:)= dudx(1,:)*(1-v)-(1+u)*dudx(2,:) 10051 CASE(11) 10052 du=dudx(3,:); Base=(1+u)*(1+v) 10053 dBase(:)= dudx(1,:)*(1+v)+(1+u)*dudx(2,:) 10054 CASE(12) 10055 du=dudx(3,:); Base=(1-u)*(1+v) 10056 dBase(:)=-dudx(1,:)*(1+v)+(1-u)*dudx(2,:) 10057 END SELECT 10058 10059 wBasis(i,:)=Base*du/n 10060 RotWBasis(i,1)=(dBase(2)*du(3) - dBase(3)*du(2))/n 10061 RotWBasis(i,2)=(dBase(3)*du(1) - dBase(1)*du(3))/n 10062 RotWBasis(i,3)=(dBase(1)*du(2) - dBase(2)*du(1))/n 10063 CASE DEFAULT 10064 CALL Fatal( 'Edge Basis', 'Not implemented for this element type.') 10065 END SELECT 10066 10067 IF( nk < nj ) THEN 10068 WBasis(i,:) = -WBasis(i,:); RotWBasis(i,:) = -RotWBasis(i,:) 10069 END IF 10070 END DO 10071!------------------------------------------------------------------------------ 10072 END SUBROUTINE GetEdgeBasis 10073!------------------------------------------------------------------------------ 10074 10075 10076!------------------------------------------------------------------------------ 10077!> Compute contravariant metric tensor (=J^TJ)^-1 of element coordinate 10078!> system, and square root of determinant of covariant metric tensor 10079!> (=sqrt(det(J^TJ))) 10080!------------------------------------------------------------------------------ 10081 FUNCTION ElementMetric(nDOFs,Elm,Nodes,Metric,DetG,dLBasisdx,LtoGMap) RESULT(Success) 10082!------------------------------------------------------------------------------ 10083 INTEGER :: nDOFs !< Number of active nodes in element 10084 TYPE(Element_t) :: Elm !< Element structure 10085 TYPE(Nodes_t) :: Nodes !< Element nodal coordinates 10086 REAL(KIND=dp) :: Metric(:,:) !< Contravariant metric tensor 10087 REAL(KIND=dp) :: dLBasisdx(:,:) !< Derivatives of element basis function with respect to local coordinates 10088 REAL(KIND=dp) :: DetG !< SQRT of determinant of metric tensor 10089 REAL(KIND=dp) :: LtoGMap(3,3) !< Transformation to obtain the referential description of the spatial gradient 10090 LOGICAL :: Success !< Returns .FALSE. if element is degenerate 10091!------------------------------------------------------------------------------ 10092! Local variables 10093!------------------------------------------------------------------------------ 10094 10095 REAL(KIND=dp) :: dx(3,3),G(3,3),GI(3,3),s 10096 REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z 10097 INTEGER :: GeomId 10098 10099 INTEGER :: cdim,dim,i,j,k,n 10100!------------------------------------------------------------------------------ 10101 success = .TRUE. 10102 10103 x => Nodes % x 10104 y => Nodes % y 10105 z => Nodes % z 10106 10107 cdim = CoordinateSystemDimension() 10108 n = MIN( SIZE(x), nDOFs ) 10109 dim = elm % TYPE % DIMENSION 10110 10111!------------------------------------------------------------------------------ 10112! Partial derivatives of global coordinates with respect to local coordinates 10113!------------------------------------------------------------------------------ 10114 DO i=1,dim 10115 dx(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) ) 10116 dx(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) ) 10117 dx(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) ) 10118 END DO 10119!------------------------------------------------------------------------------ 10120! Compute the covariant metric tensor of the element coordinate system 10121!------------------------------------------------------------------------------ 10122 DO i=1,dim 10123 DO j=1,dim 10124 s = 0.0d0 10125 DO k=1,cdim 10126 s = s + dx(k,i)*dx(k,j) 10127 END DO 10128 G(i,j) = s 10129 END DO 10130 END DO 10131!------------------------------------------------------------------------------ 10132! Convert the metric to contravariant base, and compute the SQRT(DetG) 10133!------------------------------------------------------------------------------ 10134 SELECT CASE( dim ) 10135!------------------------------------------------------------------------------ 10136! Line elements 10137!------------------------------------------------------------------------------ 10138 CASE (1) 10139 DetG = G(1,1) 10140 10141 IF ( DetG <= TINY( DetG ) ) GOTO 100 10142 10143 Metric(1,1) = 1.0d0 / DetG 10144 DetG = SQRT( DetG ) 10145 10146!------------------------------------------------------------------------------ 10147! Surface elements 10148!------------------------------------------------------------------------------ 10149 CASE (2) 10150 DetG = ( G(1,1)*G(2,2) - G(1,2)*G(2,1) ) 10151 10152 IF ( DetG <= TINY( DetG ) ) GOTO 100 10153 10154 Metric(1,1) = G(2,2) / DetG 10155 Metric(1,2) = -G(1,2) / DetG 10156 Metric(2,1) = -G(2,1) / DetG 10157 Metric(2,2) = G(1,1) / DetG 10158 DetG = SQRT(DetG) 10159 10160!------------------------------------------------------------------------------ 10161! Volume elements 10162!------------------------------------------------------------------------------ 10163 CASE (3) 10164 DetG = G(1,1) * ( G(2,2)*G(3,3) - G(2,3)*G(3,2) ) + & 10165 G(1,2) * ( G(2,3)*G(3,1) - G(2,1)*G(3,3) ) + & 10166 G(1,3) * ( G(2,1)*G(3,2) - G(2,2)*G(3,1) ) 10167 10168 IF ( DetG <= TINY( DetG ) ) GOTO 100 10169 10170 CALL InvertMatrix3x3( G,GI,detG ) 10171 Metric = GI 10172 DetG = SQRT(DetG) 10173 END SELECT 10174 10175!-------------------------------------------------------------------------------------- 10176! Construct a transformation X = LtoGMap such that (grad B)(f(p)) = X(p) Grad b(p), 10177! with Grad the gradient with respect to the reference element coordinates p and 10178! the referential description of the spatial field B(x) satisfying B(f(p)) = b(p). 10179! If cdim > dim (e.g. a surface embedded in the 3-dimensional space), X is 10180! the transpose of the pseudo-inverse of Grad f. 10181!------------------------------------------------------------------------------- 10182 DO i=1,cdim 10183 DO j=1,dim 10184 s = 0.0d0 10185 DO k=1,dim 10186 s = s + dx(i,k) * Metric(k,j) 10187 END DO 10188 LtoGMap(i,j) = s 10189 END DO 10190 END DO 10191 10192! Return here also implies success = .TRUE. 10193 RETURN 10194 10195 10196100 Success = .FALSE. 10197 WRITE( Message,'(A,I0,A,I0)') 'Degenerate ',dim,'D element: ',Elm % ElementIndex 10198 CALL Error( 'ElementMetric', Message ) 10199 10200 IF( ASSOCIATED( Elm % BoundaryInfo ) ) THEN 10201 WRITE( Message,'(A,I0,A,ES12.3)') 'Boundary Id: ',Elm % BoundaryInfo % Constraint,' DetG:',DetG 10202 ELSE 10203 WRITE( Message,'(A,I0,A,ES12.3)') 'Body Id: ',Elm % BodyId,' DetG:',DetG 10204 END IF 10205 CALL Info( 'ElementMetric', Message, Level=3 ) 10206 10207 DO i=1,n 10208 WRITE( Message,'(A,I0,A,3ES12.3)') 'Node: ',i,' Coord:',x(i),y(i),z(i) 10209 CALL Info( 'ElementMetric', Message, Level=3 ) 10210 END DO 10211 DO i=2,n 10212 WRITE( Message,'(A,I0,A,3ES12.3)') 'Node: ',i,' dCoord:',& 10213 x(i)-x(1),y(i)-y(1),z(i)-z(1) 10214 CALL Info( 'ElementMetric', Message, Level=3 ) 10215 END DO 10216 IF ( cdim < dim ) THEN 10217 WRITE( Message,'(A,I0,A,I0)') 'Element dim larger than meshdim: ',dim,' vs. ',cdim 10218 CALL Info( 'ElementMetric', Message, Level=3 ) 10219 END IF 10220 10221!------------------------------------------------------------------------------ 10222 END FUNCTION ElementMetric 10223!------------------------------------------------------------------------------ 10224 10225!------------------------------------------------------------------------------ 10226 FUNCTION ElementMetricVec( Elm, Nodes, nc, ndof, DetJ, nbmax, dLBasisdx, LtoGMap) RESULT(AllSuccess) 10227!------------------------------------------------------------------------------ 10228 TYPE(Element_t) :: Elm !< Element structure 10229 TYPE(Nodes_t) :: Nodes !< element nodal coordinates 10230 INTEGER, INTENT(IN) :: nc !< Number of points to map 10231 INTEGER :: ndof !< Number of active nodes in element 10232 REAL(KIND=dp) :: DetJ(VECTOR_BLOCK_LENGTH) !< SQRT of determinant of element coordinate metric at each point 10233 INTEGER, INTENT(IN) :: nbmax !< Maximum total number of basis functions in local basis 10234 REAL(KIND=dp) :: dLBasisdx(VECTOR_BLOCK_LENGTH,nbmax,3) !< Derivatives of element basis function with 10235 !< respect to local coordinates at each point 10236 REAL(KIND=dp) :: LtoGMap(VECTOR_BLOCK_LENGTH,3,3) !< Mapping between local and global coordinates 10237 LOGICAL :: AllSuccess !< Returns .FALSE. if some point in element is degenerate 10238!------------------------------------------------------------------------------ 10239! Local variables 10240!------------------------------------------------------------------------------ 10241 REAL(KIND=dp) :: dx(VECTOR_BLOCK_LENGTH,3,3) 10242 REAL(KIND=dp) :: Metric(VECTOR_BLOCK_LENGTH,6), & 10243 G(VECTOR_BLOCK_LENGTH,6) ! Symmetric Metric(nc,3,3) and G(nc,3,3) 10244 10245 REAL(KIND=dp) :: s 10246 INTEGER :: cdim,dim,i,j,k,l,n,ip, jj, kk 10247 INTEGER :: ldbasis, ldxyz, utind 10248!DIR$ ATTRIBUTES ALIGN:64::Metric 10249!DIR$ ATTRIBUTES ALIGN:64::dx 10250!DIR$ ATTRIBUTES ALIGN:64::G 10251!DIR$ ASSUME_ALIGNED dLBasisdx:64, LtoGMap:64, DetJ:64 10252 !------------------------------------------------------------------------------ 10253 AllSuccess = .TRUE. 10254 10255 ! Coordinates (single array) 10256 n = MIN( SIZE(Nodes % x, 1), ndof ) 10257 10258 ! Dimensions (coordinate system and element) 10259 cdim = CoordinateSystemDimension() 10260 dim = elm % TYPE % DIMENSION 10261 10262 ! Leading dimensions for local basis and coordinate arrays 10263 ldbasis = SIZE(dLBasisdx, 1) 10264 ldxyz = SIZE(Nodes % xyz, 1) 10265 10266 ! For linear, extruded and otherwise regular elements mapping has to be computed 10267 ! only once, the problem is to identify these cases... 10268 !------------------------------------------------------------------------------ 10269 ! Partial derivatives of global coordinates with respect to local coordinates 10270 !------------------------------------------------------------------------------ 10271 ! Avoid DGEMM calls for nc small 10272 IF (nc < VECTOR_SMALL_THRESH) THEN 10273 DO l=1,dim 10274 DO j=1,3 10275 dx(1:nc,j,l)=REAL(0,dp) 10276 DO k=1,n 10277!DIR$ UNROLL 10278 DO i=1,nc 10279 dx(i,j,l)=dx(i,j,l)+dLBasisdx(i,k,l)*Nodes % xyz(k,j) 10280 END DO 10281 END DO 10282 END DO 10283 END DO 10284 ELSE 10285 DO i=1,dim 10286 CALL DGEMM('N','N',nc, 3, n, & 10287 REAL(1,dp), dLbasisdx(1,1,i), ldbasis, & 10288 Nodes % xyz, ldxyz, REAL(0, dp), dx(1,1,i), VECTOR_BLOCK_LENGTH) 10289 END DO 10290 END IF 10291 !------------------------------------------------------------------------------ 10292 ! Compute the covariant metric tensor of the element coordinate system (symmetric) 10293 !------------------------------------------------------------------------------ 10294 ! Linearized upper triangular indices for accesses to G 10295 ! | (1,1) (1,2) (1,3) | = | 1 2 4 | 10296 ! | (2,2) (2,3) | | 3 5 | 10297 ! | (3,3) | | 6 | 10298 ! G is symmetric, compute only the upper triangular part of G=dx^Tdx 10299!DIR$ LOOP COUNT MAX=3 10300 DO j=1,dim 10301!DIR$ LOOP COUNT MAX=3 10302 DO i=1,j 10303!DIR$ INLINE 10304 utind = GetSymmetricIndex(i,j) 10305 SELECT CASE (cdim) 10306 CASE(1) 10307 !_ELMER_OMP_SIMD 10308 DO l=1,nc 10309 G(l,utind)=dx(l,1,i)*dx(l,1,j) 10310 END DO 10311 CASE(2) 10312 !_ELMER_OMP_SIMD 10313 DO l=1,nc 10314 G(l,utind)=dx(l,1,i)*dx(l,1,j)+dx(l,2,i)*dx(l,2,j) 10315 END DO 10316 CASE(3) 10317 !_ELMER_OMP_SIMD 10318 DO l=1,nc 10319 G(l,utind)=dx(l,1,i)*dx(l,1,j)+dx(l,2,i)*dx(l,2,j)+dx(l,3,i)*dx(l,3,j) 10320 END DO 10321 END SELECT 10322 END DO 10323 END DO 10324 10325 !------------------------------------------------------------------------------ 10326 ! Convert the metric to contravariant base, and compute the SQRT(DetG) 10327 !------------------------------------------------------------------------------ 10328 SELECT CASE( dim ) 10329 !------------------------------------------------------------------------------ 10330 ! Line elements 10331 !------------------------------------------------------------------------------ 10332 CASE (1) 10333 ! Determinants 10334 ! DetJ(1:nc) = G(1:nc,1,1) 10335 DetJ(1:nc) = G(1:nc,1) 10336 10337 DO i=1,nc 10338 IF (DetJ(i) <= TINY(REAL(1,dp))) THEN 10339 AllSuccess = .FALSE. 10340 EXIT 10341 END IF 10342 END DO 10343 10344 IF (AllSuccess) THEN 10345 !_ELMER_OMP_SIMD 10346 DO i=1,nc 10347 ! Metric(i,1,1) = REAL(1,dp)/DetJ(i) 10348 Metric(i,1) = REAL(1,dp)/DetJ(i) 10349 END DO 10350 !_ELMER_OMP_SIMD 10351 DO i=1,nc 10352 DetJ(i) = SQRT( DetJ(i)) 10353 END DO 10354 END IF 10355 10356 10357 !------------------------------------------------------------------------------ 10358 ! Surface elements 10359 !------------------------------------------------------------------------------ 10360 CASE (2) 10361 ! Determinants 10362 !_ELMER_OMP_SIMD 10363 DO i=1,nc 10364 ! DetJ(i) = ( G(i,1,1)*G(i,2,2) - G(i,1,2)*G(i,2,1) ) 10365 ! G is symmetric 10366 DetJ(i) = G(i,1)*G(i,3)-G(i,2)*G(i,2) 10367 END DO 10368 10369 DO i=1,nc 10370 IF (DetJ(i) <= TINY(REAL(1,dp))) THEN 10371 AllSuccess = .FALSE. 10372 EXIT 10373 END IF 10374 END DO 10375 10376 IF (AllSuccess) THEN 10377 ! Since G=G^T, it holds G^{-1}=(G^T)^{-1} 10378 !_ELMER_OMP_SIMD 10379 DO i=1,nc 10380 s = REAL(1,dp)/DetJ(i) 10381 ! G is symmetric 10382 ! All in one go, with redundancies eliminated 10383 Metric(i,1) = s*G(i,3) 10384 Metric(i,2) = -s*G(i,2) 10385 Metric(i,3) = s*G(i,1) 10386 END DO 10387 !_ELMER_OMP_SIMD 10388 DO i=1,nc 10389 DetJ(i) = SQRT(DetJ(i)) 10390 END DO 10391 10392 END IF 10393 !------------------------------------------------------------------------------ 10394 ! Volume elements 10395 !------------------------------------------------------------------------------ 10396 CASE (3) 10397 ! Determinants 10398 !_ELMER_OMP_SIMD 10399 DO i=1,nc 10400 ! DetJ(i) = G(i,1,1) * ( G(i,2,2)*G(i,3,3) - G(i,2,3)*G(i,3,2) ) + & 10401 ! G(i,1,2) * ( G(i,2,3)*G(i,3,1) - G(i,2,1)*G(i,3,3) ) + & 10402 ! G(i,1,3) * ( G(i,2,1)*G(i,3,2) - G(i,2,2)*G(i,3,1) ) 10403 ! G is symmetric 10404 DetJ(i) = G(i,1)*(G(i,3)*G(i,6)-G(i,5)*G(i,5)) + & 10405 G(i,2)*(G(i,5)*G(i,4)-G(i,2)*G(i,6)) + & 10406 G(i,4)*(G(i,2)*G(i,5)-G(i,3)*G(i,4)) 10407 END DO 10408 10409 DO i=1,nc 10410 IF (DetJ(i) <= TINY(REAL(1,dp))) THEN 10411 AllSuccess = .FALSE. 10412 EXIT 10413 END IF 10414 END DO 10415 10416 IF (AllSuccess) THEN 10417 ! Since G=G^T, it holds G^{-1}=(G^T)^{-1} 10418 !_ELMER_OMP_SIMD 10419 DO i=1,nc 10420 s = REAL(1,dp) / DetJ(i) 10421 ! Metric(i,1,1) = s * (G(i,2,2)*G(i,3,3) - G(i,3,2)*G(i,2,3)) 10422 ! Metric(i,2,1) = -s * (G(i,2,1)*G(i,3,3) - G(i,3,1)*G(i,2,3)) 10423 ! Metric(i,3,1) = s * (G(i,2,1)*G(i,3,2) - G(i,3,1)*G(i,2,2)) 10424 ! G is symmetric 10425 10426 ! All in one go, with redundancies eliminated 10427 Metric(i,1)= s*(G(i,3)*G(i,6)-G(i,5)*G(i,5)) 10428 Metric(i,2)=-s*(G(i,2)*G(i,6)-G(i,4)*G(i,5)) 10429 Metric(i,3)= s*(G(i,1)*G(i,6)-G(i,4)*G(i,4)) 10430 Metric(i,4)= s*(G(i,2)*G(i,5)-G(i,3)*G(i,4)) 10431 Metric(i,5)=-s*(G(i,1)*G(i,5)-G(i,2)*G(i,4)) 10432 Metric(i,6)= s*(G(i,1)*G(i,3)-G(i,2)*G(i,2)) 10433 END DO 10434 10435 !_ELMER_OMP_SIMD 10436 DO i=1,nc 10437 DetJ(i) = SQRT(DetJ(i)) 10438 END DO 10439 10440 END IF 10441 END SELECT 10442 10443 IF (AllSuccess) THEN 10444 SELECT CASE(dim) 10445 CASE(1) 10446!DIR$ LOOP COUNT MAX=3 10447 DO i=1,cdim 10448 !_ELMER_OMP_SIMD 10449 DO l=1,nc 10450 LtoGMap(l,i,1) = dx(l,i,1)*Metric(l,1) 10451 END DO 10452 END DO 10453 CASE(2) 10454!DIR$ LOOP COUNT MAX=3 10455 DO i=1,cdim 10456 !_ELMER_OMP_SIMD 10457 DO l=1,nc 10458 LtoGMap(l,i,1) = dx(l,i,1)*Metric(l,1) + dx(l,i,2)*Metric(l,2) 10459 LtoGMap(l,i,2) = dx(l,i,1)*Metric(l,2) + dx(l,i,2)*Metric(l,3) 10460 END DO 10461 END DO 10462 CASE(3) 10463!DIR$ LOOP COUNT MAX=3 10464 DO i=1,cdim 10465 !_ELMER_OMP_SIMD 10466 DO l=1,nc 10467 LtoGMap(l,i,1) = dx(l,i,1)*Metric(l,1) + dx(l,i,2)*Metric(l,2) + dx(l,i,3)*Metric(l,4) 10468 LtoGMap(l,i,2) = dx(l,i,1)*Metric(l,2) + dx(l,i,2)*Metric(l,3) + dx(l,i,3)*Metric(l,5) 10469 LtoGMap(l,i,3) = dx(l,i,1)*Metric(l,4) + dx(l,i,2)*Metric(l,5) + dx(l,i,3)*Metric(l,6) 10470 END DO 10471 END DO 10472 END SELECT 10473 ELSE 10474 10475 ! Degenerate element! 10476 WRITE( Message,'(A,I0,A,I0,A,I0)') 'Degenerate ',dim,'D element: ',Elm % ElementIndex, ', pt=', i 10477 CALL Error( 'ElementMetricVec', Message ) 10478 WRITE( Message,'(A,G10.3)') 'DetG:',DetJ(i) 10479 CALL Info( 'ElementMetricVec', Message, Level=3 ) 10480 DO i=1,cdim 10481 WRITE( Message,'(A,I0,A,3G10.3)') 'Dir: ',i,' Coord:',Nodes % xyz(i,1),& 10482 Nodes % xyz(i,2), Nodes % xyz(i,3) 10483 CALL Info( 'ElementMetricVec', Message, Level=3 ) 10484 END DO 10485 IF (cdim < dim) THEN 10486 WRITE( Message,'(A,I0,A,I0)') 'Element dim larger than meshdim: ',dim,' vs. ',cdim 10487 CALL Info( 'ElementMetricVec', Message, Level=3 ) 10488 END IF 10489 END IF 10490 10491 CONTAINS 10492 10493 FUNCTION GetSymmetricIndex(i,j) RESULT(utind) 10494 IMPLICIT NONE 10495 INTEGER, INTENT(IN) :: i, j 10496 INTEGER :: utind 10497 10498 IF (i>j) THEN 10499 utind = i*(i-1)/2+j 10500 ELSE 10501 utind = j*(j-1)/2+i 10502 END IF 10503 END FUNCTION GetSymmetricIndex 10504!------------------------------------------------------------------------------ 10505 END FUNCTION ElementMetricVec 10506!------------------------------------------------------------------------------ 10507 10508 10509 10510!------------------------------------------------------------------------------ 10511!> Given element structure return value of the first partial derivatives with 10512!> respect to global coordinates of a quantity x given at element nodes at 10513!> local coordinate point u,v,w inside the element. Element basis functions 10514!> are used to compute the value. This is internal version, and shouldn't 10515!> usually be called directly by the user, but through the wrapper routine 10516!> GlobalFirstDerivatives. 10517!------------------------------------------------------------------------------ 10518 SUBROUTINE GlobalFirstDerivativesInternal( elm,nodes,df,gx,gy,gz, & 10519 Metric,dLBasisdx ) 10520!------------------------------------------------------------------------------ 10521! 10522! ARGUMENTS: 10523! Type(Element_t) :: element 10524! INPUT: element structure 10525! 10526! Type(Nodes_t) :: nodes 10527! INPUT: element nodal coordinate arrays 10528! 10529! REAL(KIND=dp) :: f(:) 10530! INPUT: Nodal values of the quantity whose partial derivative we want to know 10531! 10532! REAL(KIND=dp) :: gx = @f(u,v)/@x, gy = @f(u,v)/@y, gz = @f(u,v)/@z 10533! OUTPUT: Values of the partial derivatives 10534! 10535! REAL(KIND=dp) :: Metric(:,:) 10536! INPUT: Contravariant metric tensor of the element coordinate system 10537! 10538! REAL(KIND=dp), OPTIONAL :: dLBasisdx(:,:) 10539! INPUT: Values of partial derivatives with respect to local coordinates 10540! 10541! FUNCTION VALUE: 10542! .TRUE. if element is ok, .FALSE. if degenerated 10543! 10544!------------------------------------------------------------------------------ 10545 ! 10546 ! Return value of first derivatives of a quantity f in global 10547 ! coordinates at point (u,v) in gx,gy and gz. 10548 ! 10549 TYPE(Element_t) :: elm 10550 TYPE(Nodes_t) :: nodes 10551 10552 REAL(KIND=dp) :: df(:),Metric(:,:) 10553 REAL(KIND=dp) :: gx,gy,gz 10554 REAL(KIND=dp) :: dLBasisdx(:,:) 10555 10556!------------------------------------------------------------------------------ 10557! Local variables 10558!------------------------------------------------------------------------------ 10559 10560 REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z 10561 REAL(KIND=dp) :: dx(3,3),dfc(3),s 10562 10563 INTEGER :: cdim,dim,i,j,n,NB 10564!------------------------------------------------------------------------------ 10565 10566 n = elm % TYPE % NumberOfNodes 10567 dim = elm % TYPE % DIMENSION 10568 cdim = CoordinateSystemDimension() 10569 10570 x => nodes % x 10571 y => nodes % y 10572 z => nodes % z 10573!------------------------------------------------------------------------------ 10574! Partial derivatives of global coordinates with respect to local, and 10575! partial derivatives of the quantity given, also with respect to local 10576! coordinates 10577!------------------------------------------------------------------------------ 10578 SELECT CASE(cdim) 10579 CASE(1) 10580 DO i=1,dim 10581 dx(1,i) = SUM( x(1:n)*dLBasisdx(1:n,i) ) 10582 END DO 10583 10584 CASE(2) 10585 DO i=1,dim 10586 dx(1,i) = SUM( x(1:n)*dLBasisdx(1:n,i) ) 10587 dx(2,i) = SUM( y(1:n)*dLBasisdx(1:n,i) ) 10588 END DO 10589 10590 CASE(3) 10591 DO i=1,dim 10592 dx(1,i) = SUM( x(1:n)*dLBasisdx(1:n,i) ) 10593 dx(2,i) = SUM( y(1:n)*dLBasisdx(1:n,i) ) 10594 dx(3,i) = SUM( z(1:n)*dLBasisdx(1:n,i) ) 10595 END DO 10596 END SELECT 10597!------------------------------------------------------------------------------ 10598! Contravariant components of partials in element coordinates 10599!------------------------------------------------------------------------------ 10600 DO i=1,dim 10601 s = 0.0d0 10602 DO j=1,dim 10603 s = s + Metric(i,j) * df(j) 10604 END DO 10605 dfc(i) = s 10606 END DO 10607!------------------------------------------------------------------------------ 10608! Transform partials to space coordinates 10609!------------------------------------------------------------------------------ 10610 gx = 0.0d0 10611 gy = 0.0d0 10612 gz = 0.0d0 10613 SELECT CASE(cdim) 10614 CASE(1) 10615 gx = SUM( dx(1,1:dim) * dfc(1:dim) ) 10616 10617 CASE(2) 10618 gx = SUM( dx(1,1:dim) * dfc(1:dim) ) 10619 gy = SUM( dx(2,1:dim) * dfc(1:dim) ) 10620 10621 CASE(3) 10622 gx = SUM( dx(1,1:dim) * dfc(1:dim) ) 10623 gy = SUM( dx(2,1:dim) * dfc(1:dim) ) 10624 gz = SUM( dx(3,1:dim) * dfc(1:dim) ) 10625 END SELECT 10626 10627 END SUBROUTINE GlobalFirstDerivativesInternal 10628!------------------------------------------------------------------------------ 10629 10630 10631 10632!------------------------------------------------------------------------------ 10633!> Given element structure return value of the first partial derivative with 10634!> respect to global coordinates of a quantity f given at element nodes at 10635!> local coordinate point u,v,w inside the element. Element basis functions 10636!> are used to compute the value. 10637!------------------------------------------------------------------------------ 10638 SUBROUTINE GlobalFirstDerivatives( Elm, Nodes, df, gx, gy, gz, & 10639 Metric, dLBasisdx ) 10640!------------------------------------------------------------------------------ 10641! 10642! ARGUMENTS: 10643! Type(Element_t) :: element 10644! INPUT: element structure 10645! 10646! Type(Nodes_t) :: nodes 10647! INPUT: element nodal coordinate arrays 10648! 10649! REAL(KIND=dp) :: f(:) 10650! INPUT: Nodal values of the quantity whose partial derivatives we want 10651! to know 10652! 10653! REAL(KIND=dp) :: gx=@f(u,v,w)/@x, gy=@f(u,v,w)/@y, gz=@f(u,v,w)/@z 10654! OUTPUT: Values of the partial derivatives 10655! 10656! REAL(KIND=dp) :: u,v,w 10657! INPUT: Point at which to evaluate the partial derivative 10658! 10659! REAL(KIND=dp)L :: dLBasisdx(:,:) 10660! INPUT: Values of partial derivatives of basis functions with respect to 10661! local coordinates 10662! 10663! REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:) 10664! INPUT: Values of partial derivatives of basis functions with respect to 10665! global coordinates can be given here, if known, otherwise they 10666! will be computed from the element basis functions. 10667! 10668!------------------------------------------------------------------------------ 10669 10670 TYPE(Element_t) :: elm 10671 TYPE(Nodes_t) :: nodes 10672 10673 REAL(KIND=dp) :: gx,gy,gz 10674 REAL(KIND=dp) :: dLBasisdx(:,:),Metric(:,:),df(:) 10675 10676! Local variables 10677!------------------------------------------------------------------------------ 10678 INTEGER :: n 10679!------------------------------------------------------------------------------ 10680 10681 CALL GlobalFirstDerivativesInternal( Elm, Nodes, df, & 10682 gx, gy, gz, Metric, dLBasisdx ) 10683 10684 END SUBROUTINE GlobalFirstDerivatives 10685!------------------------------------------------------------------------------ 10686 10687 10688 10689!------------------------------------------------------------------------------ 10690!> Given element structure return value of a quantity x given at element nodes 10691!> at local coordinate point u inside the element. Element basis functions are 10692!> used to compute the value. This is just a wrapper routine and will call the 10693!> real function according to element dimension. 10694!------------------------------------------------------------------------------ 10695 FUNCTION InterpolateInElement( elm,f,u,v,w,Basis ) RESULT(VALUE) 10696!------------------------------------------------------------------------------ 10697! 10698! DESCRIPTION: 10699! 10700! ARGUMENTS: 10701! Type(Element_t) :: element 10702! INPUT: element structure 10703! 10704! REAL(KIND=dp) :: f(:) 10705! INPUT: Nodal values of the quantity whose value we want to know 10706! 10707! REAL(KIND=dp) :: u,v,w 10708! INPUT: Point at which to evaluate the value 10709! 10710! REAL(KIND=dp), OPTIONAL :: Basis(:) 10711! INPUT: Values of the basis functions at the point u,v,w can be given here, 10712! if known, otherwise the will be computed from the definition 10713! 10714! FUNCTION VALUE: 10715! REAL(KIND=dp) :: y 10716! value of the quantity y = x(u,v,w) 10717! 10718!------------------------------------------------------------------------------ 10719 10720 TYPE(Element_t) :: elm 10721 REAL(KIND=dp) :: u,v,w 10722 REAL(KIND=dp) :: f(:) 10723 REAL(KIND=dp), OPTIONAL :: Basis(:) 10724 10725!------------------------------------------------------------------------------ 10726! Local variables 10727!------------------------------------------------------------------------------ 10728 REAL(KIND=dp) :: VALUE 10729 INTEGER :: n 10730 10731 IF ( PRESENT( Basis ) ) THEN 10732!------------------------------------------------------------------------------ 10733! Basis function values given, just sum the result ... 10734!------------------------------------------------------------------------------ 10735 n = elm % TYPE % NumberOfNodes 10736 VALUE = SUM( f(1:n)*Basis(1:n) ) 10737 ELSE 10738!------------------------------------------------------------------------------ 10739! ... otherwise compute from the definition. 10740!------------------------------------------------------------------------------ 10741 SELECT CASE (elm % TYPE % DIMENSION) 10742 CASE (0) 10743 VALUE = f(1) 10744 CASE (1) 10745 VALUE = InterpolateInElement1D( elm,f,u ) 10746 CASE (2) 10747 VALUE = InterpolateInElement2D( elm,f,u,v ) 10748 CASE (3) 10749 VALUE = InterpolateInElement3D( elm,f,u,v,w ) 10750 END SELECT 10751 END IF 10752 10753 END FUNCTION InterpolateInElement 10754!------------------------------------------------------------------------------ 10755 10756 10757 10758!------------------------------------------------------------------------------ 10759!> Compute elementwise matrix of second partial derivatives 10760!> at given point u,v,w in global coordinates. 10761!------------------------------------------------------------------------------ 10762 SUBROUTINE GlobalSecondDerivatives(elm,nodes,f,values,u,v,w,Metric,dBasisdx) 10763!------------------------------------------------------------------------------ 10764! 10765! Parameters: 10766! 10767! Input: (Element_t) structure describing the element 10768! (Nodes_t) element nodal coordinates 10769! (double precision) F nodal values of the quantity 10770! (double precision) u,v point at which to evaluate 10771! 10772! Output: 3x3 matrix (values) of partial derivatives 10773! 10774!------------------------------------------------------------------------------ 10775 10776 TYPE(Nodes_t) :: nodes 10777 TYPE(Element_t) :: elm 10778 10779 REAL(KIND=dp) :: u,v,w 10780 REAL(KIND=dp) :: f(:),Metric(:,:) 10781 REAL(KIND=dp) :: values(:,:) 10782 REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:) 10783!------------------------------------------------------------------------------ 10784! Local variables 10785!------------------------------------------------------------------------------ 10786 INTEGER :: i,j,k,l,dim,cdim 10787 10788 REAL(KIND=dp), DIMENSION(3,3,3) :: C1,C2,ddx 10789 REAL(KIND=dp), DIMENSION(3) :: df 10790 REAL(KIND=dp), DIMENSION(3,3) :: cddf,ddf,dx 10791 10792 REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z 10793 REAL(KIND=dp) :: s 10794 10795 INTEGER :: n 10796!------------------------------------------------------------------------------ 10797#if 1 10798! 10799! This is actually not quite correct... 10800! 10801 IF ( elm % TYPE % BasisFunctionDegree <= 1 ) RETURN 10802#else 10803! 10804! this is ... 10805! 10806 IF ( elm % TYPE % ElementCode <= 202 .OR. & 10807 elm % TYPE % ElementCode == 303 .OR. & 10808 elm % TYPE % ElementCode == 504 ) RETURN 10809#endif 10810 10811 n = elm % TYPE % NumberOfNodes 10812 x => nodes % x 10813 y => nodes % y 10814 z => nodes % z 10815 10816 dim = elm % TYPE % DIMENSION 10817 cdim = CoordinateSystemDimension() 10818 10819!------------------------------------------------------------------------------ 10820! Partial derivatives of the basis functions are given, just 10821! sum for the first partial derivatives... 10822!------------------------------------------------------------------------------ 10823 dx = 0.0d0 10824 df = 0.0d0 10825 SELECT CASE( cdim ) 10826 CASE(1) 10827 DO i=1,dim 10828 dx(1,i) = SUM( x(1:n)*dBasisdx(1:n,i) ) 10829 df(i) = SUM( f(1:n)*dBasisdx(1:n,i) ) 10830 END DO 10831 10832 CASE(2) 10833 DO i=1,dim 10834 dx(1,i) = SUM( x(1:n)*dBasisdx(1:n,i) ) 10835 dx(2,i) = SUM( y(1:n)*dBasisdx(1:n,i) ) 10836 df(i) = SUM( f(1:n)*dBasisdx(1:n,i) ) 10837 END DO 10838 10839 CASE(3) 10840 DO i=1,dim 10841 dx(1,i) = SUM( x(1:n)*dBasisdx(1:n,i) ) 10842 dx(2,i) = SUM( y(1:n)*dBasisdx(1:n,i) ) 10843 dx(3,i) = SUM( z(1:n)*dBasisdx(1:n,i) ) 10844 df(i) = SUM( f(1:n)*dBasisdx(1:n,i) ) 10845 END DO 10846 END SELECT 10847!------------------------------------------------------------------------------ 10848! Get second partial derivatives with respect to local coordinates 10849!------------------------------------------------------------------------------ 10850 SELECT CASE( dim ) 10851 CASE(1) 10852!------------------------------------------------------------------------------ 10853! Line elements 10854!------------------------------------------------------------------------------ 10855 ddx(1,1,1) = SecondDerivatives1D( elm,x,u ) 10856 ddx(2,1,1) = SecondDerivatives1D( elm,y,u ) 10857 ddx(3,1,1) = SecondDerivatives1D( elm,z,u ) 10858 10859 CASE(2) 10860!------------------------------------------------------------------------------ 10861! Surface elements 10862!------------------------------------------------------------------------------ 10863 ddx(1,1:2,1:2) = SecondDerivatives2D( elm,x,u,v ) 10864 ddx(2,1:2,1:2) = SecondDerivatives2D( elm,y,u,v ) 10865 ddx(3,1:2,1:2) = SecondDerivatives2D( elm,z,u,v ) 10866 10867 CASE(3) 10868!------------------------------------------------------------------------------ 10869! Volume elements 10870!------------------------------------------------------------------------------ 10871 ddx(1,1:3,1:3) = SecondDerivatives3D( elm,x,u,v,w ) 10872 ddx(2,1:3,1:3) = SecondDerivatives3D( elm,y,u,v,w ) 10873 ddx(3,1:3,1:3) = SecondDerivatives3D( elm,z,u,v,w ) 10874 END SELECT 10875! 10876!------------------------------------------------------------------------------ 10877! Christoffel symbols of the second kind of the element coordinate system 10878!------------------------------------------------------------------------------ 10879 DO i=1,dim 10880 DO j=1,dim 10881 DO k=1,dim 10882 s = 0.0d0 10883 DO l=1,cdim 10884 s = s + ddx(l,i,j)*dx(l,k) 10885 END DO 10886 C2(i,j,k) = s 10887 END DO 10888 END DO 10889 END DO 10890!------------------------------------------------------------------------------ 10891! Christoffel symbols of the first kind 10892!------------------------------------------------------------------------------ 10893 DO i=1,dim 10894 DO j=1,dim 10895 DO k=1,dim 10896 s = 0.0d0 10897 DO l=1,dim 10898 s = s + Metric(k,l)*C2(i,j,l) 10899 END DO 10900 C1(i,j,k) = s 10901 END DO 10902 END DO 10903 END DO 10904!------------------------------------------------------------------------------ 10905! First add ordinary partials (change of the quantity with coordinates)... 10906!------------------------------------------------------------------------------ 10907 SELECT CASE(dim) 10908 CASE(1) 10909 ddf(1,1) = SecondDerivatives1D( elm,f,u ) 10910 10911 CASE(2) 10912 ddf(1:2,1:2) = SecondDerivatives2D( elm,f,u,v ) 10913 10914 CASE(3) 10915 ddf(1:3,1:3) = SecondDerivatives3D( elm,f,u,v,w ) 10916 END SELECT 10917!------------------------------------------------------------------------------ 10918! ... then add change of coordinates 10919!------------------------------------------------------------------------------ 10920 DO i=1,dim 10921 DO j=1,dim 10922 s = 0.0d0 10923 DO k=1,dim 10924 s = s - C1(i,j,k)*df(k) 10925 END DO 10926 ddf(i,j) = ddf(i,j) + s 10927 END DO 10928 END DO 10929!------------------------------------------------------------------------------ 10930! Convert to contravariant base 10931!------------------------------------------------------------------------------ 10932 DO i=1,dim 10933 DO j=1,dim 10934 s = 0.0d0 10935 DO k=1,dim 10936 DO l=1,dim 10937 s = s + Metric(i,k)*Metric(j,l)*ddf(k,l) 10938 END DO 10939 END DO 10940 cddf(i,j) = s 10941 END DO 10942 END DO 10943!------------------------------------------------------------------------------ 10944! And finally transform to global coordinates 10945!------------------------------------------------------------------------------ 10946 Values = 0.0d0 10947 DO i=1,cdim 10948 DO j=1,cdim 10949 s = 0.0d0 10950 DO k=1,dim 10951 DO l=1,dim 10952 s = s + dx(i,k)*dx(j,l)*cddf(k,l) 10953 END DO 10954 END DO 10955 Values(i,j) = s 10956 END DO 10957 END DO 10958!------------------------------------------------------------------------------ 10959 END SUBROUTINE GlobalSecondDerivatives 10960!------------------------------------------------------------------------------ 10961 10962 10963 10964!------------------------------------------------------------------------------ 10965 FUNCTION GetEdgeMap( ElementFamily ) RESULT(EdgeMap) 10966!------------------------------------------------------------------------------ 10967 INTEGER :: ElementFamily 10968 INTEGER, POINTER :: EdgeMap(:,:) 10969 10970 INTEGER, TARGET :: Point(1,1) 10971 INTEGER, TARGET :: Line(1,2) 10972 INTEGER, TARGET :: Triangle(3,2) 10973 INTEGER, TARGET :: Quad(4,2) 10974 INTEGER, TARGET :: Tetra(6,2) 10975 INTEGER, TARGET :: Pyramid(8,2) 10976 INTEGER, TARGET :: Wedge(9,2) 10977 INTEGER, TARGET :: Brick(12,2) 10978 10979 LOGICAL :: Initialized(8) = .FALSE. 10980 10981 SAVE Line, Triangle, Wedge, Brick, Tetra, Quad, Pyramid, Initialized 10982 10983 SELECT CASE(ElementFamily) 10984 CASE(1) 10985 EdgeMap => Point 10986 CASE(2) 10987 EdgeMap => Line 10988 CASE(3) 10989 EdgeMap => Triangle 10990 CASE(4) 10991 EdgeMap => Quad 10992 CASE(5) 10993 EdgeMap => Tetra 10994 CASE(6) 10995 EdgeMap => Pyramid 10996 CASE(7) 10997 EdgeMap => Wedge 10998 CASE(8) 10999 EdgeMap => Brick 11000 CASE DEFAULT 11001 WRITE( Message,'(A,I0,A)') 'Element family ',ElementFamily,' is not known!' 11002 CALL Fatal( 'GetEdgeMap', Message ) 11003 END SELECT 11004 11005 IF ( .NOT. Initialized(ElementFamily) ) THEN 11006 Initialized(ElementFamily) = .TRUE. 11007 SELECT CASE(ElementFamily) 11008 CASE(1) 11009 EdgeMap(1,1) = 1 11010 11011 CASE(2) 11012 EdgeMap(1,:) = [ 1,2 ] 11013 11014 CASE(3) 11015 EdgeMap(1,:) = [ 1,2 ] 11016 EdgeMap(2,:) = [ 2,3 ] 11017 EdgeMap(3,:) = [ 3,1 ] 11018 11019 CASE(4) 11020 EdgeMap(1,:) = [ 1,2 ] 11021 EdgeMap(2,:) = [ 2,3 ] 11022 EdgeMap(3,:) = [ 3,4 ] 11023 EdgeMap(4,:) = [ 4,1 ] 11024 11025 CASE(5) 11026 EdgeMap(1,:) = [ 1,2 ] 11027 EdgeMap(2,:) = [ 2,3 ] 11028 EdgeMap(3,:) = [ 3,1 ] 11029 EdgeMap(4,:) = [ 1,4 ] 11030 EdgeMap(5,:) = [ 2,4 ] 11031 EdgeMap(6,:) = [ 3,4 ] 11032 11033 CASE(6) 11034 EdgeMap(1,:) = [ 1,2 ] 11035 EdgeMap(2,:) = [ 2,3 ] 11036 EdgeMap(3,:) = [ 4,3 ] 11037 EdgeMap(4,:) = [ 1,4 ] 11038 EdgeMap(5,:) = [ 1,5 ] 11039 EdgeMap(6,:) = [ 2,5 ] 11040 EdgeMap(7,:) = [ 3,5 ] 11041 EdgeMap(8,:) = [ 4,5 ] 11042 11043 CASE(7) 11044 EdgeMap(1,:) = [ 1,2 ] 11045 EdgeMap(2,:) = [ 2,3 ] 11046 EdgeMap(3,:) = [ 3,1 ] 11047 EdgeMap(4,:) = [ 4,5 ] 11048 EdgeMap(5,:) = [ 5,6 ] 11049 EdgeMap(6,:) = [ 6,4 ] 11050 EdgeMap(7,:) = [ 1,4 ] 11051 EdgeMap(8,:) = [ 2,5 ] 11052 EdgeMap(9,:) = [ 3,6 ] 11053 11054 CASE(8) 11055 EdgeMap(1,:) = [ 1,2 ] 11056 EdgeMap(2,:) = [ 2,3 ] 11057 EdgeMap(3,:) = [ 4,3 ] 11058 EdgeMap(4,:) = [ 1,4 ] 11059 EdgeMap(5,:) = [ 5,6 ] 11060 EdgeMap(6,:) = [ 6,7 ] 11061 EdgeMap(7,:) = [ 8,7 ] 11062 EdgeMap(8,:) = [ 5,8 ] 11063 EdgeMap(9,:) = [ 1,5 ] 11064 EdgeMap(10,:) = [ 2,6 ] 11065 EdgeMap(11,:) = [ 3,7 ] 11066 EdgeMap(12,:) = [ 4,8 ] 11067 END SELECT 11068 END IF 11069!------------------------------------------------------------------------------ 11070 END FUNCTION GetEdgeMap 11071!------------------------------------------------------------------------------ 11072 11073 11074 11075!------------------------------------------------------------------------------ 11076!> Figure out element diameter parameter for stablization. 11077!------------------------------------------------------------------------------ 11078 FUNCTION ElementDiameter( elm, nodes, UseLongEdge ) RESULT(hK) 11079!------------------------------------------------------------------------------ 11080 TYPE(Element_t) :: elm !< element structure 11081 TYPE(Nodes_t) :: nodes !< Nodal coordinate arrays of the element 11082 LOGICAL, OPTIONAL :: UseLongEdge !< Use the longest edge to determine the diameter. 11083 REAL(KIND=dp) :: hK !< hK 11084!------------------------------------------------------------------------------ 11085! Local variables 11086!------------------------------------------------------------------------------ 11087 REAL(KIND=dp), DIMENSION(:), POINTER :: X,Y,Z 11088 INTEGER :: i,j,k,Family 11089 INTEGER, POINTER :: EdgeMap(:,:) 11090 REAL(KIND=dp) :: x0,y0,z0,A,S,CX,CY,CZ 11091 REAL(KIND=dp) :: J11,J12,J13,J21,J22,J23,G11,G12,G21,G22 11092 LOGICAL :: LongEdge=.FALSE. 11093!------------------------------------------------------------------------------ 11094 11095 IF(PRESENT(UseLongEdge)) LongEdge = UseLongEdge 11096 11097 X => Nodes % x 11098 Y => Nodes % y 11099 Z => Nodes % z 11100 11101 Family = Elm % TYPE % ElementCode / 100 11102 SELECT CASE( Family ) 11103 11104 CASE(1) 11105 hK = 0.0d0 11106 11107!------------------------------------------------------------------------------ 11108! Triangular element 11109!------------------------------------------------------------------------------ 11110 CASE(3) 11111 J11 = X(2) - X(1) 11112 J12 = Y(2) - Y(1) 11113 J13 = Z(2) - Z(1) 11114 J21 = X(3) - X(1) 11115 J22 = Y(3) - Y(1) 11116 J23 = Z(3) - Z(1) 11117 G11 = J11**2 + J12**2 + J13**2 11118 G12 = J11*J21 + J12*J22 + J13*J23 11119 G22 = J21**2 + J22**2 + J23**2 11120 A = SQRT(G11*G22 - G12**2) / 2.0d0 11121 11122 CX = ( X(1) + X(2) + X(3) ) / 3.0d0 11123 CY = ( Y(1) + Y(2) + Y(3) ) / 3.0d0 11124 CZ = ( Z(1) + Z(2) + Z(3) ) / 3.0d0 11125 11126 s = (X(1)-CX)**2 + (Y(1)-CY)**2 + (Z(1)-CZ)**2 11127 s = s + (X(2)-CX)**2 + (Y(2)-CY)**2 + (Z(2)-CZ)**2 11128 s = s + (X(3)-CX)**2 + (Y(3)-CY)**2 + (Z(3)-CZ)**2 11129 11130 hK = 16.0d0*A*A / ( 3.0d0 * s ) 11131 11132!------------------------------------------------------------------------------ 11133! Quadrilateral 11134!------------------------------------------------------------------------------ 11135 CASE(4) 11136 CX = (X(2)-X(1))**2 + (Y(2)-Y(1))**2 + (Z(2)-Z(1))**2 11137 CY = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 + (Z(4)-Z(1))**2 11138 hk = 2*CX*CY/(CX+CY) 11139 11140 CASE DEFAULT 11141 EdgeMap => GetEdgeMap(Family) 11142 11143 IF(LongEdge) THEN 11144 hK = -1.0 * HUGE(1.0_dp) 11145 ELSE 11146 hK = HUGE(1.0_dp) 11147 END IF 11148 11149 DO i=1,SIZE(EdgeMap,1) 11150 j=EdgeMap(i,1) 11151 k=EdgeMap(i,2) 11152 x0 = X(j) - X(k) 11153 y0 = Y(j) - Y(k) 11154 z0 = Z(j) - Z(k) 11155 IF(LongEdge) THEN 11156 hk = MAX(hK, x0**2 + y0**2 + z0**2) 11157 ELSE 11158 hk = MIN(hK, x0**2 + y0**2 + z0**2) 11159 END IF 11160 END DO 11161 END SELECT 11162 11163 hK = SQRT( hK ) 11164!------------------------------------------------------------------------------ 11165 END FUNCTION ElementDiameter 11166!------------------------------------------------------------------------------ 11167 11168 11169 11170!------------------------------------------------------------------------------ 11171!> Figure out if given point x,y,z is inside a triangle, whose node 11172!> coordinates are given in nx,ny,nz. Method: Invert the basis 11173!> functions.... 11174!------------------------------------------------------------------------------ 11175 FUNCTION TriangleInside( nx,ny,nz,x,y,z ) RESULT(inside) 11176!------------------------------------------------------------------------------ 11177 REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays 11178 REAL(KIND=dp) :: x,y,z !< point which to consider 11179 LOGICAL :: inside !< result of the in/out test 11180!------------------------------------------------------------------------------ 11181! Local variables 11182!------------------------------------------------------------------------------ 11183 REAL(KIND=dp) :: a00,a01,a10,a11,b00,b01,b10,b11,detA,px,py,u,v 11184!------------------------------------------------------------------------------ 11185 11186 inside = .FALSE. 11187 11188 IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y ) RETURN 11189 IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y ) RETURN 11190 11191 A00 = nx(2) - nx(1) 11192 A01 = nx(3) - nx(1) 11193 A10 = ny(2) - ny(1) 11194 A11 = ny(3) - ny(1) 11195 11196 detA = A00*A11 - A01*A10 11197 IF ( ABS(detA) < AEPS ) RETURN 11198 11199 detA = 1 / detA 11200 11201 B00 = A11*detA 11202 B01 = -A01*detA 11203 B10 = -A10*detA 11204 B11 = A00*detA 11205 11206 px = x - nx(1) 11207 py = y - ny(1) 11208 u = 0.0d0 11209 v = 0.0d0 11210 11211 u = B00*px + B01*py 11212 IF ( u < 0.0d0 .OR. u > 1.0d0 ) RETURN 11213 11214 v = B10*px + B11*py 11215 IF ( v < 0.0d0 .OR. v > 1.0d0 ) RETURN 11216 11217 inside = (u + v <= 1.0d0) 11218!------------------------------------------------------------------------------ 11219 END FUNCTION TriangleInside 11220!------------------------------------------------------------------------------ 11221 11222 11223 11224!------------------------------------------------------------------------------ 11225!> Figure out if given point x,y,z is inside a quadrilateral, whose 11226!> node coordinates are given in nx,ny,nz. Method: Invert the 11227!> basis functions.... 11228!------------------------------------------------------------------------------ 11229 FUNCTION QuadInside( nx,ny,nz,x,y,z ) RESULT(inside) 11230!------------------------------------------------------------------------------ 11231 REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays 11232 REAL(KIND=dp) :: x,y,z !< point which to consider 11233 LOGICAL :: inside !< result of the in/out test 11234!------------------------------------------------------------------------------ 11235! Local variables 11236!------------------------------------------------------------------------------ 11237 REAL(KIND=dp) :: r,a,b,c,d,ax,bx,cx,dx,ay,by,cy,dy,px,py,u,v 11238!------------------------------------------------------------------------------ 11239 inside = .FALSE. 11240 11241 IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y ) RETURN 11242 IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y ) RETURN 11243 11244 ax = 0.25*( nx(1) + nx(2) + nx(3) + nx(4) ) 11245 bx = 0.25*( -nx(1) + nx(2) + nx(3) - nx(4) ) 11246 cx = 0.25*( -nx(1) - nx(2) + nx(3) + nx(4) ) 11247 dx = 0.25*( nx(1) - nx(2) + nx(3) - nx(4) ) 11248 11249 ay = 0.25*( ny(1) + ny(2) + ny(3) + ny(4) ) 11250 by = 0.25*( -ny(1) + ny(2) + ny(3) - ny(4) ) 11251 cy = 0.25*( -ny(1) - ny(2) + ny(3) + ny(4) ) 11252 dy = 0.25*( ny(1) - ny(2) + ny(3) - ny(4) ) 11253 11254 px = x - ax 11255 py = y - ay 11256 11257 a = cy*dx - cx*dy 11258 b = bx*cy - by*cx + dy*px - dx*py 11259 c = by*px - bx*py 11260 11261 u = 0.0d0 11262 v = 0.0d0 11263 11264 IF ( ABS(a) < AEPS ) THEN 11265 r = -c / b 11266 IF ( r < -1.0d0 .OR. r > 1.0d0 ) RETURN 11267 11268 v = r 11269 u = (px - cx*r)/(bx + dx*r) 11270 inside = (u >= -1.0d0 .AND. u <= 1.0d0) 11271 RETURN 11272 END IF 11273 11274 d = b*b - 4*a*c 11275 IF ( d < 0.0d0 ) RETURN 11276 11277 d = SQRT(d) 11278 IF ( b>0 ) THEN 11279 r = -2*c/(b+d) 11280 ELSE 11281 r = (-b+d)/(2*a) 11282 END IF 11283 IF ( r >= -1.0d0 .AND. r <= 1.0d0 ) THEN 11284 v = r 11285 u = (px - cx*r)/(bx + dx*r) 11286 11287 IF ( u >= -1.0d0 .AND. u <= 1.0d0 ) THEN 11288 inside = .TRUE. 11289 RETURN 11290 END IF 11291 END IF 11292 11293 IF ( b>0 ) THEN 11294 r = -(b+d)/(2*a) 11295 ELSE 11296 r = 2*c/(-b+d) 11297 END IF 11298 IF ( r >= -1.0d0 .AND. r <= 1.0d0 ) THEN 11299 v = r 11300 u = (px - cx*r)/(bx + dx*r) 11301 inside = u >= -1.0d0 .AND. u <= 1.0d0 11302 RETURN 11303 END IF 11304!------------------------------------------------------------------------------ 11305 END FUNCTION QuadInside 11306!------------------------------------------------------------------------------ 11307 11308 11309 11310!------------------------------------------------------------------------------ 11311!> Figure out if given point x,y,z is inside a tetrahedron, whose 11312!> node coordinates are given in nx,ny,nz. Method: Invert the 11313!> basis functions.... 11314!------------------------------------------------------------------------------ 11315 FUNCTION TetraInside( nx,ny,nz,x,y,z ) RESULT(inside) 11316!------------------------------------------------------------------------------ 11317 REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays 11318 REAL(KIND=dp) :: x,y,z !< point which to consider 11319 LOGICAL :: inside !< result of the in/out test 11320!------------------------------------------------------------------------------ 11321! Local variables 11322!------------------------------------------------------------------------------ 11323 REAL(KIND=dp) :: A00,A01,A02,A10,A11,A12,A20,A21,A22,detA 11324 REAL(KIND=dp) :: B00,B01,B02,B10,B11,B12,B20,B21,B22 11325 REAL(KIND=dp) :: px,py,pz,u,v,w 11326!------------------------------------------------------------------------------ 11327 inside = .FALSE. 11328 11329 IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y .OR. MAXVAL(nz) < z ) RETURN 11330 IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y .OR. MINVAL(nz) > z ) RETURN 11331 11332 A00 = nx(2) - nx(1) 11333 A01 = nx(3) - nx(1) 11334 A02 = nx(4) - nx(1) 11335 11336 A10 = ny(2) - ny(1) 11337 A11 = ny(3) - ny(1) 11338 A12 = ny(4) - ny(1) 11339 11340 A20 = nz(2) - nz(1) 11341 A21 = nz(3) - nz(1) 11342 A22 = nz(4) - nz(1) 11343 11344 detA = A00*(A11*A22 - A12*A21) 11345 detA = detA + A01*(A12*A20 - A10*A22) 11346 detA = detA + A02*(A10*A21 - A11*A20) 11347 IF ( ABS(detA) < AEPS ) RETURN 11348 11349 detA = 1 / detA 11350 11351 px = x - nx(1) 11352 py = y - ny(1) 11353 pz = z - nz(1) 11354 11355 B00 = (A11*A22 - A12*A21)*detA 11356 B01 = (A21*A02 - A01*A22)*detA 11357 B02 = (A01*A12 - A11*A02)*detA 11358 11359 u = B00*px + B01*py + B02*pz 11360 IF ( u < 0.0d0 .OR. u > 1.0d0 ) RETURN 11361 11362 11363 B10 = (A12*A20 - A10*A22)*detA 11364 B11 = (A00*A22 - A20*A02)*detA 11365 B12 = (A10*A02 - A00*A12)*detA 11366 11367 v = B10*px + B11*py + B12*pz 11368 IF ( v < 0.0d0 .OR. v > 1.0d0 ) RETURN 11369 11370 11371 B20 = (A10*A21 - A11*A20)*detA 11372 B21 = (A01*A20 - A00*A21)*detA 11373 B22 = (A00*A11 - A10*A01)*detA 11374 11375 w = B20*px + B21*py + B22*pz 11376 IF ( w < 0.0d0 .OR. w > 1.0d0 ) RETURN 11377 11378 inside = (u + v + w) <= 1.0d0 11379!------------------------------------------------------------------------------ 11380 END FUNCTION TetraInside 11381!------------------------------------------------------------------------------ 11382 11383 11384 11385!------------------------------------------------------------------------------ 11386!> Figure out if given point x,y,z is inside a brick, whose node coordinates 11387!> are given in nx,ny,nz. Method: Divide to tetrahedrons. 11388!------------------------------------------------------------------------------ 11389 FUNCTION BrickInside( nx,ny,nz,x,y,z ) RESULT(inside) 11390!------------------------------------------------------------------------------ 11391 REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays 11392 REAL(KIND=dp) :: x,y,z !< point which to consider 11393 LOGICAL :: inside !< result of the in/out test 11394!------------------------------------------------------------------------------ 11395! Local variables 11396!------------------------------------------------------------------------------ 11397 INTEGER :: i,j 11398 REAL(KIND=dp) :: px(4),py(4),pz(4),r,s,t,maxx,minx,maxy,miny,maxz,minz 11399 INTEGER :: map(3,12) 11400!------------------------------------------------------------------------------ 11401 map = RESHAPE( [ 0,1,2, 0,2,3, 4,5,6, 4,6,7, 3,2,6, 3,6,7, & 11402 1,5,6, 1,6,2, 0,4,7, 0,7,3, 0,1,5, 0,5,4 ], [ 3,12 ] ) + 1 11403 11404 inside = .FALSE. 11405 11406 IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y .OR. MAXVAL(nz) < z ) RETURN 11407 IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y .OR. MINVAL(nz) > z ) RETURN 11408 11409 px(1) = 0.125d0 * SUM(nx) 11410 py(1) = 0.125d0 * SUM(ny) 11411 pz(1) = 0.125d0 * SUM(nz) 11412 11413 DO i=1,12 11414 px(2:4) = nx(map(1:3,i)) 11415 py(2:4) = ny(map(1:3,i)) 11416 pz(2:4) = nz(map(1:3,i)) 11417 11418 IF ( TetraInside( px,py,pz,x,y,z ) ) THEN 11419 inside = .TRUE. 11420 RETURN 11421 END IF 11422 END DO 11423!------------------------------------------------------------------------------ 11424 END FUNCTION BrickInside 11425!------------------------------------------------------------------------------ 11426 11427!------------------------------------------------------------------------------ 11428!> Check if the current element has been defined passive. 11429!> This is done by inspecting a looking an the values of "varname Passive" 11430!> in the Body Force section. It is determined to be passive if it has 11431!> more positive than negative hits in an element. 11432!------------------------------------------------------------------------------ 11433 FUNCTION CheckPassiveElement( UElement ) RESULT( IsPassive ) 11434 !------------------------------------------------------------------------------ 11435 TYPE(Element_t), OPTIONAL, TARGET :: UElement 11436 LOGICAL :: IsPassive 11437 !------------------------------------------------------------------------------ 11438 TYPE(Element_t), POINTER :: Element 11439 REAL(KIND=dp), ALLOCATABLE :: Passive(:) 11440 INTEGER :: body_id, bf_id, nlen, NbrNodes,PassNodes, LimitNodes 11441 LOGICAL :: Found 11442 CHARACTER(LEN=MAX_NAME_LEN) :: PassName 11443 LOGICAL :: NoPassiveElements = .FALSE. 11444 TYPE(Solver_t), POINTER :: pSolver, PrevSolver => NULL() 11445 11446 SAVE Passive, NoPassiveElements, PrevSolver, PassName 11447 !$OMP THREADPRIVATE(Passive, NoPassiveElements, PrevSolver, PassName) 11448 !------------------------------------------------------------------------------ 11449 IsPassive = .FALSE. 11450 pSolver => CurrentModel % Solver 11451 11452 IF( .NOT. ASSOCIATED( pSolver, PrevSolver ) ) THEN 11453 PrevSolver => pSolver 11454 nlen = CurrentModel % Solver % Variable % NameLen 11455 PassName = GetVarName(CurrentModel % Solver % Variable) // ' Passive' 11456 NoPassiveElements = .NOT. ListCheckPresentAnyBodyForce( CurrentModel, PassName ) 11457 END IF 11458 11459 IF( NoPassiveElements ) RETURN 11460 11461 IF (PRESENT(UElement)) THEN 11462 Element => UElement 11463 ELSE 11464#ifdef _OPENMP 11465 IF (omp_in_parallel()) THEN 11466 CALL Fatal('CheckPassiveElement', & 11467 'Need an element to update inside a threaded region') 11468 END IF 11469#endif 11470 Element => CurrentModel % CurrentElement 11471 END IF 11472 11473 body_id = Element % BodyId 11474 IF ( body_id <= 0 ) RETURN ! body_id == 0 for boundary elements 11475 11476 bf_id = ListGetInteger( CurrentModel % Bodies(body_id) % Values, & 11477 'Body Force', Found, minv=1,maxv=CurrentModel % NumberOfBodyForces ) 11478 IF ( .NOT. Found ) RETURN 11479 11480 IF ( ListCheckPresent(CurrentModel % BodyForces(bf_id) % Values, PassName) ) THEN 11481 NbrNodes = Element % TYPE % NumberOfNodes 11482 IF ( ALLOCATED(Passive) ) THEN 11483 IF ( SIZE(Passive) < NbrNodes ) THEN 11484 DEALLOCATE(Passive) 11485 ALLOCATE( Passive(NbrNodes) ) 11486 END IF 11487 ELSE 11488 ALLOCATE( Passive(NbrNodes) ) 11489 END IF 11490 Passive(1:NbrNodes) = ListGetReal( CurrentModel % BodyForces(bf_id) % Values, & 11491 PassName, NbrNodes, Element % NodeIndexes ) 11492 PassNodes = COUNT(Passive(1:NbrNodes)>0) 11493 11494 ! Go through the extremum cases first, and if the element is not either fully 11495 ! active or passive, then check for some possible given criteria for determining 11496 ! the element active / passive. 11497 !------------------------------------------------------------------------------ 11498 IF( PassNodes == 0 ) THEN 11499 CONTINUE 11500 ELSE IF( PassNodes == NbrNodes ) THEN 11501 IsPassive = .TRUE. 11502 ELSE 11503 LimitNodes = ListGetInteger( CurrentModel % BodyForces(bf_id) % Values, & 11504 'Passive Element Min Nodes',Found ) 11505 IF( Found ) THEN 11506 IsPassive = ( PassNodes >= LimitNodes ) 11507 ELSE 11508 LimitNodes = ListGetInteger( CurrentModel % BodyForces(bf_id) % Values, & 11509 'Active Element Min Nodes',Found ) 11510 IF( Found ) THEN 11511 IsPassive = ( PassNodes > NbrNodes - LimitNodes ) 11512 ELSE 11513 IsPassive = ( 2*PassNodes > NbrNodes ) 11514 END IF 11515 END IF 11516 END IF 11517 END IF 11518 11519!------------------------------------------------------------------------------ 11520 END FUNCTION CheckPassiveElement 11521!------------------------------------------------------------------------------ 11522 11523!------------------------------------------------------------------------------ 11524!> Normal will point from more dense material to less dense 11525!> or outwards, if no elements on the other side. 11526!------------------------------------------------------------------------------ 11527 SUBROUTINE CheckNormalDirection( Boundary,Normal,x,y,z,turn ) 11528!------------------------------------------------------------------------------ 11529 11530 TYPE(Element_t), POINTER :: Boundary 11531 TYPE(Nodes_t) :: Nodes 11532 REAL(KIND=dp) :: Normal(3),x,y,z 11533 LOGICAL, OPTIONAL :: turn 11534!------------------------------------------------------------------------------ 11535 11536 TYPE (Element_t), POINTER :: Element,LeftElement,RightElement 11537 11538 INTEGER :: LMat,RMat,n,k 11539 11540 REAL(KIND=dp) :: x1,y1,z1 11541 REAL(KIND=dp), ALLOCATABLE :: nx(:),ny(:),nz(:) 11542 LOGICAL :: LPassive 11543!------------------------------------------------------------------------------ 11544 11545 IF(.NOT. ASSOCIATED( Boundary % BoundaryInfo ) ) RETURN 11546 11547 k = Boundary % BoundaryInfo % OutBody 11548 11549 LeftElement => Boundary % BoundaryInfo % Left 11550 11551 Element => Null() 11552 IF ( ASSOCIATED(LeftELement) ) THEN 11553 RightElement => Boundary % BoundaryInfo % Right 11554 IF ( ASSOCIATED( RightElement ) ) THEN ! we have a body-body boundary 11555 IF ( k > 0 ) THEN ! declared outbody 11556 IF ( LeftElement % BodyId == k ) THEN 11557 Element => RightElement 11558 ELSE 11559 Element => LeftElement 11560 END IF 11561 ELSE IF (LeftElement % BodyId > RightElement % BodyId) THEN ! normal pointing into body with lower body ID 11562 Element => LeftElement 11563 ELSE IF (LeftElement % BodyId < RightElement % BodyId) THEN! normal pointing into body with lower body ID 11564 Element => RightElement 11565 ELSE ! active/passive boundary 11566 LPassive = CheckPassiveElement( LeftElement ) 11567 IF (LPassive .NEQV. CheckPassiveElement( RightElement )) THEN 11568 IF(LPassive) THEN 11569 Element => RightElement 11570 ELSE 11571 Element => LeftElement 11572 END IF 11573 END IF 11574 END IF 11575 ELSE ! body-vacuum boundary from left->right 11576 Element => LeftElement 11577 END IF 11578 ELSE! body-vacuum boundary from right->left 11579 Element => Boundary % BoundaryInfo % Right 11580 END IF 11581 11582 IF ( .NOT. ASSOCIATED(Element) ) RETURN 11583 11584 n = Element % TYPE % NumberOfNodes 11585 11586 ALLOCATE( nx(n), ny(n), nz(n) ) 11587 11588 nx(1:n) = CurrentModel % Nodes % x(Element % NodeIndexes) 11589 ny(1:n) = CurrentModel % Nodes % y(Element % NodeIndexes) 11590 nz(1:n) = CurrentModel % Nodes % z(Element % NodeIndexes) 11591 11592 SELECT CASE( Element % TYPE % ElementCode / 100 ) 11593 11594 CASE(2,4,8) 11595 x1 = InterpolateInElement( Element, nx, 0.0d0, 0.0d0, 0.0d0 ) 11596 y1 = InterpolateInElement( Element, ny, 0.0d0, 0.0d0, 0.0d0 ) 11597 z1 = InterpolateInElement( Element, nz, 0.0d0, 0.0d0, 0.0d0 ) 11598 CASE(3) 11599 x1 = InterpolateInElement( Element, nx, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11600 y1 = InterpolateInElement( Element, ny, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11601 z1 = InterpolateInElement( Element, nz, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11602 CASE(5) 11603 x1 = InterpolateInElement( Element, nx, 1.0d0/4, 1.0d0/4, 1.0d0/4 ) 11604 y1 = InterpolateInElement( Element, ny, 1.0d0/4, 1.0d0/4, 1.0d0/4 ) 11605 z1 = InterpolateInElement( Element, nz, 1.0d0/4, 1.0d0/4, 1.0d0/4 ) 11606 CASE(6) 11607 x1 = InterpolateInElement( Element, nx, 0.0d0, 0.0d0, 1.0d0/3 ) 11608 y1 = InterpolateInElement( Element, ny, 0.0d0, 0.0d0, 1.0d0/3 ) 11609 z1 = InterpolateInElement( Element, nz, 0.0d0, 0.0d0, 1.0d0/3 ) 11610 CASE(7) 11611 x1 = InterpolateInElement( Element, nx, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11612 y1 = InterpolateInElement( Element, ny, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11613 z1 = InterpolateInElement( Element, nz, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11614 CASE DEFAULT 11615 CALL Fatal('CheckNormalDirection','Invalid elementcode for parent element!') 11616 11617 END SELECT 11618 x1 = x1 - x 11619 y1 = y1 - y 11620 z1 = z1 - z 11621 11622 IF ( PRESENT(turn) ) turn = .FALSE. 11623 IF ( x1*Normal(1) + y1*Normal(2) + z1*Normal(3) > 0 ) THEN 11624 IF ( Element % BodyId /= k ) THEN 11625 Normal = -Normal 11626 IF ( PRESENT(turn) ) turn = .TRUE. 11627 END IF 11628 ELSE IF ( Element % BodyId == k ) THEN 11629 Normal = -Normal 11630 IF ( PRESENT(turn) ) turn = .TRUE. 11631 END IF 11632 DEALLOCATE( nx,ny,nz ) 11633!------------------------------------------------------------------------------ 11634 END SUBROUTINE CheckNormalDirection 11635!------------------------------------------------------------------------------ 11636 11637 11638!------------------------------------------------------------------------------ 11639!> Normal will point out from the parent. 11640!------------------------------------------------------------------------------ 11641 SUBROUTINE CheckNormalDirectionParent( Boundary,Normal,x,y,z,Element,turn ) 11642!------------------------------------------------------------------------------ 11643 11644 TYPE(Element_t), POINTER :: Boundary 11645 TYPE(Nodes_t) :: Nodes 11646 REAL(KIND=dp) :: Normal(3),x,y,z 11647 TYPE(Element_t), POINTER :: Element 11648 LOGICAL, OPTIONAL :: turn 11649!------------------------------------------------------------------------------ 11650 INTEGER :: n,k 11651 REAL(KIND=dp) :: x1,y1,z1 11652 REAL(KIND=dp), ALLOCATABLE :: nx(:),ny(:),nz(:) 11653 LOGICAL :: LPassive 11654!------------------------------------------------------------------------------ 11655 11656 IF( PRESENT( turn ) ) turn = .FALSE. 11657 11658 IF ( .NOT. ASSOCIATED(Element) ) RETURN 11659 11660 n = Element % TYPE % NumberOfNodes 11661 11662 ALLOCATE( nx(n), ny(n), nz(n) ) 11663 11664 nx(1:n) = CurrentModel % Nodes % x(Element % NodeIndexes) 11665 ny(1:n) = CurrentModel % Nodes % y(Element % NodeIndexes) 11666 nz(1:n) = CurrentModel % Nodes % z(Element % NodeIndexes) 11667 11668 SELECT CASE( Element % TYPE % ElementCode / 100 ) 11669 11670 CASE(2,4,8) 11671 x1 = InterpolateInElement( Element, nx, 0.0d0, 0.0d0, 0.0d0 ) 11672 y1 = InterpolateInElement( Element, ny, 0.0d0, 0.0d0, 0.0d0 ) 11673 z1 = InterpolateInElement( Element, nz, 0.0d0, 0.0d0, 0.0d0 ) 11674 CASE(3) 11675 x1 = InterpolateInElement( Element, nx, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11676 y1 = InterpolateInElement( Element, ny, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11677 z1 = InterpolateInElement( Element, nz, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11678 CASE(5) 11679 x1 = InterpolateInElement( Element, nx, 1.0d0/4, 1.0d0/4, 1.0d0/4 ) 11680 y1 = InterpolateInElement( Element, ny, 1.0d0/4, 1.0d0/4, 1.0d0/4 ) 11681 z1 = InterpolateInElement( Element, nz, 1.0d0/4, 1.0d0/4, 1.0d0/4 ) 11682 CASE(6) 11683 x1 = InterpolateInElement( Element, nx, 0.0d0, 0.0d0, 1.0d0/3 ) 11684 y1 = InterpolateInElement( Element, ny, 0.0d0, 0.0d0, 1.0d0/3 ) 11685 z1 = InterpolateInElement( Element, nz, 0.0d0, 0.0d0, 1.0d0/3 ) 11686 CASE(7) 11687 x1 = InterpolateInElement( Element, nx, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11688 y1 = InterpolateInElement( Element, ny, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11689 z1 = InterpolateInElement( Element, nz, 1.0d0/3, 1.0d0/3, 0.0d0 ) 11690 CASE DEFAULT 11691 CALL Fatal('CheckNormalDirection','Invalid elementcode for parent element!') 11692 11693 END SELECT 11694 11695 ! Test vector points from surface to center of parent 11696 x1 = x1 - x 11697 y1 = y1 - y 11698 z1 = z1 - z 11699 11700 ! Swap the sign if the tentative normal points to the center, it should point outward 11701 IF ( x1*Normal(1) + y1*Normal(2) + z1*Normal(3) > 0 ) THEN 11702 Normal = -Normal 11703 IF ( PRESENT(turn) ) turn = .TRUE. 11704 END IF 11705 11706 DEALLOCATE( nx,ny,nz ) 11707!------------------------------------------------------------------------------ 11708 END SUBROUTINE CheckNormalDirectionParent 11709!------------------------------------------------------------------------------ 11710 11711 11712!------------------------------------------------------------------------------ 11713!> Gives the normal vector of a boundary element. 11714!> For noncurved elements the normal vector does not depend on the local coordinate 11715!> while otherwise it does. There are different uses of the function where some 11716!> do not have the luxury of knowing the local coordinates and hence the center 11717!> point is used as default. 11718!------------------------------------------------------------------------------ 11719 FUNCTION NormalVector( Boundary,BoundaryNodes,u0,v0,Check,Parent,Turn) RESULT(Normal) 11720!------------------------------------------------------------------------------ 11721 TYPE(Element_t), POINTER :: Boundary 11722 TYPE(Nodes_t) :: BoundaryNodes 11723 REAL(KIND=dp), OPTIONAL :: u0,v0 11724 LOGICAL, OPTIONAL :: Check 11725 TYPE(Element_t), POINTER, OPTIONAL :: Parent 11726 LOGICAL, OPTIONAL :: Turn 11727 REAL(KIND=dp) :: Normal(3) 11728!------------------------------------------------------------------------------ 11729 LOGICAL :: CheckBody, CheckParent 11730 TYPE(ElementType_t),POINTER :: elt 11731 REAL(KIND=dp) :: u,v,Auu,Auv,Avu,Avv,detA,x,y,z 11732 REAL(KIND=dp) :: dxdu,dxdv,dydu,dydv,dzdu,dzdv 11733 REAL(KIND=dp), DIMENSION(:), POINTER :: nx,ny,nz 11734 11735!------------------------------------------------------------------------------ 11736 11737 nx => BoundaryNodes % x 11738 ny => BoundaryNodes % y 11739 nz => BoundaryNodes % z 11740 11741 SELECT CASE ( Boundary % TYPE % DIMENSION ) 11742 11743 CASE ( 0 ) 11744 Normal(1) = 1.0_dp 11745 Normal(2:3) = 0.0_dp 11746 11747 CASE ( 1 ) 11748 IF( PRESENT( u0 ) ) THEN 11749 u = u0 11750 ELSE 11751 u = 0.0_dp 11752 END IF 11753 11754 dxdu = FirstDerivative1D( Boundary,nx,u ) 11755 dydu = FirstDerivative1D( Boundary,ny,u ) 11756 11757 detA = dxdu*dxdu + dydu*dydu 11758 IF ( detA <= 0._dp ) THEN 11759 Normal = 0._dp 11760 RETURN 11761 END IF 11762 detA = 1.0_dp / SQRT(detA) 11763 Normal(1) = -dydu * detA 11764 Normal(2) = dxdu * detA 11765 Normal(3) = 0.0d0 11766 11767 CASE ( 2 ) 11768 IF( PRESENT( u0 ) ) THEN 11769 u = u0 11770 v = v0 11771 ELSE 11772 IF( Boundary % TYPE % ElementCode / 100 == 3 ) THEN 11773 u = 1.0_dp/3 11774 v = 1.0_dp/3 11775 ELSE 11776 u = 0.0_dp 11777 v = 0.0_dp 11778 END IF 11779 END IF 11780 11781 dxdu = FirstDerivativeInU2D( Boundary,nx,u,v ) 11782 dydu = FirstDerivativeInU2D( Boundary,ny,u,v ) 11783 dzdu = FirstDerivativeInU2D( Boundary,nz,u,v ) 11784 11785 dxdv = FirstDerivativeInV2D( Boundary,nx,u,v ) 11786 dydv = FirstDerivativeInV2D( Boundary,ny,u,v ) 11787 dzdv = FirstDerivativeInV2D( Boundary,nz,u,v ) 11788 11789 Auu = dxdu*dxdu + dydu*dydu + dzdu*dzdu 11790 Auv = dxdu*dxdv + dydu*dydv + dzdu*dzdv 11791 Avv = dxdv*dxdv + dydv*dydv + dzdv*dzdv 11792 11793 detA = 1.0d0 / SQRT(Auu*Avv - Auv*Auv) 11794 11795 Normal(1) = (dydu * dzdv - dydv * dzdu) * detA 11796 Normal(2) = (dxdv * dzdu - dxdu * dzdv) * detA 11797 Normal(3) = (dxdu * dydv - dxdv * dydu) * detA 11798 11799 CASE DEFAULT 11800 CALL Fatal('NormalVector','Invalid dimension for determining normal!') 11801 11802 END SELECT 11803 11804 11805 CheckParent = .FALSE. 11806 IF( PRESENT( Parent ) ) CheckParent = ASSOCIATED( Parent ) 11807 11808 CheckBody = .FALSE. 11809 IF ( PRESENT(Check) ) CheckBody = Check 11810 11811 IF ( .NOT. ( CheckBody .OR. CheckParent ) ) RETURN 11812 11813 SELECT CASE( Boundary % TYPE % ElementCode / 100 ) 11814 11815 CASE(1) 11816 x = nx(1) 11817 y = nx(1) 11818 z = nz(1) 11819 11820 CASE(2,4) 11821 x = InterpolateInElement( Boundary,nx,0.0d0,0.0d0,0.0d0 ) 11822 y = InterpolateInElement( Boundary,ny,0.0d0,0.0d0,0.0d0 ) 11823 z = InterpolateInElement( Boundary,nz,0.0d0,0.0d0,0.0d0 ) 11824 11825 CASE(3) 11826 x = InterpolateInElement( Boundary,nx,1.0d0/3,1.0d0/3,0.0d0) 11827 y = InterpolateInElement( Boundary,ny,1.0d0/3,1.0d0/3,0.0d0) 11828 z = InterpolateInElement( Boundary,nz,1.0d0/3,1.0d0/3,0.0d0) 11829 END SELECT 11830 11831 IF( CheckParent ) THEN 11832 CALL CheckNormalDirectionParent( Boundary, Normal, x, y, z, Parent,Turn ) 11833 ELSE 11834 CALL CheckNormalDirection( Boundary,Normal,x,y,z,Turn ) 11835 END IF 11836 11837!------------------------------------------------------------------------------ 11838 END FUNCTION NormalVector 11839!------------------------------------------------------------------------------ 11840 11841!------------------------------------------------------------------------------ 11842!> Returns a point that is most importantly supposed to be on the surface 11843!> For noncurved elements this may simply be the mean while otherwise 11844!> there may be a need to find the surface node using the local coordinates. 11845!> Hence the optional parameters. Typically the NormalVector and SurfaceVector 11846!> should be defined at the same position. 11847!------------------------------------------------------------------------------ 11848 FUNCTION SurfaceVector( Boundary,BoundaryNodes,u,v ) RESULT(Surface) 11849!------------------------------------------------------------------------------ 11850 TYPE(Element_t), POINTER :: Boundary 11851 TYPE(Nodes_t) :: BoundaryNodes 11852 REAL(KIND=dp),OPTIONAL :: u,v 11853 REAL(KIND=dp) :: Surface(3) 11854!------------------------------------------------------------------------------ 11855 REAL(KIND=dp), DIMENSION(:), POINTER :: nx,ny,nz 11856 INTEGER :: i,n 11857!------------------------------------------------------------------------------ 11858 11859 nx => BoundaryNodes % x 11860 ny => BoundaryNodes % y 11861 nz => BoundaryNodes % z 11862 n = Boundary % TYPE % NumberOfNodes 11863 11864 IF( .NOT. PRESENT( u ) ) THEN 11865 Surface(1) = SUM( nx ) / n 11866 Surface(2) = SUM( ny ) / n 11867 Surface(3) = SUM( nz ) / n 11868 ELSE 11869 IF( Boundary % TYPE % DIMENSION == 1 ) THEN 11870 Surface(1) = InterpolateInElement( Boundary,nx,u,0.0_dp,0.0_dp) 11871 Surface(2) = InterpolateInElement( Boundary,ny,u,0.0_dp,0.0_dp) 11872 Surface(3) = InterpolateInElement( Boundary,nz,u,0.0_dp,0.0_dp) 11873 ELSE 11874 Surface(1) = InterpolateInElement( Boundary,nx,u,v,0.0_dp) 11875 Surface(2) = InterpolateInElement( Boundary,ny,u,v,0.0_dp) 11876 Surface(3) = InterpolateInElement( Boundary,nz,u,v,0.0_dp) 11877 END IF 11878 END IF 11879 11880!------------------------------------------------------------------------------ 11881 END FUNCTION SurfaceVector 11882!------------------------------------------------------------------------------ 11883 11884 11885!--------------------------------------------------------------------------- 11886!> This subroutine tests where the intersection between the line defined by two 11887!> points and a plane (or line) defined by a boundary element meet. There is 11888!> an intersection if ( 0 < Lambda < 1 ). Of all intersections the first one is 11889!> that with the smallest positive lambda. 11890!--------------------------------------------------------------------------- 11891 FUNCTION LineFaceIntersection(FaceElement,FaceNodes,& 11892 Rinit,Rfin,u,v) RESULT ( Lambda ) 11893!--------------------------------------------------------------------------- 11894 TYPE(Nodes_t) :: FaceNodes 11895 TYPE(Element_t), POINTER :: FaceElement 11896 REAL(KIND=dp) :: Rinit(3),Rfin(3) 11897 REAL(KIND=dp),OPTIONAL :: u,v 11898 REAL(KIND=dp) :: Lambda 11899 11900 REAL (KIND=dp) :: Surface(3),t1(3),t2(3),Normal(3),Rproj 11901 REAL (KIND=dp) :: Lambda0 11902 INTEGER :: third 11903 11904 third = 3 11905 11906100 CONTINUE 11907 11908 ! For higher order elements this may be a necessity 11909 IF( PRESENT( u ) .AND. PRESENT(v) ) THEN 11910 Surface = SurfaceVector( FaceElement, FaceNodes, u, v ) 11911 Normal = NormalVector( FaceElement, FaceNodes, u, v ) 11912 11913 ELSE IF( FaceElement % TYPE % DIMENSION == 2 ) THEN 11914 ! Any point known to be at the surface, even corner node 11915 Surface(1) = FaceNodes % x(1) 11916 Surface(2) = FaceNodes % y(1) 11917 Surface(3) = FaceNodes % z(1) 11918 11919 ! Tangent vector, nor normalized to unity! 11920 t1(1) = FaceNodes % x(2) - Surface(1) 11921 t1(2) = FaceNodes % y(2) - Surface(2) 11922 t1(3) = FaceNodes % z(2) - Surface(3) 11923 11924 t2(1) = FaceNodes % x(third) - Surface(1) 11925 t2(2) = FaceNodes % y(third) - Surface(2) 11926 t2(3) = FaceNodes % z(third) - Surface(3) 11927 11928 ! Normal vector obtained from the cross product of tangent vectoes 11929 ! This is not normalized to unity as value of lambda does not depend on its magnitude 11930 Normal(1) = t1(2)*t2(3) - t1(3)*t2(2) 11931 Normal(2) = t1(3)*t2(1) - t1(1)*t2(3) 11932 Normal(3) = t1(1)*t2(2) - t1(2)*t2(1) 11933 ELSE 11934 Surface(1) = FaceNodes % x(1) 11935 Surface(2) = FaceNodes % y(1) 11936 Surface(3) = 0.0_dp 11937 11938 Normal(1) = Surface(2) - FaceNodes % y(2) 11939 Normal(2) = FaceNodes % x(2) - Surface(1) 11940 Normal(3) = 0.0_dp 11941 END IF 11942 11943 ! Project of the line to the face normal 11944 Rproj = SUM( (Rfin - Rinit) * Normal ) 11945 11946 IF( ABS( Rproj ) < TINY( Rproj ) ) THEN 11947 ! if the intersection cannot be defined make it an impossible one 11948 Lambda = -HUGE( Lambda ) 11949 ELSE 11950 Lambda = SUM( ( Surface - Rinit ) * Normal ) / Rproj 11951 END IF 11952 11953 IF( FaceElement % NDofs == 4 ) THEN 11954 IF( third == 3 ) THEN 11955 third = 4 11956 Lambda0 = Lambda 11957 GOTO 100 11958 END IF 11959 IF( ABS( Lambda0 ) < ABS( Lambda) ) THEN 11960 Lambda = Lambda0 11961 END IF 11962 END IF 11963 11964 11965 END FUNCTION LineFaceIntersection 11966 11967 11968!--------------------------------------------------------------------------- 11969!> This subroutine performs a similar test as above using slightly different 11970!> strategy. 11971!--------------------------------------------------------------------------- 11972 FUNCTION LineFaceIntersection2(FaceElement,FaceNodes,Rinit,Rfin,Intersect) RESULT ( Lambda ) 11973 11974 TYPE(Nodes_t) :: FaceNodes 11975 TYPE(Element_t), POINTER :: FaceElement 11976 REAL(KIND=dp) :: Rinit(3), Rfin(3),Lambda 11977 LOGICAL :: Intersect 11978!---------------------------------------------------------------------------- 11979 REAL (KIND=dp) :: A(3,3),B(3),C(3),Eps,Eps2,Eps3,detA,absA,ds 11980 INTEGER :: split, i, n, notriangles, triangle, ElemDim 11981 11982 Eps = EPSILON( Eps ) 11983 Eps2 = SQRT(TINY(Eps2)) 11984 Eps3 = 1.0d-12 11985 Lambda = -HUGE( Lambda ) 11986 Intersect = .FALSE. 11987 ElemDim = FaceElement % TYPE % DIMENSION 11988 11989 ! Then solve the exact points of intersection from a 3x3 or 2x2 linear system 11990 !-------------------------------------------------------------------------- 11991 IF( ElemDim == 2 ) THEN 11992 n = FaceElement % NDofs 11993 ! In 3D rectangular faces are treated as two triangles 11994 IF( n == 4 .OR. n == 8 .OR. n == 9 ) THEN 11995 notriangles = 2 11996 ELSE 11997 notriangles = 1 11998 END IF 11999 12000 DO triangle=1,notriangles 12001 12002 A(1:3,1) = Rfin(1:3) - Rinit(1:3) 12003 12004 IF(triangle == 1) THEN 12005 A(1,2) = FaceNodes % x(1) - FaceNodes % x(2) 12006 A(2,2) = FaceNodes % y(1) - FaceNodes % y(2) 12007 A(3,2) = FaceNodes % z(1) - FaceNodes % z(2) 12008 ELSE 12009 A(1,2) = FaceNodes % x(1) - FaceNodes % x(4) 12010 A(2,2) = FaceNodes % y(1) - FaceNodes % y(4) 12011 A(3,2) = FaceNodes % z(1) - FaceNodes % z(4) 12012 END IF 12013 12014 A(1,3) = FaceNodes % x(1) - FaceNodes % x(3) 12015 A(2,3) = FaceNodes % y(1) - FaceNodes % y(3) 12016 A(3,3) = FaceNodes % z(1) - FaceNodes % z(3) 12017 12018 ! Check for linearly dependent vectors 12019 detA = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) & 12020 - A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)) & 12021 + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) 12022 absA = SUM(ABS(A(1,1:3))) * SUM(ABS(A(2,1:3))) * SUM(ABS(A(3,1:3))) 12023 12024 IF(ABS(detA) <= eps * absA + Eps2) CYCLE 12025! print *,'detA',detA 12026 12027 B(1) = FaceNodes % x(1) - Rinit(1) 12028 B(2) = FaceNodes % y(1) - Rinit(2) 12029 B(3) = FaceNodes % z(1) - Rinit(3) 12030 12031 CALL InvertMatrix( A,3 ) 12032 C(1:3) = MATMUL( A(1:3,1:3),B(1:3) ) 12033 12034 IF( ANY(C(2:3) < -Eps3) .OR. ANY(C(2:3) > 1.0_dp + Eps3 ) ) CYCLE 12035 IF( C(2)+C(3) > 1.0_dp + Eps3 ) CYCLE 12036 12037 ! Relate the point of intersection to local coordinates 12038 !IF(corners < 4) THEN 12039 ! u = C(2) 12040 ! v = C(3) 12041 !ELSE IF(corners == 4 .AND. split == 0) THEN 12042 ! u = 2*(C(2)+C(3))-1 12043 ! v = 2*C(3)-1 12044 !ELSE 12045 ! ! For the 2nd split of the rectangle the local coordinates switched 12046 ! v = 2*(C(2)+C(3))-1 12047 ! u = 2*C(3)-1 12048 !END IF 12049 12050 Intersect = .TRUE. 12051 Lambda = C(1) 12052 EXIT 12053 12054 END DO 12055 ELSE 12056 ! In 2D the intersection is between two lines 12057 12058 A(1:2,1) = Rfin(1:2) - Rinit(1:2) 12059 A(1,2) = FaceNodes % x(1) - FaceNodes % x(2) 12060 A(2,2) = FaceNodes % y(1) - FaceNodes % y(2) 12061 12062 detA = A(1,1)*A(2,2)-A(1,2)*A(2,1) 12063 absA = SUM(ABS(A(1,1:2))) * SUM(ABS(A(2,1:2))) 12064 12065 ! Lines are almost parallel => no intersection possible 12066 IF(ABS(detA) <= eps * absA + Eps2) RETURN 12067 12068 B(1) = FaceNodes % x(1) - Rinit(1) 12069 B(2) = FaceNodes % y(1) - Rinit(2) 12070 12071 CALL InvertMatrix( A,2 ) 12072 C(1:2) = MATMUL(A(1:2,1:2),B(1:2)) 12073 12074 IF(C(2) < -Eps3 .OR. C(2) > 1.0_dp + Eps3 ) RETURN 12075 12076 Intersect = .TRUE. 12077 Lambda = C(1) 12078 12079! u = -1.0d0 + 2.0d0 * C(2) 12080 12081 END IF 12082 12083! IF(.NOT. Inside) RETURN 12084 12085! stat = ElementInfo( Element, FaceNodes, U, V, W, SqrtElementMetric, & 12086! Basis, dBasisdx ) 12087 12088! Weights(1:n) = Basis(1:n) 12089! MaxInd = 1 12090! DO i=2,n 12091! IF(Weights(MaxInd) < Weights(i)) MaxInd = i 12092! END DO 12093 12094 END FUNCTION LineFaceIntersection2 12095 12096 12097 12098!--------------------------------------------------------------------------- 12099!> This subroutine computes the signed distance of a point from a surface. 12100!--------------------------------------------------------------------------- 12101 FUNCTION PointFaceDistance(BoundaryElement,BoundaryNodes,& 12102 Coord,Normal,u0,v0) RESULT ( Dist ) 12103!--------------------------------------------------------------------------- 12104 TYPE(Nodes_t) :: BoundaryNodes 12105 TYPE(Element_t), POINTER :: BoundaryElement 12106 REAL(KIND=dp) :: Coord(3),Normal(3) 12107 REAL(KIND=dp),OPTIONAL :: u0,v0 12108 REAL(KIND=dp) :: Dist 12109 12110 REAL (KIND=dp) :: Surface(3),t1(3),t2(3),u,v 12111 12112 ! For higher order elements this may be a necessity 12113 IF( PRESENT( u0 ) .AND. PRESENT(v0) ) THEN 12114 u = u0 12115 v = v0 12116 Surface = SurfaceVector( BoundaryElement, BoundaryNodes, u, v ) 12117 ELSE 12118 u = 0.0_dp 12119 v = 0.0_dp 12120 12121 ! Any point known to be at the surface, even corner node 12122 Surface(1) = BoundaryNodes % x(1) 12123 Surface(2) = BoundaryNodes % y(1) 12124 Surface(3) = BoundaryNodes % z(1) 12125 END IF 12126 12127 Normal = NormalVector( BoundaryElement, BoundaryNodes, u, v, .TRUE. ) 12128 12129 ! Project of the line to the face normal 12130 Dist = SUM( (Surface - Coord ) * Normal ) 12131END FUNCTION PointFaceDistance 12132 12133 12134 12135!------------------------------------------------------------------------------ 12136!> Convert global coordinates x,y,z inside element to local coordinates 12137!> u,v,w of the element. 12138!> @todo Change to support p elements 12139!------------------------------------------------------------------------------ 12140 SUBROUTINE GlobalToLocal( u,v,w,x,y,z,Element,ElementNodes ) 12141!------------------------------------------------------------------------------ 12142 TYPE(Nodes_t) :: ElementNodes 12143 REAL(KIND=dp) :: x,y,z,u,v,w 12144 TYPE(Element_t), POINTER :: Element 12145!------------------------------------------------------------------------------ 12146 INTEGER, PARAMETER :: MaxIter = 50 12147 INTEGER :: i,n 12148 REAL(KIND=dp) :: r,s,t,delta(3),prevdelta(3),J(3,3),J1(3,2),det,swap,acc,err 12149 LOGICAL :: Converged 12150!------------------------------------------------------------------------------ 12151 12152 u = 0._dp 12153 v = 0._dp 12154 w = 0._dp 12155 IF (Element % TYPE % DIMENSION==0) RETURN 12156 12157 n = Element % TYPE % NumberOfNodes 12158 12159 ! @todo Not supported yet 12160! IF (ASSOCIATED(Element % PDefs)) THEN 12161! CALL Fatal('GlobalToLocal','P elements not supported yet!') 12162! END IF 12163 acc = EPSILON(1.0_dp) 12164 Converged = .FALSE. 12165 12166 delta = 0._dp 12167 12168!------------------------------------------------------------------------------ 12169 DO i=1,Maxiter 12170!------------------------------------------------------------------------------ 12171 r = InterpolateInElement(Element,ElementNodes % x(1:n),u,v,w) - x 12172 s = InterpolateInElement(Element,ElementNodes % y(1:n),u,v,w) - y 12173 t = InterpolateInElement(Element,ElementNodes % z(1:n),u,v,w) - z 12174 12175 err = r**2 + s**2 + t**2 12176 12177 IF ( err < acc ) THEN 12178 Converged = .TRUE. 12179 EXIT 12180 END IF 12181 12182 prevdelta = delta 12183 delta = 0.d0 12184 12185 SELECT CASE( Element % TYPE % DIMENSION ) 12186 CASE(1) 12187 12188 J(1,1) = FirstDerivative1D( Element, ElementNodes % x, u ) 12189 J(2,1) = FirstDerivative1D( Element, ElementNodes % y, u ) 12190 J(3,1) = FirstDerivative1D( Element, ElementNodes % z, u ) 12191 12192 det = SUM( J(1:3,1)**2 ) 12193 delta(1) = (r*J(1,1)+s*J(2,1)+t*J(3,1))/det 12194 12195 CASE(2) 12196 12197 J(1,1) = FirstDerivativeInU2D( Element, ElementNodes % x,u,v ) 12198 J(1,2) = FirstDerivativeInV2D( Element, ElementNodes % x,u,v ) 12199 J(2,1) = FirstDerivativeInU2D( Element, ElementNodes % y,u,v ) 12200 J(2,2) = FirstDerivativeInV2D( Element, ElementNodes % y,u,v ) 12201 12202 SELECT CASE( CoordinateSystemDimension() ) 12203 CASE(3) 12204 J(3,1) = FirstDerivativeInU2D( Element, ElementNodes % z, u, v ) 12205 J(3,2) = FirstDerivativeInV2D( Element, ElementNodes % z, u, v ) 12206 12207 delta(1) = r 12208 delta(2) = s 12209 delta(3) = t 12210 delta(1:2) = MATMUL( TRANSPOSE(J(1:3,1:2)), delta ) 12211 r = delta(1) 12212 s = delta(2) 12213 12214 J(1:2,1:2) = MATMUL( TRANSPOSE(J(1:3,1:2)), J(1:3,1:2) ) 12215 delta(3) = 0.0d0 12216 END SELECT 12217 12218 CALL SolveLinSys2x2( J(1:2,1:2), delta(1:2), [ r, s] ) 12219 12220 CASE(3) 12221 J(1,1) = FirstDerivativeInU3D( Element, ElementNodes % x, u, v, w ) 12222 J(1,2) = FirstDerivativeInV3D( Element, ElementNodes % x, u, v, w ) 12223 J(1,3) = FirstDerivativeInW3D( Element, ElementNodes % x, u, v, w ) 12224 12225 J(2,1) = FirstDerivativeInU3D( Element, ElementNodes % y, u, v, w ) 12226 J(2,2) = FirstDerivativeInV3D( Element, ElementNodes % y, u, v, w ) 12227 J(2,3) = FirstDerivativeInW3D( Element, ElementNodes % y, u, v, w ) 12228 12229 J(3,1) = FirstDerivativeInU3D( Element, ElementNodes % z, u, v, w ) 12230 J(3,2) = FirstDerivativeInV3D( Element, ElementNodes % z, u, v, w ) 12231 J(3,3) = FirstDerivativeInW3D( Element, ElementNodes % z, u, v, w ) 12232 12233 CALL SolveLinSys3x3( J, delta, [ r, s, t ] ) 12234 12235 END SELECT 12236 12237 IF( i > 10 ) THEN 12238 ! If the same values is suggested over and over again, then exit 12239 ! This may be a sign that the node is off-plane and cannot be 12240 ! described within the element. 12241 IF( SUM( ABS( delta - prevdelta ) ) < acc ) EXIT 12242 12243 ! Use sloppier criteria when iteration still unsuccessful 12244 IF( i > 20 ) THEN 12245 IF( SUM( ABS( delta - prevdelta ) ) < SQRT( acc ) ) EXIT 12246 END IF 12247 12248 ! If the iteration does not proceed try with some relaxation 12249 delta = 0.5_dp * delta 12250 END IF 12251 12252 u = u - delta(1) 12253 v = v - delta(2) 12254 w = w - delta(3) 12255 12256 12257!------------------------------------------------------------------------------ 12258 END DO 12259!------------------------------------------------------------------------------ 12260 12261 IF ( .NOT. Converged ) THEN 12262 IF( err > SQRT( acc ) ) THEN 12263 IF( i > MaxIter ) THEN 12264 CALL Warn( 'GlobalToLocal', 'did not converge.') 12265 PRINT *,'rst',i,r,s,t 12266 PRINT *,'err',err,acc,SQRT(acc) 12267 PRINT *,'delta',delta,prevdelta 12268 PRINT *,'uvw',u,v,w 12269 PRINT *,'code',Element % TYPE % ElementCode 12270 PRINT *,'x:',x,ElementNodes % x(1:n) 12271 PRINT *,'y:',y,ElementNodes % y(1:n) 12272 PRINT *,'z:',z,ElementNodes % z(1:n) 12273 ELSE 12274! CALL Warn( 'GlobalToLocal', 'Node may be out of element') 12275! PRINT *,'rst',i,r,s,t,acc 12276 END IF 12277 END IF 12278 END IF 12279!------------------------------------------------------------------------------ 12280 END SUBROUTINE GlobalToLocal 12281!------------------------------------------------------------------------------ 12282 12283 12284!------------------------------------------------------------------------------ 12285 SUBROUTINE InvertMatrix3x3( G,GI,detG ) 12286!------------------------------------------------------------------------------ 12287 REAL(KIND=dp) :: G(3,3),GI(3,3) 12288 REAL(KIND=dp) :: detG, s 12289!------------------------------------------------------------------------------ 12290 s = 1.0 / DetG 12291 12292 GI(1,1) = s * (G(2,2)*G(3,3) - G(3,2)*G(2,3)); 12293 GI(2,1) = -s * (G(2,1)*G(3,3) - G(3,1)*G(2,3)); 12294 GI(3,1) = s * (G(2,1)*G(3,2) - G(3,1)*G(2,2)); 12295 12296 GI(1,2) = -s * (G(1,2)*G(3,3) - G(3,2)*G(1,3)); 12297 GI(2,2) = s * (G(1,1)*G(3,3) - G(3,1)*G(1,3)); 12298 GI(3,2) = -s * (G(1,1)*G(3,2) - G(3,1)*G(1,2)); 12299 12300 GI(1,3) = s * (G(1,2)*G(2,3) - G(2,2)*G(1,3)); 12301 GI(2,3) = -s * (G(1,1)*G(2,3) - G(2,1)*G(1,3)); 12302 GI(3,3) = s * (G(1,1)*G(2,2) - G(2,1)*G(1,2)); 12303!------------------------------------------------------------------------------ 12304 END SUBROUTINE InvertMatrix3x3 12305!------------------------------------------------------------------------------ 12306 12307 12308!------------------------------------------------------------------------------ 12309!> Given element and its face map (for some triangular face of element ), 12310!> this routine returns global direction of triangle face so that 12311!> functions are continuous over element boundaries 12312!------------------------------------------------------------------------------ 12313 FUNCTION getTriangleFaceDirection( Element, FaceMap ) RESULT(globalDir) 12314!------------------------------------------------------------------------------ 12315 IMPLICIT NONE 12316 12317 TYPE(Element_t) :: Element !< Element to get direction to 12318 INTEGER :: FaceMap(3) !< Element triangular face map 12319 INTEGER :: globalDir(3) !< Global direction of triangular face as local node numbers. 12320!------------------------------------------------------------------------------ 12321 INTEGER :: i, nodes(3) 12322 nodes = 0 12323 12324 ! Put global nodes of face into sorted order 12325 nodes(1:3) = Element % NodeIndexes( FaceMap ) 12326 CALL sort(3, nodes) 12327 12328 globalDir = 0 12329 ! Find local numbers of sorted nodes. These local nodes 12330 ! span continuous functions over element boundaries 12331 DO i=1,Element % TYPE % NumberOfNodes 12332 IF (nodes(1) == Element % NodeIndexes(i)) THEN 12333 globalDir(1) = i 12334 ELSE IF (nodes(2) == Element % NodeIndexes(i)) THEN 12335 globalDir(2) = i 12336 ELSE IF (nodes(3) == Element % NodeIndexes(i)) THEN 12337 globalDir(3) = i 12338 END IF 12339 END DO 12340 END FUNCTION getTriangleFaceDirection 12341 12342 12343!------------------------------------------------------------------------------ 12344!> Given element and its face map (for some square face of element ), 12345!> this routine returns global direction of square face so that 12346!> functions are continuous over element boundaries 12347!------------------------------------------------------------------------------ 12348 FUNCTION getSquareFaceDirection( Element, FaceMap ) RESULT(globalDir) 12349!------------------------------------------------------------------------------ 12350 IMPLICIT NONE 12351 TYPE(Element_t) :: Element !< Element to get direction to 12352 INTEGER :: FaceMap(4) !< Element square face map 12353 INTEGER :: globalDir(4) !< Global direction of square face as local node numbers. 12354!------------------------------------------------------------------------------ 12355 INTEGER :: i, A,B,C,D, nodes(4), minGlobal 12356 12357 ! Get global nodes 12358 nodes(1:4) = Element % NodeIndexes( FaceMap ) 12359 ! Find min global node 12360 minGlobal = nodes(1) 12361 A = 1 12362 DO i=2,4 12363 IF (nodes(i) < minGlobal) THEN 12364 A = i 12365 minGlobal = nodes(i) 12366 END IF 12367 END DO 12368 12369 ! Now choose node B as the smallest node NEXT to min node 12370 B = MOD(A,4)+1 12371 C = MOD(A+3,4) 12372 IF (C == 0) C = 4 12373 D = MOD(A+2,4) 12374 IF (D == 0) D = 4 12375 IF (nodes(B) > nodes(C)) THEN 12376 i = B 12377 B = C 12378 C = i 12379 END IF 12380 12381 ! Finally find local numbers of nodes A,B and C. They uniquely 12382 ! define a global face so that basis functions are continuous 12383 ! over element boundaries 12384 globalDir = 0 12385 DO i=1,Element % TYPE % NumberOfNodes 12386 IF (nodes(A) == Element % NodeIndexes(i)) THEN 12387 globalDir(1) = i 12388 ELSE IF (nodes(B) == Element % NodeIndexes(i)) THEN 12389 globalDir(2) = i 12390 ELSE IF (nodes(C) == Element % NodeIndexes(i)) THEN 12391 globalDir(4) = i 12392 ELSE IF (nodes(D) == Element % NodeIndexes(i)) THEN 12393 globalDir(3) = i 12394 END IF 12395 END DO 12396 END FUNCTION getSquareFaceDirection 12397 12398 12399!------------------------------------------------------------------------------ 12400!> Function checks if given local numbering of a square face 12401!> is legal for wedge element 12402!------------------------------------------------------------------------------ 12403 FUNCTION wedgeOrdering( ordering ) RESULT(retVal) 12404!------------------------------------------------------------------------------ 12405 IMPLICIT NONE 12406 12407 INTEGER, DIMENSION(4), INTENT(IN) :: ordering !< Local ordering of a wedge square face 12408 LOGICAL :: retVal !< .TRUE. iff given ordering is legal for wedge square face. 12409 12410 retVal = .FALSE. 12411 IF ((ordering(1) >= 1 .AND. ordering(1) <= 3 .AND.& 12412 ordering(2) >= 1 .AND. ordering(2) <= 3) .OR. & 12413 (ordering(1) >= 4 .AND. ordering(1) <= 6 .AND.& 12414 ordering(2) >= 4 .AND. ordering(2) <= 6)) THEN 12415 retVal = .TRUE. 12416 END IF 12417 END FUNCTION wedgeOrdering 12418 12419 !--------------------------------------------------------- 12420 !> Computes the 3D rotation matrix for a given 12421 !> surface normal vector 12422 !--------------------------------------------------------- 12423 FUNCTION ComputeRotationMatrix(PlaneVector) RESULT ( RotMat ) 12424 12425 REAL(KIND=dp) :: PlaneVector(3), RotMat(3,3), ex(3), ey(3), ez(3) 12426 INTEGER :: i, MinIndex, MidIndex, MaxIndex 12427 12428 !Ensure PlaneVector is the unit normal 12429 PlaneVector = PlaneVector / SQRT( SUM(PlaneVector ** 2) ) 12430 12431 !The new z-axis is normal to the defined surface 12432 ez = PlaneVector 12433 12434 MaxIndex = MAXLOC(ABS(ez),1) 12435 MinIndex = MINLOC(ABS(ez),1) 12436 12437 !Special case when calving front perfectly aligned to either 12438 ! x or y axis. In this case, make minindex = 3 (ex points upwards) 12439 IF(ABS(ez(3)) == ABS(ez(2)) .OR. ABS(ez(3)) == ABS(ez(1))) & 12440 MinIndex = 3 12441 12442 DO i=1,3 12443 IF(i == MaxIndex .OR. i == MinIndex) CYCLE 12444 MidIndex = i 12445 END DO 12446 12447 ex(MinIndex) = 1.0 12448 ex(MidIndex) = 0.0 12449 12450 ex(MaxIndex) = -ez(MinIndex)/ez(MaxIndex) 12451 ex = ex / SQRT( SUM(ex ** 2) ) 12452 12453 !The new y-axis is orthogonal to new x and z axes 12454 ey = CrossProduct(ez, ex) 12455 ey = ey / SQRT( SUM(ey ** 2) ) !just in case... 12456 12457 RotMat(1,:) = ex 12458 RotMat(2,:) = ey 12459 RotMat(3,:) = ez 12460 12461 END FUNCTION ComputeRotationMatrix 12462 12463END MODULE ElementDescription 12464 12465 12466!> \} 12467