Book a Demo!
CoCalc Logo Icon
StoreFeaturesDocsShareSupportNewsAboutPoliciesSign UpSign In
ElmerCSC
GitHub Repository: ElmerCSC/elmerfem
 Path: blob/devel/fem/src/ElementDescription.F90
5198 views
1
!/*****************************************************************************/

2
! *

3
! *  Elmer, A Finite Element Software for Multiphysical Problems

4
! *

5
! *  Copyright 1st April 1995 - , CSC - IT Center for Science Ltd., Finland

6
! * 

7
! *  This library is free software; you can redistribute it and/or

8
! *  modify it under the terms of the GNU Lesser General Public

9
! *  License as published by the Free Software Foundation; either

10
! *  version 2.1 of the License, or (at your option) any later version.

11
! *

12
! *  This library is distributed in the hope that it will be useful,

13
! *  but WITHOUT ANY WARRANTY; without even the implied warranty of

14
! *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU

15
! *  Lesser General Public License for more details.

16
! * 

17
! *  You should have received a copy of the GNU Lesser General Public

18
! *  License along with this library (in file ../LGPL-2.1); if not, write 

19
! *  to the Free Software Foundation, Inc., 51 Franklin Street, 

20
! *  Fifth Floor, Boston, MA  02110-1301  USA

21
! *

22
! *****************************************************************************/

23
!

24
!/******************************************************************************

25
! *

26
! *  Authors: Juha Ruokolainen

27
! *  Email:   [email protected]

28
! *  Web:     http://www.csc.fi/elmer

29
! *  Address: CSC - IT Center for Science Ltd.

30
! *           Keilaranta 14

31
! *           02101 Espoo, Finland 

32
! *

33
! *  Original Date: 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


46
MODULE ElementDescription

47
   USE Integration

48
   USE LinearAlgebra

49
   USE CoordinateSystems

50
   ! Use module P element basis functions 

51
   USE PElementMaps

52
   USE PElementBase

53
   ! Vectorized P element basis functions

54
   USE H1Basis

55
   USE Lists

56
   

57
   IMPLICIT NONE

58


59
   INTEGER, PARAMETER,PRIVATE  :: MaxDeg  = 4, MaxDeg3 = MaxDeg**3, &

60
                           MaxDeg2 = MaxDeg**2

61


62
   INTEGER, PARAMETER :: MAX_ELEMENT_NODES = 256

63


64
   !

65
   ! Module global variables

66
   !

67
   LOGICAL, PRIVATE :: TypeListInitialized = .FALSE.

68
   TYPE(ElementType_t), PRIVATE, POINTER :: ElementTypeList

69


70
   ! Local workspace for basis function values and mapping

71
!    REAL(KIND=dp), ALLOCATABLE, PRIVATE :: BasisWrk(:,:), dBasisdxWrk(:,:,:), &

72
!            LtoGMapsWrk(:,:,:), DetJWrk(:), uWrk(:), vWrk(:), wWrk(:)

73
!     !$OMP THREADPRIVATE(BasisWrk, dBasisdxWrk, LtoGMapsWrk, DetJWrk, uWrk, vWrk, wWrk)

74
! !DIR$ ATTRIBUTES ALIGN:64::BasisWrk, dBasisdxWrk

75
! !DIR$ ATTRIBUTES ALIGN:64::LtoGMapsWrk

76
! !DIR$ ATTRIBUTES ALIGN:64::DetJWrk

77
! !DIR$ ATTRIBUTES ALIGN:64::uWrk, vWrk, wWrk

78


79
CONTAINS

80


81
!------------------------------------------------------------------------------

82
    SUBROUTINE SwapRefElemNodes(p)

83
!------------------------------------------------------------------------------

84
      LOGICAL :: p

85
!------------------------------------------------------------------------------

86
      INTEGER :: n

87
      TYPE(ElementType_t), POINTER :: et

88
!------------------------------------------------------------------------------

89
      

90
      et => ElementTypeList

91
      DO WHILE(ASSOCIATED(et))

92
        n = et % NumberOfNodes

93


94
        ! Single node does not really have much options here...

95
        IF( et % ElementCode < 200 ) THEN

96
          CONTINUE

97
        ELSE IF( p .AND. ALLOCATED(et % NodeU) ) THEN

98
          IF ( .NOT.ALLOCATED(et % P_NodeU) ) THEN

99
            ALLOCATE(et % P_NodeU(n), et % P_NodeV(n), et % P_NodeW(n))

100
            CALL GetRefPElementNodes( et,  et % P_NodeU, et % P_NodeV, et % P_NodeW )

101
          END IF

102
          et % NodeU = et % P_NodeU

103
          et % NodeV = et % P_NodeV

104
          et % NodeW = et % P_NodeW

105
        ELSE IF ( ALLOCATED(et % N_NodeU) ) THEN

106
          et % NodeU = et % N_NodeU

107
          et % NodeV = et % N_NodeV

108
          et % NodeW = et % N_NodeW

109
        END IF

110
        et => et % NextElementType

111
      END DO

112
!------------------------------------------------------------------------------

113
    END SUBROUTINE SwapRefElemNodes

114
!------------------------------------------------------------------------------

115


116
!------------------------------------------------------------------------------

117
!> Add an element description to global list of element types.

118
!------------------------------------------------------------------------------

119
   SUBROUTINE AddElementDescription( element,BasisTerms )

120
!------------------------------------------------------------------------------

121
      INTEGER, DIMENSION(:) :: BasisTerms  !< List of terms in the basis function that should be included for this element type. 

122
	                                       ! BasisTerms(i) is an integer from 1-27 according to the list below.

123
      TYPE(ElementType_t), TARGET :: element !< Structure holding element type description

124
!------------------------------------------------------------------------------

125
!     Local variables

126
!------------------------------------------------------------------------------

127
      TYPE(ElementType_t), POINTER :: temp

128


129
      INTEGER, DIMENSION(MaxDeg3) :: s

130
      INTEGER :: i,j,k,l,m,n,upow,vpow,wpow,i1,i2,ii(9),jj

131


132
      REAL(KIND=dp) :: u,v,w,r

133
      REAL(KIND=dp), DIMENSION(:,:), ALLOCATABLE :: A, B

134
!------------------------------------------------------------------------------

135


136
!     PRINT*,'Adding element type: ', element % ElementCode

137


138
      n = element % NumberOfNodes

139
      element % NumberOfEdges = 0

140
      element % NumberOfFaces = 0

141
      element % BasisFunctionDegree = 0

142
      NULLIFY( element % BasisFunctions )

143


144
      IF ( element % ElementCode >= 200 ) THEN

145


146
      ALLOCATE( A(n,n) )

147


148
!------------------------------------------------------------------------------

149
!     1D bar elements

150
!------------------------------------------------------------------------------

151
      IF ( element % DIMENSION == 1 ) THEN

152


153
         DO i = 1,n

154
           u = element % NodeU(i)

155
           DO j = 1,n

156
             k = BasisTerms(j) - 1

157
             upow = k

158
             IF ( u==0 .AND. upow == 0 ) THEN

159
                A(i,j) = 1

160
             ELSE

161
                A(i,j) = u**upow

162
             END IF

163
             element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,upow) 

164
           END DO

165
         END DO

166


167
!        ALLOCATE( element % BasisFunctions(MaxDeg,MaxDeg) )

168


169
!------------------------------------------------------------------------------

170
!     2D surface elements

171
!------------------------------------------------------------------------------

172
      ELSE IF ( element % DIMENSION == 2 ) THEN

173


174
         DO i = 1,n

175
            u = element % NodeU(i)

176
            v = element % NodeV(i)

177
            DO j = 1,n

178
              k = BasisTerms(j) - 1

179
              vpow = k / MaxDeg 

180
              upow = MOD(k,MaxDeg)

181


182
              IF ( upow == 0 ) THEN

183
                 A(i,j) = 1

184
              ELSE

185
                 A(i,j) = u**upow

186
              END IF

187


188
              IF ( vpow /= 0 ) THEN

189
                 A(i,j) = A(i,j) * v**vpow

190
              END IF

191


192
              element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,upow) 

193
              element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,vpow) 

194
            END DO

195
         END DO

196


197
!        ALLOCATE( element % BasisFunctions(MaxDeg2,MaxDeg2) )

198


199
!------------------------------------------------------------------------------

200
!     3D volume elements

201
!------------------------------------------------------------------------------

202
      ELSE

203


204
         DO i = 1,n

205
            u = element % NodeU(i)

206
            v = element % NodeV(i)

207
            w = element % NodeW(i)

208
            DO j = 1,n

209
              k = BasisTerms(j) - 1

210
              upow = MOD( k,MaxDeg )

211
              wpow = k / MaxDeg2

212
              vpow = MOD( k / MaxDeg, MaxDeg )

213


214
              IF ( upow == 0 ) THEN

215
                 A(i,j) = 1

216
              ELSE

217
                 A(i,j) = u**upow

218
              END IF

219


220
              IF ( vpow /= 0 ) THEN

221
                 A(i,j) = A(i,j) * v**vpow

222
              END IF

223


224
              IF ( wpow /= 0 ) THEN

225
                 A(i,j) = A(i,j) * w**wpow

226
              END IF

227


228
              element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,upow) 

229
              element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,vpow) 

230
              element % BasisFunctionDegree = MAX(element % BasisFunctionDegree,wpow) 

231
            END DO

232
         END DO

233


234
!        ALLOCATE( element % BasisFunctions(MaxDeg3,MaxDeg3) )

235
      END IF

236


237
!------------------------------------------------------------------------------

238
!     Compute the coefficients of the basis function terms

239
!------------------------------------------------------------------------------

240
      CALL InvertMatrix( A,n )

241


242
      IF ( Element % ElementCode == 202 ) THEN

243
         ALLOCATE( Element % BasisFunctions(14) )

244
      ELSE

245
         ALLOCATE( Element % BasisFunctions(n) )

246
      END IF

247


248
      upow = 0

249
      vpow = 0

250
      wpow = 0

251


252
      DO i = 1,n

253
        Element % BasisFunctions(i) % n = n

254
        ALLOCATE( Element % BasisFunctions(i) % p(n) )

255
        ALLOCATE( Element % BasisFunctions(i) % q(n) )

256
        ALLOCATE( Element % BasisFunctions(i) % r(n) )

257
        ALLOCATE( Element % BasisFunctions(i) % Coeff(n) )

258


259
        DO j = 1,n

260
          k = BasisTerms(j) - 1

261


262
          SELECT CASE( Element % DIMENSION ) 

263
          CASE(1)

264
             upow = k

265
          CASE(2)

266
             vpow = k / MaxDeg 

267
             upow = MOD(k,MaxDeg)

268
          CASE(3)

269
             upow = MOD( k,MaxDeg )

270
             wpow = k / MaxDeg2

271
             vpow = MOD( k / MaxDeg, MaxDeg )

272
           END SELECT

273


274
           Element % BasisFunctions(i) % p(j) = upow

275
           Element % BasisFunctions(i) % q(j) = vpow

276
           Element % BasisFunctions(i) % r(j) = wpow

277
           Element % BasisFunctions(i) % Coeff(j) = A(j,i)

278
        END DO

279
      END DO

280


281
      DEALLOCATE( A )

282


283
      IF ( Element % ElementCode == 202 ) THEN

284
         ALLOCATE( A(14,14) )

285
         A = 0

286
         CALL Compute1DPBasis( A,14 )

287


288
         DO i=3,14

289
            ALLOCATE( Element % BasisFunctions(i) % p(i) )

290
            ALLOCATE( Element % BasisFunctions(i) % q(i) )

291
            ALLOCATE( Element % BasisFunctions(i) % r(i) )

292
            ALLOCATE( Element % BasisFunctions(i) % Coeff(i) )

293


294
            k = 0

295
            DO j=1,i

296
               IF ( A(i,j) /= 0.0d0 ) THEN

297
                  k = k + 1

298
                  Element % BasisFunctions(i) % p(k) = j-1

299
                  Element % BasisFunctions(i) % q(k) = 0

300
                  Element % BasisFunctions(i) % r(k) = 0

301
                  Element % BasisFunctions(i) % Coeff(k) = A(i,j)

302
               END IF

303
            END DO

304
            Element % BasisFunctions(i) % n = k

305
         END DO

306
         DEALLOCATE( A )

307
      END IF

308


309
!------------------------------------------------------------------------------

310


311
      SELECT CASE( Element % ElementCode / 100 )

312
        CASE(2) 

313
           Element % NumberOfEdges = 1

314
        CASE(3) 

315
           Element % NumberOfFaces = 1

316
           Element % NumberOfEdges = 3

317
        CASE(4) 

318
           Element % NumberOfFaces = 1

319
           Element % NumberOfEdges = 4

320
        CASE(5) 

321
           Element % NumberOfFaces = 4

322
           Element % NumberOfEdges = 6

323
        CASE(6) 

324
           Element % NumberOfFaces = 5

325
           Element % NumberOfEdges = 8

326
        CASE(7) 

327
           Element % NumberOfFaces = 5

328
           Element % NumberOfEdges = 9

329
        CASE(8) 

330
           Element % NumberOfFaces = 6

331
           Element % NumberOfEdges = 12

332
      END SELECT

333


334
      END IF ! type >= 200

335


336
!------------------------------------------------------------------------------

337
!     And finally add the element description to the global list of types

338
!------------------------------------------------------------------------------

339
      IF ( .NOT.TypeListInitialized ) THEN

340
        ALLOCATE( ElementTypeList )

341
        ElementTypeList = element

342
        TypeListInitialized = .TRUE.

343
        NULLIFY( ElementTypeList % NextElementType )

344
      ELSE

345
        ALLOCATE( temp )

346
        temp = element

347
        temp % NextElementType => ElementTypeList

348
        ElementTypeList => temp

349
      END IF

350


351
!------------------------------------------------------------------------------

352


353
CONTAINS

354


355


356
!------------------------------------------------------------------------------

357
!> Subroutine to compute 1D P-basis from Legendre polynomials.

358
!------------------------------------------------------------------------------

359
   SUBROUTINE Compute1DPBasis( Basis,n )

360
!------------------------------------------------------------------------------

361
     INTEGER :: n

362
     REAL(KIND=dp) :: Basis(:,:)

363
!------------------------------------------------------------------------------

364
     REAL(KIND=dp)   :: s,P(n+1),Q(n),P0(n),P1(n+1)

365
     INTEGER :: i,j,k,np,info

366


367
!------------------------------------------------------------------------------

368


369
     IF ( n <= 1 ) THEN

370
        Basis(1,1)     = 1.0d0

371
        RETURN

372
     END IF

373
!------------------------------------------------------------------------------

374
! Compute coefficients of n:th Legendre polynomial from the recurrence:

375
!

376
! (i+1)P_{i+1}(x) = (2i+1)*x*P_i(x) - i*P_{i-1}(x), P_{0} = 1; P_{1} = x;

377
!

378
! CAVEAT: Computed coefficients inaccurate for n > ~15

379
!------------------------------------------------------------------------------

380
     P = 0

381
     P0 = 0

382
     P1 = 0

383
     P0(1) = 1

384
     P1(1) = 1

385
     P1(2) = 0

386


387
     Basis(1,1) =  0.5d0

388
     Basis(1,2) = -0.5d0

389


390
     Basis(2,1) =  0.5d0

391
     Basis(2,2) =  0.5d0

392


393
     DO k=2,n

394
       IF ( k > 2 ) THEN

395
          s = SQRT( (2.0d0*(k-1)-1) / 2.0d0 )

396
          DO j=1,k-1

397
             Basis(k,k-j+1) = s * P0(j) / (k-j)

398
             Basis(k,1) = Basis(k,1) - s * P0(j)*(-1)**(j+1) / (k-j)

399
          END DO

400
       END IF

401


402
       i = k - 1

403
       P(1:i+1) = (2*i+1) * P1(1:i+1)  / (i+1)

404
       P(3:i+2) = P(3:i+2) - i*P0(1:i) / (i+1)

405
       P0(1:i+1) = P1(1:i+1)

406
       P1(1:i+2) = P(1:i+2)

407
     END DO

408
!--------------------------------------------------------------------------

409
 END SUBROUTINE Compute1DPBasis

410
!--------------------------------------------------------------------------

411


412
   END SUBROUTINE AddElementDescription 

413
!------------------------------------------------------------------------------

414


415


416


417
!------------------------------------------------------------------------------

418
!>   Read the element description input file and add the element types to a

419
!>   global list. The file is assumed to be found under the name

420
!>        $ELMER_HOME/lib/elements.def

421
!>   This is the first routine the user of the element utilities should call

422
!>   in his/her code.

423
!------------------------------------------------------------------------------

424
   SUBROUTINE InitializeElementDescriptions()

425
!------------------------------------------------------------------------------

426
!     Local variables

427
!------------------------------------------------------------------------------

428
      CHARACTER(LEN=:), ALLOCATABLE :: tstr, str,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
      ALLOCATE(CHARACTER(MAX_PATH_LEN)::elmer_home)

459


460
      tstr = 'ELMER_LIB'

461
      CALL envir( tstr,elmer_home,k ) 

462
      

463
      fexist = .FALSE.

464
      IF (  k > 0 ) THEN

465
         tstr = elmer_home(1:k) // '/elements.def'

466
	 INQUIRE(FILE=TRIM(tstr), EXIST=fexist)

467
      END IF

468
      IF (.NOT. fexist) THEN

469
        tstr = 'ELMER_HOME'

470
        CALL envir( tstr,elmer_home,k ) 

471
        IF ( k > 0 ) THEN

472
           tstr = elmer_home(1:k)//'/share/elmersolver/lib/elements.def'

473
           INQUIRE(FILE=TRIM(tstr), EXIST=fexist)

474
        END IF

475
        IF ((.NOT. fexist) .AND. k > 0) THEN

476
           tstr = elmer_home(1:k)//'/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
        tstr = elmer_home(1:n)//'/lib/elements.def'

483
        INQUIRE(FILE=TRIM(tstr), EXIST=fexist)

484
     END IF

485
     IF (.NOT. fexist) THEN

486
        CALL Fatal('InitializeElementDescriptions','elements.def not found')

487
     END IF

488


489
      OPEN( 1,FILE=TRIM(tstr), STATUS='OLD' )

490


491
      ALLOCATE(CHARACTER(MAX_STRING_LEN)::str)

492
      DO WHILE( ReadAndTrim(1,str) )

493


494
        IF ( SEQL(str, 'element') ) THEN

495


496
          BasisTerms = 0

497


498
          gotit = .FALSE.

499
          DO WHILE( ReadAndTrim(1,str) )

500


501
            IF ( SEQL(str, 'dimension') ) THEN

502
              READ( str(10:), * ) element % DIMENSION

503


504
            ELSE IF ( SEQL(str, 'code') ) THEN

505
              READ( str(5:), * ) element % ElementCode

506


507
            ELSE IF ( SEQL(str, 'nodes') ) THEN

508
              READ( str(6:), * ) element % NumberOfNodes

509


510
            ELSE IF ( SEQL(str, 'node u') ) THEN

511
              ALLOCATE( element % NodeU(element % NumberOfNodes) )

512
              READ( str(7:), * ) (element % NodeU(k),k=1,element % NumberOfNodes)

513


514
            ELSE IF ( SEQL(str, 'node v') ) THEN

515
              ALLOCATE( element % NodeV(element % NumberOfNodes) )

516
              READ( str(7:), * ) (element % NodeV(k),k=1,element % NumberOfNodes)

517


518
            ELSE IF ( SEQL(str, 'node w') ) THEN

519
              ALLOCATE( element % NodeW(element % NumberOfNodes ) )

520
              READ( str(7:), * ) (element % NodeW(k),k=1,element % NumberOfNodes)

521


522
            ELSE IF ( SEQL(str, 'basis') ) THEN

523
              READ( str(6:), * ) (BasisTerms(k),k=1,element % NumberOfNodes)

524


525
            ELSE IF ( SEQL(str, 'stabilization') ) THEN

526
              READ( str(14:), * ) element % StabilizationMK

527


528
            ELSE IF ( SEQL(str, 'gauss points') ) THEN

529


530
              Element % GaussPoints2 = 0

531
              READ( str(13:), *,END=10 ) element % GaussPoints,&

532
                  element % GaussPoints2, element % GaussPoints0 

533


534
10            CONTINUE

535


536
              IF ( Element % GaussPoints2 <= 0 ) &

537
                   Element % GaussPoints2 = Element % GaussPoints

538


539
              IF ( Element % GaussPoints0 <= 0 ) &

540
                   Element % GaussPoints0 = Element % GaussPoints

541
             

542
            ELSE IF ( str == 'end element' ) THEN

543
              gotit = .TRUE.

544
              EXIT

545
            END IF

546
          END DO

547


548
          IF ( gotit ) THEN

549
            Element % StabilizationMK = 0.0d0

550
            IF ( .NOT.ALLOCATED( element % NodeV ) ) THEN

551
              ALLOCATE( element % NodeV(element % NumberOfNodes) )

552
              element % NodeV = 0.0d0

553
            END IF

554


555
            IF ( .NOT.ALLOCATED( element % NodeW ) ) THEN

556
              ALLOCATE( element % NodeW(element % NumberOfNodes) )

557
              element % NodeW = 0.0d0

558
            END IF

559


560
            CALL AddElementDescription( element,BasisTerms )

561
            IF ( ALLOCATED( element % NodeU ) ) DEALLOCATE( element % NodeU )

562
            IF ( ALLOCATED( element % NodeV ) ) DEALLOCATE( element % NodeV )

563
            IF ( ALLOCATED( element % NodeW ) ) DEALLOCATE( element % NodeW )

564
          ELSE

565
            IF ( ALLOCATED( element % NodeU ) ) DEALLOCATE( element % NodeU )

566
            IF ( ALLOCATED( element % NodeV ) ) DEALLOCATE( element % NodeV )

567
            IF ( ALLOCATED( element % NodeW ) ) DEALLOCATE( element % NodeW )

568
          END IF

569
        END IF

570
      END DO

571


572
      CLOSE(1)

573
!------------------------------------------------------------------------------

574
   END SUBROUTINE InitializeElementDescriptions

575
!------------------------------------------------------------------------------

576


577


578


579
!------------------------------------------------------------------------------

580
!>    Given element type code return pointer to the corresponding element type

581
!>    structure.

582
!------------------------------------------------------------------------------

583
   FUNCTION GetElementType( code,CompStabFlag ) RESULT(element)

584
!------------------------------------------------------------------------------

585
      INTEGER :: code

586
      LOGICAL, OPTIONAL :: CompStabFlag

587
      TYPE(ElementType_t), POINTER :: element

588
!------------------------------------------------------------------------------

589
!     Local variables

590
!------------------------------------------------------------------------------

591
      TYPE(Nodes_t) :: Nodes

592
      INTEGER :: sdim

593
      TYPE(Element_t), POINTER :: Elm

594
!------------------------------------------------------------------------------

595
      element => ElementTypeList

596


597
      DO WHILE( ASSOCIATED(element) )

598
        IF ( code == element % ElementCode ) EXIT

599
        element => element % NextElementType

600
      END DO

601


602
      IF ( .NOT. ASSOCIATED( element ) ) THEN

603
        WRITE( message, * ) &

604
             'Element type code ',code,' not found. Ignoring element.'

605
        CALL Warn( 'GetElementType', message )

606
        RETURN

607
      END IF

608


609
      IF ( PRESENT( CompStabFlag ) ) THEN

610
        IF ( .NOT. CompStabFlag ) RETURN

611
      END IF

612


613
      IF ( Element % StabilizationMK == 0.0d0 ) THEN

614
        ALLOCATE( Elm )

615
        Elm % TYPE => element

616
        Elm % BDOFs  = 0

617
        Elm % DGDOFs = 0

618
        NULLIFY( Elm % PDefs )

619
        NULLIFY( Elm % DGIndexes )

620
        NULLIFY( Elm % EdgeIndexes )

621
        NULLIFY( Elm % FaceIndexes )

622
        NULLIFY( Elm % BubbleIndexes )

623
        Nodes % x => Element % NodeU

624
        Nodes % y => Element % NodeV

625
        Nodes % z => Element % NodeW

626


627
        sdim = CurrentModel % Dimension

628
        CurrentModel % Dimension = Element % Dimension

629
        CALL StabParam( Elm, Nodes, Element % NumberOfNodes, &

630
                 Element % StabilizationMK )

631
        CurrentModel % Dimension = sdim

632


633
        DEALLOCATE(Elm)

634
      END IF

635


636
   END FUNCTION GetElementType

637
!------------------------------------------------------------------------------

638


639


640
!------------------------------------------------------------------------------

641
!> Compute convection diffusion equation stab. parameter  for each and every

642
!> element of the model by solving the largest eigenvalue of

643
!

644
!> Lu = \lambda Gu,

645
!

646
!> L = (\nablda^2 u,\nabla^ w), G = (\nabla u,\nabla w)

647
!------------------------------------------------------------------------------

648
   SUBROUTINE StabParam(Element,Nodes,n,mK,hK,UseLongEdge)

649
!------------------------------------------------------------------------------

650
      IMPLICIT NONE

651


652
      TYPE(Element_t), POINTER :: Element

653
      INTEGER :: n

654
      TYPE(Nodes_t) :: Nodes

655
      REAL(KIND=dp) :: mK

656
      REAL(KIND=dp), OPTIONAL :: hK

657
      LOGICAL, OPTIONAL :: UseLongEdge

658
!------------------------------------------------------------------------------

659
      INTEGER :: info,p,q,i,j,t,dim

660
      REAL(KIND=dp) :: EIGR(n),EIGI(n),Beta(n),s,ddp(3),ddq(3),dNodalBasisdx(n,n,3)

661
      REAL(KIND=dp) :: u,v,w,L(n-1,n-1),G(n-1,n-1),Work(16*n)

662
      REAL(KIND=dp) :: Basis(n),dBasisdx(n,3),ddBasisddx(n,3,3),detJ

663


664
      LOGICAL :: stat

665
      TYPE(GaussIntegrationPoints_t) :: IntegStuff

666


667
      IF ( Element % TYPE % BasisFunctionDegree <= 1 ) THEN

668
         SELECT CASE( Element % TYPE % ElementCode ) 

669
           CASE( 202, 303, 404, 504, 605, 706  )

670
              mK = 1.0d0 / 3.0d0

671
           CASE( 808 )

672
              mK = 1.0d0 / 6.0d0

673
         END SELECT

674
         IF ( PRESENT( hK ) ) hK = ElementDiameter( Element, Nodes, UseLongEdge)

675
         RETURN

676
      END IF

677


678
      dNodalBasisdx = 0._dp

679
      DO p=1,n

680
        u = Element % TYPE % NodeU(p)

681
        v = Element % TYPE % NodeV(p)

682
        w = Element % TYPE % NodeW(p)

683
        stat = ElementInfo( Element, Nodes, u,v,w, detJ, Basis, dBasisdx )

684
        dNodalBasisdx(1:n,p,:) = dBasisdx(1:n,:)

685
      END DO

686


687
      dim = CoordinateSystemDimension()

688
      IntegStuff = GaussPoints( Element )

689
      L = 0.0d0

690
      G = 0.0d0

691
      DO t=1,IntegStuff % n

692
        u = IntegStuff % u(t)

693
        v = IntegStuff % v(t)

694
        w = IntegStuff % w(t)

695


696
        stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis, &

697
                dBasisdx )

698


699
        s = detJ * IntegStuff % s(t)

700


701
        DO p=2,n

702
          DO q=2,n

703
            ddp = 0.0d0

704
            ddq = 0.0d0

705
            DO i=1,dim

706
              G(p-1,q-1) = G(p-1,q-1) + s * dBasisdx(p,i) * dBasisdx(q,i)

707
              ddp(i) = ddp(i) + SUM( dNodalBasisdx(p,1:n,i) * dBasisdx(1:n,i) )

708
              ddq(i) = ddq(i) + SUM( dNodalBasisdx(q,1:n,i) * dBasisdx(1:n,i) )

709
            END DO

710
            L(p-1,q-1) = L(p-1,q-1) + s * SUM(ddp) * SUM(ddq)

711
          END DO

712
        END DO

713
      END DO

714


715
      IF ( ALL(ABS(L) < AEPS) ) THEN

716
        mK = 1.0d0 / 3.0d0

717
        IF ( PRESENT(hK) ) THEN

718
          hK = ElementDiameter( Element,Nodes,UseLongEdge)

719
        END IF

720
        RETURN

721
      END IF

722


723


724
      CALL DSYGV( 1,'N','U',n-1,L,n-1,G,n-1,EIGR,Work,12*n,info )

725
      mK = EIGR(n-1)

726


727
      IF ( mK < 10*AEPS ) THEN

728
        mK = 1.0d0 / 3.0d0

729
        IF ( PRESENT(hK) ) THEN

730
          hK = ElementDiameter( Element,Nodes,UseLongEdge )

731
        END IF

732
        RETURN

733
      END IF

734


735
      IF ( PRESENT( hK ) ) THEN

736
        hK = SQRT( 2.0d0 / (mK * Element % TYPE % StabilizationMK) )

737
        mK = MIN( 1.0d0 / 3.0d0, Element % TYPE % StabilizationMK )

738
      ELSE

739
        SELECT CASE(Element % TYPE % ElementCode / 100)

740
        CASE(2,4,8) 

741
          mK = 4 * mK

742
        END SELECT

743
        mK = MIN( 1.0d0/3.0d0, 2/mK )

744
      END IF

745


746
!------------------------------------------------------------------------------

747
   END SUBROUTINE StabParam

748
!------------------------------------------------------------------------------

749


750


751
!------------------------------------------------------------------------------

752
!>   Given element structure return value of a quantity x given at element nodes

753
!>   at local coordinate point u inside the element. Element basis functions are

754
!>   used to compute the value. This is for 1D elements, and shouldn't probably

755
!>   be called directly by the user but through the wrapper routine

756
!>   InterpolateInElement.

757
!------------------------------------------------------------------------------

758
   FUNCTION InterpolateInElement1D( element,x,u ) RESULT(y)

759
!------------------------------------------------------------------------------

760
     TYPE(Element_t) :: element  !< element structure

761
     REAL(KIND=dp) :: u          !< Point at which to evaluate the value

762
     REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity whose value we want to know

763
     REAL(KIND=dp) :: y                !< value of the quantity y = x(u)

764
!------------------------------------------------------------------------------

765
!    Local variables

766
!------------------------------------------------------------------------------

767
     REAL(KIND=dp) :: s

768
     INTEGER :: i,j,k,n

769
     TYPE(ElementType_t), POINTER :: elt

770
     REAL(KIND=dp), POINTER :: Coeff(:)

771
     INTEGER, POINTER :: p(:)

772
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

773
!------------------------------------------------------------------------------

774


775
     elt => element % TYPE

776
     k = Elt % NumberOfNodes

777
     BasisFunctions => elt % BasisFunctions

778


779
     y = 0.0d0

780
     DO n=1,k

781
       IF ( x(n) /= 0.0d0 ) THEN

782
          p => BasisFunctions(n) % p

783
          Coeff => BasisFunctions(n) % Coeff

784


785
          s = 0.0d0

786
          DO i=1,BasisFunctions(n) % n

787
            IF (p(i)==0) THEN

788
              s = s + Coeff(i)

789
            ELSE

790
              s = s + Coeff(i) * u**p(i)

791
            END if

792
          END DO

793
          y = y + s * x(n)

794
       END IF

795
     END DO

796
   END FUNCTION InterpolateInElement1D

797
!------------------------------------------------------------------------------

798


799


800
!------------------------------------------------------------------------------

801
   SUBROUTINE NodalBasisFunctions1D( y,element,u )

802
!------------------------------------------------------------------------------

803
     TYPE(Element_t) :: element  !< element structure

804
     REAL(KIND=dp) :: u          !< Point at which to evaluate the value

805
     REAL(KIND=dp) :: y(:)       !< value of the quantity y = x(u)

806


807
!------------------------------------------------------------------------------

808
!    Local variables

809
!------------------------------------------------------------------------------

810
     REAL(KIND=dp) :: s

811
     INTEGER :: i,n

812
     TYPE(ElementType_t), POINTER :: elt

813
     REAL(KIND=dp), POINTER :: Coeff(:)

814
     INTEGER, POINTER :: p(:)

815
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

816
!------------------------------------------------------------------------------

817


818
     elt => element % TYPE

819
     BasisFunctions => elt % BasisFunctions

820


821
     DO n=1,Elt % NumberOfNodes

822
       p => BasisFunctions(n) % p

823
       Coeff => BasisFunctions(n) % Coeff

824


825
       s = 0.0d0

826
       DO i=1,BasisFunctions(n) % n

827
         IF (p(i)==0) THEN

828
           s = s + Coeff(i)

829
         ELSE

830
           s = s + Coeff(i) * u**p(i)

831
         END if

832
       END DO

833
       y(n) = s

834
     END DO

835
   END SUBROUTINE NodalBasisFunctions1D

836
!------------------------------------------------------------------------------

837


838


839


840
!------------------------------------------------------------------------------

841
!>   Given element structure return value of the first partial derivative with

842
!>   respect to local coordinate of a quantity x given at element nodes at local

843
!>   coordinate point u inside the element. Element basis functions are used to

844
!>   compute the value. 

845
!------------------------------------------------------------------------------

846
   FUNCTION FirstDerivative1D( element,x,u ) RESULT(y)

847
!------------------------------------------------------------------------------

848
     TYPE(Element_t) :: element         !< element structure

849
     REAL(KIND=dp) :: u                 !< Point at which to evaluate the partial derivative

850
     REAL(KIND=dp), DIMENSION(:) :: x   !< Nodal values of the quantity whose partial derivative we want to know

851
     REAL(KIND=dp) :: y                 !< value of the quantity y = @x/@u

852
!------------------------------------------------------------------------------

853
!    Local variables

854
!------------------------------------------------------------------------------

855
     INTEGER :: i,j,k,n,l

856
     TYPE(ElementType_t), POINTER :: elt

857
     REAL(KIND=dp) :: s

858
     REAL(KIND=dp), POINTER :: Coeff(:)

859
     INTEGER, POINTER :: p(:)

860
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

861


862
     elt => element % TYPE

863
     k = Elt % NumberOfNodes

864
     BasisFunctions => elt % BasisFunctions

865


866
     y = 0.0d0

867
     DO n=1,k

868
       IF ( x(n) /= 0.0d0 ) THEN

869
          p => BasisFunctions(n) % p

870
          Coeff => BasisFunctions(n) % Coeff

871


872
          s = 0.0d0

873
          DO i=1,BasisFunctions(n) % n

874
             IF ( p(i) >= 1 ) THEN 

875
                s = s + p(i) * Coeff(i) * u**(p(i)-1)

876
             END IF

877
          END DO

878
          y = y + s * x(n)

879
       END IF

880
     END DO

881
   END FUNCTION FirstDerivative1D

882
!------------------------------------------------------------------------------

883


884


885
!------------------------------------------------------------------------------

886
   SUBROUTINE NodalFirstDerivatives1D( y,element,u )

887
!------------------------------------------------------------------------------

888
     REAL(KIND=dp) :: u          !< Point at which to evaluate the partial derivative

889
     REAL(KIND=dp) :: y(:,:)     !< value of the quantity y = @x/@u

890
     TYPE(Element_t) :: element  !< element structure

891
!------------------------------------------------------------------------------

892
!    Local variables

893
!------------------------------------------------------------------------------

894
     TYPE(ElementType_t), POINTER :: elt

895
     INTEGER :: i,n

896
     REAL(KIND=dp) :: s

897


898
     REAL(KIND=dp), POINTER :: Coeff(:)

899
     INTEGER, POINTER :: p(:)

900
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

901


902
     elt => element % TYPE

903
     BasisFunctions => elt % BasisFunctions

904


905
     DO n=1, Elt % NumberOfNodes

906
        p => BasisFunctions(n) % p

907
        Coeff => BasisFunctions(n) % Coeff

908


909
        s = 0.0d0

910
        DO i=1,BasisFunctions(n) % n

911
           IF (p(i)>=1) s = s + p(i)*Coeff(i)*u**(p(i)-1)

912
        END DO

913
        y(n,1) = s

914
     END DO

915
   END SUBROUTINE NodalFirstDerivatives1D

916
!------------------------------------------------------------------------------

917


918


919


920
!------------------------------------------------------------------------------

921
!>   Given element structure return value of the second partial derivative with

922
!>   respect to local coordinate of a quantity x given at element nodes at local

923
!>   coordinate point u inside the element. Element basis functions are used to

924
!>   compute the value. 

925
!------------------------------------------------------------------------------

926
   FUNCTION SecondDerivatives1D( element,x,u ) RESULT(y)

927
!------------------------------------------------------------------------------

928
     TYPE(Element_t) :: element          !< element structure

929
     REAL(KIND=dp) :: u                  !< Point at which to evaluate the partial derivative

930
     REAL(KIND=dp), DIMENSION(:) :: x    !< Nodal values of the quantity whose partial derivative we want to know

931
     REAL(KIND=dp) :: y                  !< value of the quantity y = @x/@u

932
!------------------------------------------------------------------------------

933
!    Local variables

934
!------------------------------------------------------------------------------

935
     REAL(KIND=dp) :: usum

936
     INTEGER :: i,j,k,n

937
     TYPE(ElementType_t), POINTER :: elt

938
     INTEGER, POINTER :: p(:),q(:)

939
     REAL(KIND=dp), POINTER :: Coeff(:)

940
     REAL(KIND=dp) :: s

941
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

942


943
     elt => element % TYPE

944
     k = Elt % NumberOfNodes

945
     BasisFunctions => elt % BasisFunctions

946


947
     y = 0.0d0

948
     DO n=1,k

949
       IF ( x(n) /= 0.0d0 ) THEN

950
          p => BasisFunctions(n) % p

951
          Coeff => BasisFunctions(n) % Coeff

952


953
          s = 0.0d0

954
          DO i=1,BasisFunctions(n) % n

955
             IF ( p(i) >= 2 ) THEN

956
                s = s + p(i) * (p(i)-1) * Coeff(i) * u**(p(i)-2)

957
             END IF

958
          END DO

959
          y = y + s * x(n)

960
       END IF

961
     END DO

962
   END FUNCTION SecondDerivatives1D

963
!------------------------------------------------------------------------------

964


965


966


967
!------------------------------------------------------------------------------

968
!>   Given element structure return the value of a quantity x known at element nodes

969
!>   at local coordinate point (u,v) inside the element. Element basis functions

970
!>   are used to compute the value. This is for 2D elements, and shouldn't probably

971
!>   be called directly by the user but through the wrapper routine

972
!>   InterpolateInElement.

973
!------------------------------------------------------------------------------

974
   FUNCTION InterpolateInElement2D( element,x,u,v ) RESULT(y)

975
!------------------------------------------------------------------------------

976
     TYPE(Element_t) :: element          !< element structure

977
     REAL(KIND=dp) :: u                  !< u at the point where the quantity is evaluated

978
     REAL(KIND=dp) :: v                  !< v at the point where the quantity is evaluated

979
     REAL(KIND=dp), DIMENSION(:) :: x    !< Nodal values of the quantity

980
     REAL(KIND=dp) :: y                  !< The value of the quantity y = x(u,v)

981
!------------------------------------------------------------------------------

982
!    Local variables

983
!------------------------------------------------------------------------------

984
      REAL(KIND=dp) :: s,t

985


986
      INTEGER :: i,j,k,m,n

987


988
      TYPE(ElementType_t),POINTER :: elt

989
      REAL(KIND=dp), POINTER :: Coeff(:)

990
      INTEGER, POINTER :: p(:),q(:)

991
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

992
!------------------------------------------------------------------------------

993


994
      elt => element % TYPE

995
      BasisFunctions => elt % BasisFunctions

996


997
      y = 0.0d0

998
      DO n = 1,elt % NumberOfNodes

999
        IF ( x(n) /= 0.0d0 ) THEN

1000
          p => BasisFunctions(n) % p

1001
          q => BasisFunctions(n) % q

1002
          Coeff => BasisFunctions(n) % Coeff

1003


1004
          s = 0.0d0

1005
          DO i = 1,BasisFunctions(n) % n

1006
             s = s + Coeff(i) * u**p(i) * v**q(i)

1007
          END DO

1008
          y = y + s*x(n)

1009
        END IF

1010
      END DO

1011


1012
   END FUNCTION InterpolateInElement2D

1013
!------------------------------------------------------------------------------

1014


1015


1016
!------------------------------------------------------------------------------

1017
   SUBROUTINE NodalBasisFunctions2D( y,element,u,v )

1018
!------------------------------------------------------------------------------

1019
     REAL(KIND=dp) :: y(:)       !< The values of the reference element basis

1020
     TYPE(Element_t) :: element  !< element structure

1021
     REAL(KIND=dp) :: u          !< Point at which to evaluate the value

1022
     REAL(KIND=dp) :: v          !< Point at which to evaluate the value

1023
!------------------------------------------------------------------------------

1024
!    Local variables

1025
!------------------------------------------------------------------------------

1026
     REAL(KIND=dp) :: s

1027
     INTEGER :: i,n

1028
     TYPE(ElementType_t), POINTER :: elt

1029
     REAL(KIND=dp), POINTER :: Coeff(:)

1030
     INTEGER, POINTER :: p(:),q(:)

1031
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1032
!------------------------------------------------------------------------------

1033
     REAL(KIND=dp) :: ult(0:6), vlt(0:6)

1034


1035
     elt => element % TYPE

1036
     BasisFunctions => elt % BasisFunctions

1037


1038
     ult(0) = 1

1039
     ult(1) = u

1040


1041
     vlt(0) = 1

1042
     vlt(1) = v

1043


1044
     DO i=2,elt % BasisFunctionDegree

1045
       ult(i) = u**i

1046
       vlt(i) = v**i

1047
     END DO

1048


1049
     DO n=1,Elt % NumberOfNodes

1050
       p => BasisFunctions(n) % p

1051
       q => BasisFunctions(n) % q

1052
       Coeff => BasisFunctions(n) % Coeff

1053


1054
       s = 0.0d0

1055
       DO i=1,BasisFunctions(n) % n

1056
          s = s + Coeff(i)*ult(p(i))*vlt(q(i))

1057
       END DO

1058
       y(n) = s

1059
     END DO

1060
   END SUBROUTINE NodalBasisFunctions2D

1061
!------------------------------------------------------------------------------

1062


1063


1064


1065
!------------------------------------------------------------------------------

1066
!>   Given element structure return the value of the first partial derivative with

1067
!>   respect to local coordinate u of a quantity x given at element nodes at local

1068
!>   coordinate point u,v inside the element. Element basis functions are used to

1069
!>   compute the value. 

1070
!------------------------------------------------------------------------------

1071
   FUNCTION FirstDerivativeInU2D( element,x,u,v ) RESULT(y)

1072
!------------------------------------------------------------------------------

1073
      TYPE(Element_t) :: element        !< element structure

1074
      REAL(KIND=dp) :: u,v              !< Point at which to evaluate the partial derivative

1075
      REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity to differentiate

1076
      REAL(KIND=dp) :: y                !< value of the quantity y = @x(u,v)/@u

1077
!------------------------------------------------------------------------------

1078
!    Local variables

1079
!------------------------------------------------------------------------------

1080
      REAL(KIND=dp) :: s,t

1081
      TYPE(ElementType_t),POINTER :: elt

1082
      REAL(KIND=dp), POINTER :: Coeff(:)

1083
      INTEGER, POINTER :: p(:),q(:)

1084
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1085
      INTEGER :: i,j,k,m,n

1086


1087
      elt => element % TYPE

1088
      BasisFunctions => elt % BasisFunctions

1089


1090
      y = 0.0d0

1091
      DO n = 1,elt % NumberOfNodes

1092
        IF ( x(n) /= 0.0d0 ) THEN

1093
          p => BasisFunctions(n) % p

1094
          q => BasisFunctions(n) % q

1095
          Coeff => BasisFunctions(n) % Coeff

1096


1097
          s = 0.0d0

1098
          DO i = 1,BasisFunctions(n) % n

1099
             IF ( p(i) >= 1 ) THEN

1100
               s = s + p(i) * Coeff(i) * u**(p(i)-1) * v**q(i)

1101
            END IF

1102
          END DO

1103
          y = y + s*x(n)

1104
        END IF

1105
      END DO

1106


1107
   END FUNCTION FirstDerivativeInU2D

1108
!------------------------------------------------------------------------------

1109


1110


1111


1112
!------------------------------------------------------------------------------

1113
!>   Given element structure return value of the first partial derivative with

1114
!>   respect to local coordinate v of i quantity x given at element nodes at local

1115
!>   coordinate point u,v inside the element. Element basis functions are used to

1116
!>   compute the value. 

1117
!------------------------------------------------------------------------------

1118
   FUNCTION FirstDerivativeInV2D( element,x,u,v ) RESULT(y)

1119
!------------------------------------------------------------------------------

1120
     TYPE(Element_t) :: element        !< element structure

1121
     REAL(KIND=dp) :: u,v              !< Point at which to evaluate the partial derivative

1122
     REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity to differentiate

1123
     REAL(KIND=dp) :: y                !< value of the quantity y = @x(u,v)/@u

1124
!------------------------------------------------------------------------------

1125
!    Local variables

1126
!------------------------------------------------------------------------------

1127
      REAL(KIND=dp) :: s,t

1128
      TYPE(ElementType_t),POINTER :: elt

1129
      REAL(KIND=dp), POINTER :: Coeff(:)

1130
      INTEGER, POINTER :: p(:),q(:)

1131
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1132


1133
      INTEGER :: i,j,k,m,n

1134


1135
      elt => element % TYPE

1136
      BasisFunctions => elt % BasisFunctions

1137


1138
      y = 0.0d0

1139
      DO n = 1,elt % NumberOfNodes

1140
        IF ( x(n) /= 0.0d0 ) THEN

1141
          p => BasisFunctions(n) % p

1142
          q => BasisFunctions(n) % q

1143
          Coeff => BasisFunctions(n) % Coeff

1144


1145
          s = 0.0d0

1146
          DO i = 1,BasisFunctions(n) % n

1147
             IF ( q(i) >= 1  ) THEN

1148
                s = s + q(i) * Coeff(i) * u**p(i) * v**(q(i)-1)

1149
             END IF

1150
          END DO

1151
          y = y + s*x(n)

1152
        END IF

1153
      END DO

1154


1155
   END FUNCTION FirstDerivativeInV2D

1156
!------------------------------------------------------------------------------

1157


1158


1159
!------------------------------------------------------------------------------

1160
   SUBROUTINE NodalFirstDerivatives2D( y,element,u,v )

1161
!------------------------------------------------------------------------------

1162
     TYPE(Element_t) :: element        !< element structure

1163
     REAL(KIND=dp) :: u,v              !< Point at which to evaluate the partial derivative

1164
     REAL(KIND=dp) :: y(:,:)           !< value of the quantity y = @x(u,v)/@u

1165
!------------------------------------------------------------------------------

1166
!    Local variables

1167
!------------------------------------------------------------------------------

1168
      REAL(KIND=dp) :: s,t

1169
      TYPE(ElementType_t),POINTER :: elt

1170
      REAL(KIND=dp), POINTER :: Coeff(:)

1171
      INTEGER, POINTER :: p(:),q(:)

1172
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1173


1174
      INTEGER :: i,n

1175


1176
      REAL(KIND=dp) :: ult(0:6), vlt(0:6)

1177
 

1178
      elt => element % TYPE

1179
      BasisFunctions => elt % BasisFunctions

1180


1181
      ult(0) = 1

1182
      ult(1) = u

1183


1184
      vlt(0) = 1

1185
      vlt(1) = v

1186


1187
      DO i=2,elt % BasisFunctionDegree

1188
        ult(i) = u**i

1189
        vlt(i) = v**i

1190
      END DO

1191


1192


1193
      DO n = 1,elt % NumberOfNodes

1194
        p => BasisFunctions(n) % p

1195
        q => BasisFunctions(n) % q

1196
        Coeff => BasisFunctions(n) % Coeff

1197


1198
        s = 0.0d0

1199
        t = 0.0d0

1200
        DO i = 1,BasisFunctions(n) % n

1201
          IF (p(i)>=1) s = s + p(i)*Coeff(i)*ult(p(i)-1)*vlt(q(i))

1202
          IF (q(i)>=1) t = t + q(i)*Coeff(i)*ult(p(i))*vlt(q(i)-1)

1203
        END DO

1204
        y(n,1) = s

1205
        y(n,2) = t

1206
      END DO

1207


1208
   END SUBROUTINE NodalFirstDerivatives2D

1209
!------------------------------------------------------------------------------

1210


1211


1212


1213
!------------------------------------------------------------------------------

1214
!>   Given an element structure return the second partial derivatives of 

1215
!>   a quantity x given at the element nodes with respect to the local coordinates

1216
!>   u,v of the element. The element basis functions are used to compute the value. 

1217
!------------------------------------------------------------------------------

1218
   FUNCTION SecondDerivatives2D( element,x,u,v ) RESULT(ddx)

1219
!------------------------------------------------------------------------------

1220
     TYPE(Element_t) :: element        !< Element structure

1221
     REAL(KIND=dp) :: u,v              !< Point at which to evaluate the partial derivatives

1222
     REAL(KIND=dp), DIMENSION(:) :: x  !< The nodal values of the quantity to differentiate

1223
     REAL(KIND=dp), DIMENSION (2,2) :: ddx !< The second partial derivatives of x

1224
!------------------------------------------------------------------------------

1225
!    Local variables

1226
!------------------------------------------------------------------------------

1227
      TYPE(ElementType_t),POINTER :: elt

1228
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1229
      REAL(KIND=dp) :: s,t

1230
      INTEGER, POINTER :: p(:),q(:)

1231
      REAL(KIND=dp), POINTER :: Coeff(:)

1232
      INTEGER :: i,j,k,n,m

1233


1234
!------------------------------------------------------------------------------

1235
      elt => element % TYPE

1236
      k = elt % NumberOfNodes

1237
      BasisFunctions => elt % BasisFunctions

1238


1239
      ddx = 0.0d0

1240
      DO n = 1,k

1241
        IF ( x(n) /= 0.0d0 ) THEN

1242
          p => BasisFunctions(n) % p

1243
          q => BasisFunctions(n) % q

1244
          Coeff => BasisFunctions(n) % Coeff

1245
!------------------------------------------------------------------------------

1246
!         @^2x/@u^2

1247
!------------------------------------------------------------------------------

1248
          s = 0.0d0

1249
          DO i = 1, BasisFunctions(n) % n

1250
             IF ( p(i) >= 2 ) THEN

1251
                s = s + p(i) * (p(i)-1) * Coeff(i) * u**(p(i)-2) * v**q(i)

1252
             END IF

1253
          END DO

1254
          ddx(1,1) = ddx(1,1) + s*x(n)

1255


1256
!------------------------------------------------------------------------------

1257
!         @^2x/@u@v

1258
!------------------------------------------------------------------------------

1259
          s = 0.0d0

1260
          DO i = 1, BasisFunctions(n) % n

1261
              IF ( p(i) >= 1 .AND. q(i) >= 1 ) THEN

1262
                 s = s + p(i) * q(i) * Coeff(i) * u**(p(i)-1) * v**(q(i)-1)

1263
              END IF

1264
          END DO

1265
          ddx(1,2) = ddx(1,2) + s*x(n)

1266


1267
!------------------------------------------------------------------------------

1268
!         @^2x/@v^2

1269
!------------------------------------------------------------------------------

1270
          s = 0.0d0

1271
          DO i = 1, BasisFunctions(n) % n

1272
             IF ( q(i) >= 2 ) THEN

1273
                s = s + q(i) * (q(i)-1) * Coeff(i) * u**p(i) * v**(q(i)-2)

1274
             END IF

1275
          END DO

1276
          ddx(2,2) = ddx(2,2) + s*x(n)

1277
        END IF

1278
      END DO

1279


1280
      ddx(2,1) = ddx(1,2)

1281


1282
   END FUNCTION SecondDerivatives2D

1283
!------------------------------------------------------------------------------

1284


1285


1286


1287
!------------------------------------------------------------------------------

1288
!>   Given element structure return value of a quantity x given at element nodes

1289
!>   at local coordinate point (u,v,w) inside the element. Element basis functions

1290
!>   are used to compute the value. This is for 3D elements, and shouldn't probably

1291
!>   be called directly by the user but through the wrapper routine

1292
!>   InterpolateInElement.

1293
!------------------------------------------------------------------------------

1294
   FUNCTION InterpolateInElement3D( element,x,u,v,w ) RESULT(y)

1295
!------------------------------------------------------------------------------

1296
     TYPE(Element_t) :: element        !< element structure

1297
     REAL(KIND=dp) :: u,v,w            !< Point at which to evaluate the partial derivative

1298
     REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity to differentiate

1299
     REAL(KIND=dp) :: y                !< value of the quantity y = x(u,v,w)

1300
!------------------------------------------------------------------------------

1301
!    Local variables

1302
!------------------------------------------------------------------------------

1303
      TYPE(ElementType_t),POINTER :: elt

1304
      INTEGER :: i,j,k,l,n,m

1305
      REAL(KIND=dp) :: s,t

1306
      INTEGER, POINTER :: p(:),q(:), r(:)

1307
      REAL(KIND=dp), POINTER :: Coeff(:)

1308
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1309
!------------------------------------------------------------------------------

1310


1311
      elt => element % TYPE

1312
      l = elt % BasisFunctionDegree

1313
      BasisFunctions => elt % BasisFunctions

1314


1315
      IF ( Elt % ElementCode == 605 ) THEN

1316
        s = 0.0d0

1317
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1318
        s = 1.0d0 / (1-w)

1319


1320
        y = 0.0d0

1321
        DO n=1,5

1322
          IF(x(n)==0) CYCLE

1323
          SELECT CASE(n)

1324
          CASE(1)

1325
            y = y + x(1)*((1-u)*(1-v) - w + u*v*w * s) / 4

1326
          CASE(2)

1327
            y = y + x(2)*((1+u)*(1-v) - w - u*v*w * s) / 4

1328
          CASE(3)

1329
            y = y + x(3)*((1+u)*(1+v) - w + u*v*w * s) / 4

1330
          CASE(4)

1331
            y = y + x(4)*((1-u)*(1+v) - w - u*v*w * s) / 4

1332
          CASE(5)

1333
            y = y + x(5)*w

1334
          END SELECT

1335
        END DO

1336
        RETURN

1337
      ELSE IF ( Elt % ElementCode == 613 ) THEN

1338
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1339
        s = 1.0d0 / (1-w)

1340


1341
        y = 0.0d0

1342
        DO n=1,13

1343
          IF(x(n)==0) CYCLE

1344
          SELECT CASE(n)

1345
          CASE(1)

1346
            y = y + x(1)  * (-u-v-1) * ( (1-u) * (1-v) - w + u*v*w * s ) / 4

1347
          CASE(2)

1348
            y = y + x(2)  * ( u-v-1) * ( (1+u) * (1-v) - w - u*v*w * s ) / 4

1349
          CASE(3)

1350
            y = y + x(3)  * ( u+v-1) * ( (1+u) * (1+v) - w + u*v*w * s ) / 4

1351
          CASE(4)

1352
            y = y + x(4)  * (-u+v-1) * ( (1-u) * (1+v) - w - u*v*w * s ) / 4

1353
          CASE(5)

1354
            y = y + x(5)  * w*(2*w-1)

1355
          CASE(6)

1356
            y = y + x(6)  * (1+u-w)*(1-u-w)*(1-v-w) * s / 2

1357
          CASE(7)

1358
            y = y + x(7)  * (1+v-w)*(1-v-w)*(1+u-w) * s / 2

1359
          CASE(8)

1360
            y = y + x(8)  * (1+u-w)*(1-u-w)*(1+v-w) * s / 2

1361
          CASE(9)

1362
            y = y + x(9)  * (1+v-w)*(1-v-w)*(1-u-w) * s / 2

1363
          CASE(10)

1364
            y = y + x(10) * w * (1-u-w) * (1-v-w) * s

1365
          CASE(11)

1366
            y = y + x(11) * w * (1+u-w) * (1-v-w) * s

1367
          CASE(12)

1368
            y = y + x(12) * w * (1+u-w) * (1+v-w) * s

1369
          CASE(13)

1370
            y = y + x(13) * w * (1-u-w) * (1+v-w) * s

1371
          END SELECT

1372
        END DO

1373
        RETURN

1374
      END IF

1375


1376
      y = 0.0d0

1377
      DO n = 1,elt % NumberOfNodes

1378
        IF ( x(n) /= 0.0d0 ) THEN

1379
          p => BasisFunctions(n) % p

1380
          q => BasisFunctions(n) % q

1381
          r => BasisFunctions(n) % r

1382
          Coeff => BasisFunctions(n) % Coeff

1383


1384
          s = 0.0d0

1385
          DO i = 1,BasisFunctions(n) % n

1386
             s = s + Coeff(i) * u**p(i) * v**q(i) * w**r(i)

1387
          END DO

1388
          y = y + s*x(n)

1389
        END IF

1390
      END DO

1391
!------------------------------------------------------------------------------

1392
   END FUNCTION InterpolateInElement3D

1393
!------------------------------------------------------------------------------

1394


1395


1396
!------------------------------------------------------------------------------

1397
   SUBROUTINE NodalBasisFunctions3D( y,element,u,v,w )

1398
!------------------------------------------------------------------------------

1399
     TYPE(Element_t) :: element        !< element structure

1400
     REAL(KIND=dp) :: u,v,w            !< Point at which to evaluate the basis functions

1401
     REAL(KIND=dp) :: y(:)             !< The values of the basis functions

1402
!------------------------------------------------------------------------------

1403
!    Local variables

1404
!------------------------------------------------------------------------------

1405
     REAL(KIND=dp) :: s

1406


1407
     INTEGER :: i,n

1408


1409
     TYPE(ElementType_t), POINTER :: elt

1410


1411
     REAL(KIND=dp), POINTER :: Coeff(:)

1412
     INTEGER, POINTER :: p(:),q(:),r(:)

1413
     TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1414
!------------------------------------------------------------------------------

1415
     REAL(KIND=dp) :: ult(0:6), vlt(0:6), wlt(0:6)

1416


1417
     elt => element % TYPE

1418
     BasisFunctions => elt % BasisFunctions

1419
 

1420
     ult(0) = 1

1421
     ult(1) = u

1422


1423
     vlt(0) = 1

1424
     vlt(1) = v

1425


1426
     wlt(0) = 1

1427
     wlt(1) = w

1428


1429
     DO i=2,elt % BasisFunctionDegree

1430
       ult(i) = u**i

1431
       vlt(i) = v**i

1432
       wlt(i) = w**i

1433
     END DO

1434


1435
     DO n=1,Elt % NumberOfNodes

1436
       p => BasisFunctions(n) % p

1437
       q => BasisFunctions(n) % q

1438
       r => BasisFunctions(n) % r

1439
       Coeff => BasisFunctions(n) % Coeff

1440


1441
       s = 0.0d0

1442
       DO i=1,BasisFunctions(n) % n

1443
          s = s + Coeff(i)*ult(p(i))*vlt(q(i))*wlt(r(i))

1444
       END DO

1445
       y(n) = s

1446
     END DO

1447
   END SUBROUTINE NodalBasisFunctions3D

1448
!------------------------------------------------------------------------------

1449


1450


1451
!------------------------------------------------------------------------------

1452
!>   Given element structure return value of the first partial derivative with

1453
!>   respect to local coordinate u of a quantity x given at element nodes at

1454
!>   local coordinate point u,v,w inside the element. Element basis functions

1455
!>   are used to compute the value. 

1456
!------------------------------------------------------------------------------

1457
   FUNCTION FirstDerivativeInU3D( element,x,u,v,w ) RESULT(y)

1458
!------------------------------------------------------------------------------

1459
     TYPE(Element_t) :: element        !< element structure

1460
     REAL(KIND=dp) :: u,v,w            !< Point at which to evaluate the partial derivative

1461
     REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity to be derivated

1462
     REAL(KIND=dp) :: y                !< value of the quantity y =  @x(u,v,w)/@u

1463
!------------------------------------------------------------------------------

1464
!    Local variables

1465
!------------------------------------------------------------------------------

1466
      TYPE(ElementType_t),POINTER :: elt

1467
      INTEGER :: i,j,k,l,n,m

1468
      REAL(KIND=dp) :: s,t

1469
      INTEGER, POINTER :: p(:),q(:), r(:)

1470
      REAL(KIND=dp), POINTER :: Coeff(:)

1471
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1472
!------------------------------------------------------------------------------

1473
      elt => element % TYPE

1474
      l = elt % BasisFunctionDegree

1475
      BasisFunctions => elt % BasisFunctions

1476


1477
      IF ( Elt % ElementCode == 605 ) THEN

1478
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1479
        s = 1.0d0 / (1-w)

1480


1481
        y = 0.0d0

1482
        DO n=1,5

1483
          IF(x(n)==0) CYCLE

1484
          SELECT CASE(n)

1485
          CASE(1)

1486
            y = y + x(1) * ( -(1-v) + v*w * s ) / 4

1487
          CASE(2)

1488
            y = y + x(2) * (  (1-v) - v*w * s ) / 4

1489
          CASE(3)

1490
            y = y + x(3) * (  (1+v) + v*w * s ) / 4

1491
          CASE(4)

1492
            y = y + x(4) * ( -(1+v) - v*w * s ) / 4

1493
          CASE(5)

1494
            CONTINUE

1495
          END SELECT

1496
        END DO

1497
        RETURN

1498


1499
      ELSE IF ( Elt % ElementCode == 613 ) THEN

1500
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1501
        s = 1.0d0 / (1-w)

1502


1503
        y = 0.0d0

1504
        DO n=1,13

1505
          IF(x(n)==0) CYCLE

1506
          SELECT CASE(n)

1507
          CASE(1)

1508
             y = y + x(1) * (-((1-u)*(1-v)-w+u*v*w*s)+(-u-v-1) * (-(1-v)+v*w*s))/4

1509
          CASE(2)

1510
             y = y + x(2)  * ( ((1+u)*(1-v)-w-u*v*w*s)+( u-v-1) * ( (1-v)-v*w*s))/4

1511
          CASE(3)

1512
             y = y + x(3)  * ( ((1+u)*(1+v)-w+u*v*w*s)+( u+v-1) * ( (1+v)+v*w*s))/4

1513
          CASE(4)

1514
             y = y + x(4)  * (-((1-u)*(1+v)-w-u*v*w*s)+(-u+v-1) * (-(1+v)-v*w*s))/4

1515
          CASE(5)

1516
             CONTINUE

1517
          CASE(6)

1518
             y = y + x(6)  * (  (1-u-w)*(1-v-w) - (1+u-w)*(1-v-w) ) * s / 2

1519
          CASE(7)

1520
             y = y + x(7)  * (  (1+v-w)*(1-v-w) ) * s / 2

1521
          CASE(8)

1522
             y = y + x(8)  * (  (1-u-w)*(1+v-w) - (1+u-w)*(1+v-w) ) * s / 2

1523
          CASE(9)

1524
             y = y + x(9)  * ( -(1+v-w)*(1-v-w) ) * s / 2

1525
          CASE(10)

1526
             y = y - x(10) * w * (1-v-w) * s

1527
          CASE(11)

1528
             y = y + x(11) * w * (1-v-w) * s

1529
          CASE(12)

1530
             y = y + x(12) * w * (1+v-w) * s

1531
          CASE(13)

1532
             y = y - x(13) * w * (1+v-w) * s

1533
          END SELECT

1534
        END DO

1535
        RETURN

1536
      END IF

1537


1538
      y = 0.0d0

1539
      DO n = 1,elt % NumberOfNodes

1540
        IF ( x(n) /= 0.0d0 ) THEN

1541
          p => BasisFunctions(n) % p

1542
          q => BasisFunctions(n) % q

1543
          r => BasisFunctions(n) % r

1544
          Coeff => BasisFunctions(n) % Coeff

1545


1546
          s = 0.0d0

1547
          DO i = 1,BasisFunctions(n) % n

1548
             IF ( p(i) >= 1  ) THEN

1549
                s = s + p(i) * Coeff(i) * u**(p(i)-1) * v**q(i) * w**r(i)

1550
             END IF

1551
          END DO

1552
          y = y + s*x(n)

1553
        END IF

1554
      END DO

1555
!------------------------------------------------------------------------------

1556
   END FUNCTION FirstDerivativeInU3D

1557
!------------------------------------------------------------------------------

1558


1559


1560


1561
!------------------------------------------------------------------------------

1562
!>   Given element structure return value of the first partial derivative with

1563
!>   respect to local coordinate v of a quantity x given at element nodes at

1564
!>   local coordinate point u,v,w inside the element. Element basis functions

1565
!>   are used to compute the value. 

1566
!------------------------------------------------------------------------------

1567
   FUNCTION FirstDerivativeInV3D( element,x,u,v,w ) RESULT(y)

1568
!------------------------------------------------------------------------------

1569
     TYPE(Element_t) :: element        !< element structure

1570
     REAL(KIND=dp) :: u,v,w            !< Point at which to evaluate the partial derivative

1571
     REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity to be derivated

1572
     REAL(KIND=dp) :: y                !< value of the quantity y =  @x(u,v,w)/@v

1573
!------------------------------------------------------------------------------

1574
!    Local variables

1575
!------------------------------------------------------------------------------

1576
      TYPE(ElementType_t),POINTER :: elt

1577
      INTEGER :: i,j,k,l,n,m

1578
      REAL(KIND=dp) :: s,t

1579
      INTEGER, POINTER :: p(:),q(:), r(:)

1580
      REAL(KIND=dp), POINTER :: Coeff(:)

1581
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1582
!------------------------------------------------------------------------------

1583
      elt => element % TYPE

1584
      l = elt % BasisFunctionDegree

1585
      BasisFunctions => elt % BasisFunctions

1586


1587
      IF ( Elt % ElementCode == 605 ) THEN

1588
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1589
        s = 1.0d0 / (1-w)

1590


1591
        y = 0.0d0

1592
        DO n=1,5

1593
          IF(x(n)==0) CYCLE

1594
          SELECT CASE(n)

1595
          CASE(1)

1596
            y = y + x(1) * ( -(1-u) + u*w * s ) / 4

1597
          CASE(2)

1598
            y = y + x(2) * ( -(1+u) - u*w * s ) / 4

1599
          CASE(3)

1600
            y = y + x(3) * (  (1+u) + u*w * s ) / 4

1601
          CASE(4)

1602
            y = y + x(4) * (  (1-u) - u*w * s ) / 4

1603
          CASE(5)

1604
            CONTINUE

1605
          END SELECT

1606
        END DO

1607
        RETURN

1608
      ELSE IF ( Elt % ElementCode == 613 ) THEN

1609
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1610
        s = 1.0d0 / (1-w)

1611


1612
        y = 0.0d0

1613
        DO n=1,13

1614
          IF(x(n)==0) CYCLE

1615
          SELECT CASE(n)

1616
          CASE(1)

1617
            y = y + x(1)  * ( -( (1-u) * (1-v) - w + u*v*w * s ) +  &

1618
                (-u-v-1) * ( -(1-u) + u*w * s ) ) / 4

1619
          CASE(2)

1620
            y = y + x(2)  * ( -( (1+u) * (1-v) - w - u*v*w * s ) + &

1621
                ( u-v-1) * ( -(1+u) - u*w * s ) ) / 4

1622
          CASE(3)

1623
            y = y + x(3)  * (  ( (1+u) * (1+v) - w + u*v*w * s ) + &

1624
                ( u+v-1) * (  (1+u) + u*w * s ) ) / 4

1625
          CASE(4)

1626
            y = y + x(4)  * (  ( (1-u) * (1+v) - w - u*v*w * s ) + &

1627
                (-u+v-1) * (  (1-u) - u*w * s ) ) / 4

1628
          CASE(5)

1629
            CONTINUE

1630
          CASE(6)

1631
            y = y - x(6)  *  (1+u-w)*(1-u-w) * s / 2

1632
          CASE(7)

1633
            y = y + x(7)  * ( (1-v-w)*(1+u-w) - (1+v-w)*(1+u-w) ) * s / 2

1634
          CASE(8)

1635
            y = y + x(8)  *  (1+u-w)*(1-u-w) * s / 2

1636
          CASE(9)

1637
            y = y + x(9)  * ( (1-v-w)*(1-u-w) - (1+v-w)*(1-u-w) ) * s / 2

1638
          CASE(10)

1639
            y = y - x(10) *  w * (1-u-w) * s

1640
          CASE(11)

1641
            y = y - x(11) *  w * (1+u-w) * s

1642
          CASE(12)

1643
            y = y + x(12) *  w * (1+u-w) * s

1644
          CASE(13)

1645
            y = y + x(13) *  w * (1-u-w) * s

1646
          END SELECT

1647
        END DO

1648
        RETURN

1649
      END IF

1650


1651
      y = 0.0d0

1652
      DO n = 1,elt % NumberOfNodes

1653
        IF ( x(n) /= 0.0d0 ) THEN

1654
          p => BasisFunctions(n) % p

1655
          q => BasisFunctions(n) % q

1656
          r => BasisFunctions(n) % r

1657
          Coeff => BasisFunctions(n) % Coeff

1658


1659
          s = 0.0d0

1660
          DO i = 1,BasisFunctions(n) % n

1661
             IF ( q(i) >= 1  ) THEN

1662
                s = s + q(i) * Coeff(i) * u**p(i) * v**(q(i)-1) * w**r(i)

1663
             END IF

1664
          END DO

1665
          y = y + s*x(n)

1666
        END IF

1667
      END DO

1668
   END FUNCTION FirstDerivativeInV3D

1669
!------------------------------------------------------------------------------

1670


1671


1672


1673
!------------------------------------------------------------------------------

1674
!>   Given element structure return value of the first partial derivatives with

1675
!>   respect to local coordinate w of a quantity x given at element nodes at

1676
!>   local coordinate point u,v,w inside the element. Element basis functions

1677
!>   are used to compute the value. 

1678
!------------------------------------------------------------------------------

1679
   FUNCTION FirstDerivativeInW3D( element,x,u,v,w ) RESULT(y)

1680
!------------------------------------------------------------------------------

1681
     TYPE(Element_t) :: element        !< element structure

1682
     REAL(KIND=dp) :: u,v,w            !< Point at which to evaluate the partial derivative

1683
     REAL(KIND=dp), DIMENSION(:) :: x  !< Nodal values of the quantity to be derivated

1684
     REAL(KIND=dp) :: y                !< value of the quantity y =  @x(u,v,w)/@w

1685
!------------------------------------------------------------------------------

1686
!    Local variables

1687
!------------------------------------------------------------------------------

1688
      TYPE(ElementType_t),POINTER :: elt

1689
      INTEGER :: i,j,k,l,n,m

1690
      REAL(KIND=dp) :: s,t

1691
      INTEGER, POINTER :: p(:),q(:), r(:)

1692
      REAL(KIND=dp), POINTER :: Coeff(:)

1693
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1694
!------------------------------------------------------------------------------

1695
      elt => element % TYPE

1696
      l = elt % BasisFunctionDegree

1697
      BasisFunctions => elt % BasisFunctions

1698


1699
      IF ( Elt % ElementCode == 605 ) THEN

1700
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1701
        s = 1.0d0 / (1-w)

1702


1703
        y = 0.0d0

1704
        DO n=1,5

1705
          IF(x(n)==0) CYCLE

1706
          SELECT CASE(n)

1707
          CASE(1)

1708
            y = y + x(1) * ( -1 + u*v*s**2 ) / 4

1709
          CASE(2)

1710
            y = y + x(2) * ( -1 - u*v*s**2 ) / 4

1711
          CASE(3)

1712
            y = y + x(3) * ( -1 + u*v*s**2 ) / 4

1713
          CASE(4)

1714
            y = y + x(4) * ( -1 - u*v*s**2 ) / 4

1715
          CASE(5)

1716
            y = y + x(5)

1717
          END SELECT

1718
        END DO

1719
        RETURN

1720
      ELSE IF ( Elt % ElementCode == 613 ) THEN

1721
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1722
        s = 1.0d0 / (1-w)

1723


1724
        y = 0.0d0

1725
        DO n=1,13

1726
          IF(x(n)==0) CYCLE

1727
          SELECT CASE(n)

1728
          CASE(1)

1729
            y = y + x(1)  * (-u-v-1) * ( -1 + u*v*s**2 ) / 4

1730
          CASE(2)

1731
            y = y + x(2)  * ( u-v-1) * ( -1 - u*v*s**2 ) / 4

1732
          CASE(3)

1733
            y = y + x(3)  * ( u+v-1) * ( -1 + u*v*s**2 ) / 4

1734
          CASE(4)

1735
            y = y + x(4)  * (-u+v-1) * ( -1 - u*v*s**2 ) / 4

1736
          CASE(5)

1737
            y = y + x(5)  * (4*w-1)

1738
          CASE(6)

1739
            y = y + x(6)  * ( ( -(1-u-w)*(1-v-w) - (1+u-w)*(1-v-w) - (1+u-w)*(1-u-w) ) * s + &

1740
                ( 1+u-w)*(1-u-w)*(1-v-w) * s**2 ) / 2

1741
          CASE(7)

1742
            y = y + x(7)  * ( ( -(1-v-w)*(1+u-w) - (1+v-w)*(1+u-w) - (1+v-w)*(1-v-w) ) * s + &

1743
                ( 1+v-w)*(1-v-w)*(1+u-w) * s**2 ) / 2

1744
          CASE(8)

1745
            y = y + x(8)  * ( ( -(1-u-w)*(1+v-w) - (1+u-w)*(1+v-w) - (1+u-w)*(1-u-w) ) * s + &

1746
                ( 1+u-w)*(1-u-w)*(1+v-w) * s**2 ) / 2

1747
          CASE(9)

1748
            y = y + x(9)  * ( ( -(1-v-w)*(1-u-w) - (1+v-w)*(1-u-w) - (1+v-w)*(1-v-w) ) * s + &

1749
                ( 1+v-w)*(1-v-w)*(1-u-w) * s**2 ) / 2

1750
          CASE(10)

1751
            y = y + x(10) * ( ( (1-u-w) * (1-v-w) - w * (1-v-w) - w * (1-u-w) ) * s  + &

1752
                w * (1-u-w) * (1-v-w) * s**2 )

1753
          CASE(11)

1754
            y = y + x(11) * ( ( (1+u-w) * (1-v-w) - w * (1-v-w) - w * (1+u-w) ) * s  + &

1755
                w * (1+u-w) * (1-v-w) * s**2 )

1756
          CASE(12)

1757
            y = y + x(12) * ( ( (1+u-w) * (1+v-w) - w * (1+v-w) - w * (1+u-w) ) * s  + &

1758
                w * (1+u-w) * (1+v-w) * s**2 )

1759
          CASE(13)

1760
            y = y + x(13) * ( ( (1-u-w) * (1+v-w) - w * (1+v-w) - w * (1-u-w) ) * s  + &

1761
                w * (1-u-w) * (1+v-w) * s**2 )

1762
          END SELECT

1763
        END DO

1764
        RETURN

1765
      END IF

1766


1767
      y = 0.0d0

1768
      DO n = 1,elt % NumberOfNodes

1769
        IF ( x(n) /= 0.0d0 ) THEN

1770
          p => BasisFunctions(n) % p

1771
          q => BasisFunctions(n) % q

1772
          r => BasisFunctions(n) % r

1773
          Coeff => BasisFunctions(n) % Coeff

1774


1775
          s = 0.0d0

1776
          DO i = 1,BasisFunctions(n) % n

1777
             IF ( r(i) >= 1  ) THEN

1778
                s = s + r(i) * Coeff(i) * u**p(i) * v**q(i) * w**(r(i)-1)

1779
             END IF

1780
          END DO

1781
          y = y + s*x(n)

1782
        END IF

1783
      END DO

1784
!------------------------------------------------------------------------------

1785
   END FUNCTION FirstDerivativeInW3D

1786
!------------------------------------------------------------------------------

1787


1788


1789
!------------------------------------------------------------------------------

1790
! Return first partial derivative in u of a quantity x at point (u,v,w)

1791
!------------------------------------------------------------------------------

1792
   SUBROUTINE NodalFirstDerivatives3D( y,element,u,v,w )

1793
!------------------------------------------------------------------------------

1794
     TYPE(Element_t) :: element        !< element structure

1795
     REAL(KIND=dp) :: u,v,w            !< Point at which to evaluate the partial derivative

1796
     REAL(KIND=dp) :: y(:,:)           !< value of the quantity y =  @x(u,v,w)/@u

1797
!------------------------------------------------------------------------------

1798
!    Local variables

1799
!------------------------------------------------------------------------------

1800
      REAL(KIND=dp) :: s,t,z

1801
      TYPE(ElementType_t),POINTER :: elt

1802
      REAL(KIND=dp), POINTER :: Coeff(:)

1803
      INTEGER, POINTER :: p(:),q(:),r(:)

1804
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1805
      INTEGER :: i,n

1806
      REAL(KIND=dp) :: ult(0:6), vlt(0:6), wlt(0:6)

1807
 

1808
      elt => element % TYPE

1809
      BasisFunctions => elt % BasisFunctions

1810
 

1811
      ult(0) = 1

1812
      ult(1) = u

1813


1814
      vlt(0) = 1

1815
      vlt(1) = v

1816
 

1817
      wlt(0) = 1

1818
      wlt(1) = w

1819


1820
      DO i=2,elt % BasisFunctionDegree

1821
        ult(i) = u**i

1822
        vlt(i) = v**i

1823
        wlt(i) = w**i

1824
      END DO

1825


1826
      DO n = 1,elt % NumberOfNodes

1827
        p => BasisFunctions(n) % p

1828
        q => BasisFunctions(n) % q

1829
        r => BasisFunctions(n) % r

1830
        Coeff => BasisFunctions(n) % Coeff

1831


1832
        s = 0.0d0

1833
        t = 0.0d0

1834
        z = 0.0d0

1835
        DO i = 1,BasisFunctions(n) % n

1836
          IF (p(i)>=1) s = s + p(i)*Coeff(i)*ult(p(i)-1)*vlt(q(i))*wlt(r(i))

1837
          IF (q(i)>=1) t = t + q(i)*Coeff(i)*ult(p(i))*vlt(q(i)-1)*wlt(r(i))

1838
          IF (r(i)>=1) z = z + r(i)*Coeff(i)*ult(p(i))*vlt(q(i))*wlt(r(i)-1)

1839
        END DO

1840
        y(n,1) = s

1841
        y(n,2) = t

1842
        y(n,3) = z

1843
      END DO

1844
   END SUBROUTINE NodalFirstDerivatives3D

1845
!------------------------------------------------------------------------------

1846


1847


1848


1849
!------------------------------------------------------------------------------

1850
!>   Given the element structure return the second partial derivatives of 

1851
!>   a quantity x given at element nodes with respect to local coordinates

1852
!>   at a point with local coordinates (u,v,w) inside the element. Element basis

1853
!>   functions are used to compute the value. 

1854
!------------------------------------------------------------------------------

1855
   FUNCTION SecondDerivatives3D( element,x,u,v,w ) RESULT(ddx)

1856
!------------------------------------------------------------------------------

1857
!

1858
!  ARGUMENTS:

1859
!   Type(Element_t) :: element

1860
!     INPUT: element structure

1861
!     

1862
!    REAL(KIND=dp) :: x(:)

1863
!     INPUT: Nodal values of the quantity whose partial derivatives we want to know

1864
!

1865
!    REAL(KIND=dp) :: u,v,w

1866
!     INPUT: Point at which to evaluate the partial derivative

1867
!

1868
!  FUNCTION VALUE:

1869
!     REAL(KIND=dp) :: s

1870
!      value of the quantity s = @^2x(u,v)/@v^2

1871
!    

1872
!------------------------------------------------------------------------------

1873
   !

1874
   !  Return matrix of second partial derivatives.

1875
   !

1876
!------------------------------------------------------------------------------

1877


1878
      TYPE(Element_t) :: element

1879


1880
      REAL(KIND=dp), DIMENSION(:) :: x

1881
      REAL(KIND=dp) :: u,v,w

1882


1883
!------------------------------------------------------------------------------

1884
!    Local variables

1885
!------------------------------------------------------------------------------

1886
      TYPE(ElementType_t),POINTER :: elt

1887
      REAL(KIND=dp), DIMENSION (3,3) :: ddx

1888
      TYPE(BasisFunctions_t), POINTER :: BasisFunctions(:)

1889


1890
      REAL(KIND=dp), POINTER :: Coeff(:)

1891
      INTEGER, POINTER :: p(:), q(:), r(:)

1892


1893
      REAL(KIND=dp) :: s,t

1894
      INTEGER :: i,j,k,l,n,m

1895


1896
!------------------------------------------------------------------------------

1897
      elt => element % TYPE

1898
      k = elt % NumberOfNodes

1899
      BasisFunctions => elt % BasisFunctions

1900


1901
      ddx = 0.0d0

1902
      IF ( Elt % ElementCode == 605 ) THEN

1903
        s = 0.0d0

1904
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1905
        s = 1.0d0 / (1-w)

1906


1907
        ddx(1,2) = (x(1)-x(2)+x(3)-x(4))*(1+w*s)

1908
        ddx(2,1) = ddx(1,2)

1909


1910
        ddx(1,3) = (x(1)-x(2)+x(3)-x(4))*v*s**2

1911
        ddx(3,1) = ddx(1,3)

1912


1913
        ddx(2,3) = (x(1)-x(2)+x(3)-x(4))*u*s**2

1914
        ddx(3,2) = ddx(2,3)

1915
        ddx = ddx/4

1916


1917
        RETURN

1918
      ELSE IF ( Elt % ElementCode == 613 ) THEN

1919
        s = 0.0d0

1920
        IF ( w == 1 ) w = 1.0d0-1.0d-12

1921
        s = 1.0d0 / (1-w)

1922


1923
        DO n=1,13

1924
          IF(x(n)==0) CYCLE

1925


1926
          t = 0

1927
          SELECT CASE(n)

1928
          CASE(1)

1929
            t = t - x(1)  * (-(1-v) + v*w*s)/2

1930
          CASE(2)

1931
            t = t + x(2)  * ( (1-v) - v*w*s)/2

1932
          CASE(3)

1933
            t = t + x(3)  * ( (1+v) + v*w*s)/2

1934
          CASE(4)

1935
            t = t - x(4)  * (-(1+v) - v*w*s)/2

1936
          CASE(6)

1937
            t = t - x(6)  *  (1-v-w) * s

1938
          CASE(8)

1939
            t = t - x(8)  *  (1+v-w) * s

1940
          END SELECT

1941
          ddx(1,1) = ddx(1,1) + t

1942


1943
          t = 0

1944
          SELECT CASE(n)

1945
          CASE(1)

1946
            t = t + x(1)  *  ((1-u) - u*w*s)/4

1947
            t = t + x(1)  *  ((1-v) - v*w*s)/4

1948
            t = t + x(1)  *  (-u-v-1)*(1+w*s)/4

1949
          CASE(2)

1950
            t = t + x(2)  *  (-(1+u) - u*w*s)/4

1951
            t = t + x(2)  *  ( -(1-v) + v*w*s)/4

1952
            t = t + x(2)  *  ( u-v-1)*(-1-w*s)/4

1953
          CASE(3)

1954
            t = t + x(3)  *  ( (1+u) + u*w*s)/4

1955
            t = t + x(3)  *  ( (1+v) + v*w*s)/4

1956
            t = t + x(3)  *  ( u+v-1)*(1+w*s)/4

1957
          CASE(4)

1958
            t = t + x(4)  *  ( -(1-u) + u*w*s)/4

1959
            t = t + x(4)  *  (-(1+v) - v*w*s)/4

1960
            t = t + x(4)  *  (-u+v-1)*(-1-w*s)/4

1961
          CASE(5)

1962
            CONTINUE

1963
          CASE(6)

1964
            t = t - x(6)  * (1-u-w)*s/2

1965
            t = t + x(6)  * (1+u-w)*s/2

1966
          CASE(7)

1967
            t = t + x(7)  * (1-v-w)*s/2

1968
            t = t - x(7)  * (1+v-w)*s/2

1969
          CASE(8)

1970
            t = t + x(8)  * (1-u-w)*s/2

1971
            t = t - x(8)  * (1+u-w)*s/2

1972
          CASE(9)

1973
            t = t - x(9)  * (1-v-w)*s/2

1974
            t = t + x(9)  * (1+v-w)*s/2

1975
          CASE(10)

1976
            t = t + x(10) *  w*s

1977
          CASE(11)

1978
            t = t - x(11) *  w*s

1979
          CASE(12)

1980
            t = t + x(12) *  w*s

1981
          CASE(13)

1982
            t = t - x(13) *  w*s

1983
          END SELECT

1984
          ddx(1,2) = ddx(1,2) + t

1985


1986
          t = 0

1987
          SELECT CASE(n) 

1988
          CASE(1)

1989
            t = t - x(1)  * (-1 + u*v*s**2) / 4

1990
            t = t + x(1)  * (-u-v-1) * (v*s**2) / 4

1991
          CASE(2)

1992
            t = t + x(2)  * (-1 - u*v*s**2) / 4

1993
            t = t + x(2)  * ( u-v-1) * (-v*s**2) / 4

1994
          CASE(3)

1995
            t = t + x(3)  * (-1 + u*v*s**2) / 4

1996
            t = t + x(3)  * ( u+v-1) * (v*s**2) / 4

1997
          CASE(4)

1998
            t = t - x(4)  * (-1 - u*v*s**2) / 4

1999
            t = t + x(4)  * (-u+v-1) * (-v*s**2) / 4

2000
          CASE(5)

2001
            CONTINUE

2002
          CASE(6)

2003
            t = t - x(6)  * (1-v-w) * s / 2

2004
            t = t - x(6)  * (1-u-w) * s / 2

2005
            t = t + x(6)  * (1-u-w)*(1-v-w) * s**2 / 2

2006
            t = t + x(6)  * (1-v-w) * s / 2

2007
            t = t + x(6)  * (1+u-w) * s / 2

2008
            t = t - x(6)  * (1+u-w)*(1-v-w) * s**2 / 2

2009
          CASE(7)

2010
            t = t - x(7)  * (1-v-w) * s / 2

2011
            t = t - x(7)  * (1+v-w) * s / 2

2012
            t = t + x(7)  * (1+v-w)*(1-v-w) * s**2 / 2

2013
          CASE(8)

2014
            t = t - x(8)  * (1+v-w) * s / 2

2015
            t = t - x(8)  * (1-u-w) * s / 2

2016
            t = t + x(8)  * (1-u-w)*(1+v-w) * s**2 / 2

2017
            t = t + x(8)  * (1+v-w) * s / 2

2018
            t = t + x(8)  * (1+u-w) * s / 2

2019
            t = t - x(8)  * (1+u-w)*(1+v-w) * s**2 / 2

2020
          CASE(9)

2021
            t = t + x(9)  * (1-v-w) * s / 2

2022
            t = t + x(9)  * (1+v-w) * s / 2

2023
            t = t - x(9)  * (1+v-w)*(1-v-w) * s**2 / 2

2024
          CASE(10)

2025
            t = t + x(10) * w * s

2026
            t = t - x(10) * (1-v-w) * s**2

2027
          CASE(11)

2028
            t = t - x(11) * w * s

2029
            t = t + x(11) * (1-v-w) * s**2

2030
          CASE(12)

2031
            t = t - x(12) * w * s

2032
            t = t + x(12) * (1+v-w) * s**2

2033
          CASE(13)

2034
            t = t + x(13) * w * s

2035
            t = t - x(13) * (1+v-w) * s**2

2036
          END SELECT

2037
          ddx(1,3) = ddx(1,3) + t

2038


2039
          t = 0

2040
          SELECT CASE(n)

2041
          CASE(1)

2042
            t = t - x(1)  * (-(1-u) + u*w*s)/2

2043
          CASE(2)

2044
            t = t - x(2)  * (-(1+u) - u*w*s)/2

2045
          CASE(3)

2046
            t = t + x(3)  * ( (1+u) + u*w*s)/2

2047
          CASE(4)

2048
            t = t + x(4)  * ( (1-u) - u*w*s)/2

2049
          CASE(7)

2050
            t = t - x(7)  * (1+u-w)*s

2051
          CASE(9)

2052
            t = t - x(9)  * (1-u-w)*s

2053
          CASE(6,8,10,11,12,13)

2054
          END SELECT

2055
          ddx(2,2) = ddx(2,2) + t

2056


2057
          t = 0

2058
          SELECT CASE(n)

2059
          CASE(1)

2060
            t = t - x(1)  * (-1 + u*v*s**2) / 4

2061
            t = t + x(1)  * (-u-v-1) * (u*s**2) / 4

2062
          CASE(2)

2063
            t = t - x(2)  * (-1 - u*v*s**2) / 4

2064
            t = t + x(2)  * ( u-v-1) * (-u*s**2) / 4

2065
          CASE(3)

2066
            t = t + x(3)  * (-1 + u*v*s**2) / 4

2067
            t = t + x(3)  * ( u+v-1) * (u*s**2) / 4

2068
          CASE(4)

2069
            t = t + x(4)  * (-1 - u*v*s**2) / 4

2070
            t = t + x(4)  * (-u+v-1) * (-u*s**2) / 4

2071
          CASE(5)

2072
            CONTINUE

2073
          CASE(6)

2074
            t = t + x(6)  * (1-u-w) * s / 2

2075
            t = t + x(6)  * (1+u-w) * s / 2

2076
            t = t - x(6)  * (1+u-w)*(1-u-w) * s**2 / 2

2077
          CASE(7)

2078
            t = t - x(7)  * (1+u-w) * s / 2

2079
            t = t - x(7)  * (1-v-w) * s / 2

2080
            t = t + x(7)  * (1-v-w)*(1+u-w) * s**2 / 2

2081
            t = t + x(7)  * (1+u-w) * s / 2

2082
            t = t + x(7)  * (1+v-w) * s / 2

2083
            t = t - x(7)  * (1+v-w)*(1+u-w) * s**2 / 2

2084
          CASE(8)

2085
            t = t - x(8)  * (1-u-w) * s / 2

2086
            t = t - x(8)  * (1+u-w) * s / 2

2087
            t = t + x(8)  * (1+u-w)*(1-u-w) * s**2 / 2

2088
          CASE(9)

2089
            t = t - x(9)  * (1-u-w) * s / 2

2090
            t = t - x(9)  * (1-v-w) * s / 2

2091
            t = t + x(9)  * (1-v-w)*(1-u-w) * s**2 / 2

2092
            t = t + x(9)  * (1-u-w) * s / 2

2093
            t = t + x(9)  * (1+v-w) * s / 2

2094
            t = t - x(9)  * (1+v-w)*(1-u-w) * s**2 / 2

2095
          CASE(10)

2096
            t = t + x(10) * w * s

2097
            t = t - x(10) * (1-u-w) * s**2

2098
          CASE(11)

2099
            t = t + x(11) * w * s

2100
            t = t - x(11) * (1+u-w) * s**2

2101
          CASE(12)

2102
            t = t - x(12) * w * s

2103
            t = t + x(12) * (1+u-w) * s**2

2104
          CASE(13)

2105
            t = t - x(13) * w * s

2106
            t = t + x(13) * (1-u-w) * s**2

2107
          END SELECT

2108
          ddx(2,3) = ddx(2,3) + t

2109


2110
          t = 0

2111
          SELECT CASE(n)

2112
          CASE(1)

2113
            t = t + x(1)  * (-u-v-1) * ( u*v*2*s**3) / 4

2114
          CASE(2)

2115
            t = t + x(2)  * ( u-v-1) * (-u*v*2*s**3) / 4

2116
          CASE(3)

2117
            t = t + x(3)  * ( u+v-1) * ( u*v*2*s**3) / 4

2118
          CASE(4)

2119
            t = t + x(4)  * (-u+v-1) * (-u*v*2*s**3) / 4

2120
          CASE(5)

2121
            t = t + x(5) * 4

2122
          CASE(6)

2123
            t = t + x(6)  * (1-v-w) * s / 2

2124
            t = t + x(6)  * (1-u-w) * s / 2

2125
            t = t - x(6)  * (1-u-w)*(1-v-w) * s**2 / 2

2126
            t = t + x(6)  * (1-v-w) * s / 2

2127
            t = t + x(6)  * (1+u-w) * s / 2

2128
            t = t - x(6)  * (1+u-w)*(1-v-w) * s**2 / 2

2129
            t = t + x(6)  * (1-u-w) * s / 2

2130
            t = t + x(6)  * (1+u-w) * s / 2

2131
            t = t - x(6)  * (1+u-w)*(1-u-w) * s**2 / 2

2132
            t = t - x(6)  * (1-u-w)*(1-v-w) * s**2 / 2

2133
            t = t - x(6)  * (1+u-w)*(1-v-w) * s**2 / 2

2134
            t = t - x(6)  * (1+u-w)*(1-u-w) * s**2 / 2

2135
            t = t + x(6)  * (1+u-w)*(1-u-w)*(1-v-w) * 2*s**3 / 2

2136
          CASE(7)

2137
            t = t + x(7)  * (1+u-w) * s / 2

2138
            t = t + x(7)  * (1-v-w) * s / 2

2139
            t = t - x(7)  * (1-v-w)*(1+u-w) * s**2 / 2

2140
            t = t + x(7)  * (1+u-w) * s / 2

2141
            t = t + x(7)  * (1+v-w) * s / 2

2142
            t = t - x(7)  * (1+v-w)*(1+u-w) * s**2 / 2

2143
            t = t + x(7)  * (1-v-w) * s / 2

2144
            t = t + x(7)  * (1+v-w) * s / 2

2145
            t = t - x(7)  * (1+v-w)*(1-v-w) * s**2 / 2

2146
            t = t - x(7)  * (1-v-w)*(1+u-w) * s**2 / 2

2147
            t = t - x(7)  * (1+v-w)*(1+u-w) * s**2 / 2

2148
            t = t - x(7)  * (1+v-w)*(1-v-w) * s**2 / 2

2149
            t = t + x(7)  * (1+v-w)*(1-v-w)*(1+u-w) * 2*s**3 / 2

2150
          CASE(8)

2151
            t = t + x(8)  * (1+v-w) * s / 2

2152
            t = t + x(8)  * (1-u-w) * s / 2

2153
            t = t - x(8)  * (1-u-w)*(1+v-w) * s**2 / 2

2154
            t = t + x(8)  * (1+v-w) * s / 2

2155
            t = t + x(8)  * (1+u-w) * s / 2

2156
            t = t - x(8)  * (1+u-w)*(1+v-w) * s**2 / 2

2157
            t = t + x(8)  * (1-u-w) * s / 2

2158
            t = t + x(8)  * (1+u-w) * s / 2

2159
            t = t - x(8)  * (1+u-w)*(1-u-w) * s**2 / 2

2160
            t = t - x(8)  * (1-u-w)*(1+v-w) * s**2 / 2

2161
            t = t - x(8)  * (1+u-w)*(1+v-w) * s**2 / 2

2162
            t = t - x(8)  * (1+u-w)*(1-u-w) * s**2 / 2

2163
            t = t + x(8)  * (1+u-w)*(1-u-w)*(1+v-w) * 2*s**3 / 2

2164
          CASE(9)

2165
            t = t + x(9)  * (1-u-w) * s / 2

2166
            t = t + x(9)  * (1-v-w) * s / 2

2167
            t = t - x(9)  * (1-v-w)*(1-u-w) * s**2 / 2

2168
            t = t + x(9)  * (1-u-w) * s / 2

2169
            t = t + x(9)  * (1+v-w) * s / 2

2170
            t = t - x(9)  * (1+v-w)*(1-u-w) * s**2 / 2

2171
            t = t + x(9)  * (1-v-w) * s / 2

2172
            t = t + x(9)  * (1+v-w) * s / 2

2173
            t = t - x(9)  * (1+v-w)*(1-v-w) * s**2 / 2

2174
            t = t - x(9)  * (1-v-w)*(1-u-w) * s**2 / 2

2175
            t = t - x(9)  * (1+v-w)*(1-u-w) * s**2 / 2

2176
            t = t - x(9)  * (1+v-w)*(1-v-w) * s**2 / 2

2177
            t = t + x(9)  * (1+v-w)*(1-v-w)*(1-u-w) * 2*s**3 / 2

2178
          CASE(10)

2179
            t = t + x(10) * w * s

2180
            t = t - x(10) * (1-v-w) * s**2

2181
            t = t + x(10) * w * s

2182
            t = t - x(10) * (1-u-w) * s**2

2183
            t = t - x(10) * (1-v-w) * s**2

2184
            t = t - x(10) * (1-u-w) * s**2

2185
            t = t + x(10) * (1-u-w) * (1-v-w) * 2*s**3

2186
          CASE(11)

2187
            t = t + x(11) * w * s

2188
            t = t - x(11) * (1-v-w) * s**2

2189
            t = t + x(11) * w * s

2190
            t = t - x(11) * (1+u-w) * s**2

2191
            t = t - x(11) * (1-v-w) * s**2

2192
            t = t - x(11) * (1+u-w) * s**2

2193
            t = t + x(11) * (1+u-w) * (1-v-w) * 2*s**3

2194
          CASE(12)

2195
            t = t + x(12) * w * s

2196
            t = t - x(12) * (1+v-w) * s**2

2197
            t = t + x(12) * w * s

2198
            t = t - x(12) * (1+u-w) * s**2

2199
            t = t - x(12) * (1+v-w) * s**2

2200
            t = t - x(12) * (1+u-w) * s**2

2201
            t = t + x(12) * (1+u-w) * (1+v-w) * 2*s**3

2202
          CASE(13)

2203
            t = t + x(13) * w*s

2204
            t = t - x(13) * (1+v-w) * s**2

2205
            t = t + x(13) * w*s

2206
            t = t - x(13) * (1-u-w) * s**2

2207
            t = t - x(13) * (1+v-w) * s**2

2208
            t = t - x(13) * (1-u-w) * s**2

2209
            t = t + x(13) * (1-u-w) * (1+v-w) * 2*s**3

2210
          END SELECT

2211
          ddx(3,3) = ddx(3,3) + t

2212
        END DO

2213
        ddx(2,1) = ddx(1,2)

2214
        ddx(3,1) = ddx(1,3)

2215
        ddx(3,2) = ddx(2,3)

2216
        RETURN

2217


2218
      END IF

2219


2220
      DO n = 1,k

2221
        IF ( x(n) /= 0.0d0 ) THEN

2222
          p => elt % BasisFunctions(n) % p

2223
          q => elt % BasisFunctions(n) % q

2224
          r => elt % BasisFunctions(n) % r

2225
          Coeff => elt % BasisFunctions(n) % Coeff

2226
!------------------------------------------------------------------------------

2227
!         @^2x/@u^2

2228
!------------------------------------------------------------------------------

2229
          s = 0.0d0

2230
          DO i = 1,BasisFunctions(n) % n

2231
             IF ( p(i) >= 2 ) THEN

2232
                s = s + p(i) * (p(i)-1) * Coeff(i) * u**(p(i)-2) * v**q(i) * w**r(i)

2233
             END IF

2234
          END DO

2235
          ddx(1,1) = ddx(1,1) + s*x(n)

2236


2237
!------------------------------------------------------------------------------

2238
!         @^2x/@u@v

2239
!------------------------------------------------------------------------------

2240
          s = 0.0d0

2241
          DO i = 1,BasisFunctions(n) % n

2242
              IF (  p(i) >= 1 .AND. q(i) >= 1 ) THEN

2243
                 s = s + p(i) * q(i) * Coeff(i) * u**(p(i)-1) * v**(q(i)-1) * w**r(i)

2244
              END IF

2245
          END DO

2246
          ddx(1,2) = ddx(1,2) + s*x(n)

2247


2248
!------------------------------------------------------------------------------

2249
!         @^2x/@u@w

2250
!------------------------------------------------------------------------------

2251
          s = 0.0d0

2252
          DO i = 2,k

2253
              IF (  p(i) >= 1 .AND. r(i) >= 1 ) THEN

2254
                 s = s + p(i) * r(i) * Coeff(i) * u**(p(i)-1) * v**q(i) * w**(r(i)-1)

2255
              END IF

2256
          END DO

2257
          ddx(1,3) = ddx(1,3) + s*x(n)

2258


2259
!------------------------------------------------------------------------------

2260
!         @^2x/@v^2

2261
!------------------------------------------------------------------------------

2262
          s = 0.0d0

2263
          DO i = 1,BasisFunctions(n) % n

2264
             IF ( q(i) >= 2 ) THEN

2265
                s = s + q(i) * (q(i)-1) * Coeff(i) * u**p(i) * v**(q(i)-2) * w**r(i)

2266
             END IF

2267
          END DO

2268
          ddx(2,2) = ddx(2,2) + s*x(n)

2269


2270
!------------------------------------------------------------------------------

2271
!         @^2x/@v@w

2272
!------------------------------------------------------------------------------

2273
          s = 0.0d0

2274
          DO i = 1,BasisFunctions(n) % n

2275
              IF (  q(i) >= 1 .AND. r(i) >= 1 ) THEN

2276
                 s = s + q(i) * r(i) * Coeff(i) * u**p(i) * v**(q(i)-1) * w**(r(i)-1)

2277
              END IF

2278
          END DO

2279
          ddx(2,3) = ddx(2,3) + s*x(n)

2280


2281
!------------------------------------------------------------------------------

2282
!         @^2x/@w^2

2283
!------------------------------------------------------------------------------

2284
          s = 0.0d0

2285
          DO i = 1,BasisFunctions(n) % n

2286
             IF ( r(i) >= 2 ) THEN

2287
                s = s + r(i) * (r(i)-1) * Coeff(i) * u**p(i) * v**q(i) * w**(r(i)-2)

2288
             END IF

2289
          END DO

2290
          ddx(3,3) = ddx(3,3) + s*x(n)

2291


2292
        END IF

2293
      END DO

2294


2295
      ddx(2,1) = ddx(1,2)

2296
      ddx(3,1) = ddx(1,3)

2297
      ddx(3,2) = ddx(2,3)

2298


2299
   END FUNCTION SecondDerivatives3D

2300
!------------------------------------------------------------------------------

2301


2302
! This is a test version where all nodes are obtained at once. 

2303
#define ALLNODES 1

2304
!------------------------------------------------------------------------------

2305
!>  Return the values of the reference element basis functions. In the case of

2306
!>  p-element, the values of the lowest-order basis functions corresponding 

2307
!>  to the background mesh are returned.

2308
!------------------------------------------------------------------------------

2309
   SUBROUTINE NodalBasisFunctions( n, Basis, element, u, v, w, USolver)

2310
!------------------------------------------------------------------------------

2311
     INTEGER :: n                 !< The number of (background) element nodes

2312
     REAL(KIND=dp) :: Basis(:)    !< The values of reference element basis

2313
     TYPE(Element_t) :: element   !< The element structure

2314
     REAL(KIND=dp) :: u,v,w       !< The coordinates of the reference element point

2315
     TYPE(Solver_t), POINTER, OPTIONAL :: USolver

2316
!------------------------------------------------------------------------------

2317
     INTEGER   :: i, q, dim, elemcode

2318
     REAL(KIND=dp) :: NodalBasis(n)

2319
     LOGICAL :: pElem

2320
     

2321
     dim = Element % TYPE % DIMENSION

2322
     elemcode = element % Type % ElementCode

2323
     pElem = isActivePElement( Element, USolver ) 

2324
     

2325
#if ALLNODES

2326
     ! Speedier nodal basis for p-elements and lowest order lagrange elements

2327
     ! except for the pyramid which is a different kind of beast. 

2328
     IF( elemcode/100 /= 6 .AND. ( pelem .OR. elemcode/100 >= MODULO(elemcode,100) ) ) THEN

2329
       SELECT CASE(elemcode/100)

2330
       CASE( 2 )

2331
         CALL LineNodalPBasisAll(u, Basis )

2332
       CASE( 3 ) 

2333
         IF( pElem ) THEN

2334
           CALL TriangleNodalPBasisAll(u, v, Basis)

2335
         ELSE

2336
           CALL TriangleNodalLBasisAll(u, v, Basis)

2337
         END IF

2338
       CASE( 4 ) 

2339
         CALL QuadNodalPBasisAll(u, v, Basis )

2340
       CASE( 5 )

2341
         IF( pElem ) THEN

2342
           CALL TetraNodalPBasisAll(u, v, w, Basis)

2343
         ELSE

2344
           CALL TetraNodalLBasisAll(u, v, w, Basis)

2345
         END IF

2346
       CASE( 7 ) 

2347
         IF( pElem ) THEN

2348
           CALL WedgeNodalPBasisAll(u, v, w, Basis) 

2349
         ELSE

2350
           CALL WedgeNodalLBasisAll(u, v, w, Basis) 

2351
         END IF

2352
       CASE( 8 ) 

2353
         CALL BrickNodalPBasisAll(u,v,w,Basis)

2354
       END SELECT

2355
       RETURN

2356
     END IF

2357
#endif    

2358
     

2359
     IF ( pElem ) THEN

2360
       SELECT CASE(elemcode / 100 )

2361
       CASE(2)

2362
         CALL NodalBasisFunctions1D( Basis, element, u )

2363
       CASE(3)

2364
         DO q=1,n

2365
           Basis(q) = TriangleNodalPBasis(q, u, v)

2366
         END DO

2367
       CASE(4) 

2368
         DO q=1,n

2369
           Basis(q) = QuadNodalPBasis(q, u, v)

2370
         END DO

2371
       CASE(5)

2372
         DO q=1,n

2373
           Basis(q) = TetraNodalPBasis(q, u, v, w)

2374
         END DO

2375
       CASE(6) 

2376
         DO q=1,n

2377
           Basis(q) = PyramidNodalPBasis(q, u, v, w)

2378
         END DO

2379
       CASE(7)

2380
         DO q=1,n

2381
           Basis(q) = WedgeNodalPBasis(q, u, v, w)

2382
         END DO

2383
       CASE(8) 

2384
         DO q=1,n

2385
           Basis(q) = BrickNodalPBasis(q, u, v, w)

2386
         END DO

2387
       END SELECT

2388
     ELSE

2389
       SELECT CASE( dim )

2390
       CASE(1)

2391
         CALL NodalBasisFunctions1D( Basis, element, u )

2392
       CASE(2)

2393
         CALL NodalBasisFunctions2D( Basis, element, u,v )

2394
       CASE(3)

2395
         IF ( elemcode/100==6 ) THEN

2396
           NodalBasis=0

2397
           DO q=1,n

2398
             NodalBasis(q)  = 1.0d0

2399
             Basis(q) = InterpolateInElement3D( element, NodalBasis, u,v,w )

2400
             NodalBasis(q)  = 0.0d0

2401
           END DO

2402
         ELSE

2403
           CALL NodalBasisFunctions3D( Basis, element, u,v,w )

2404
         END IF

2405
       END SELECT

2406
     END IF

2407
!------------------------------------------------------------------------------

2408
   END SUBROUTINE NodalBasisFunctions

2409
!------------------------------------------------------------------------------

2410


2411
!------------------------------------------------------------------------------

2412
!>  Return the gradient of the reference element basis functions, with the

2413
!>  gradient taken with respect to the reference element coordinates. In the case

2414
!>  of p-element, the gradients of the lowest-order basis functions corresponding 

2415
!>  to the background mesh are returned.

2416
!------------------------------------------------------------------------------

2417
   SUBROUTINE NodalFirstDerivatives( n, dLBasisdx, element, u, v, w, USolver )

2418
!------------------------------------------------------------------------------

2419
     INTEGER :: n                    !< The number of (background) element nodes

2420
     REAL(KIND=dp) :: dLBasisdx(:,:) !< The gradient of reference element basis functions

2421
     TYPE(Element_t) :: element      !< The element structure

2422
     REAL(KIND=dp) :: u,v,w          !< The coordinates of the reference element point

2423
     TYPE(Solver_t), POINTER, OPTIONAL :: USolver

2424
!------------------------------------------------------------------------------

2425
     INTEGER   :: i, q, dim, elemcode

2426
     REAL(KIND=dp) :: NodalBasis(n)

2427
     LOGICAL :: pElem

2428
!------------------------------------------------------------------------------

2429
     dim = Element % TYPE % DIMENSION

2430
     elemcode = element % TYPE % ElementCode

2431
     pElem = isActivePElement( Element, USolver ) 

2432
     

2433
#if ALLNODES

2434
     ! Speedier nodal basis for p-elements and lowest order lagrange elements

2435
     ! except for the pyramid which is a different kind of beast. 

2436
     IF( elemcode/100 /= 6 .AND. ( pelem .OR. elemcode/100 >= MODULO(elemcode,100) ) ) THEN

2437
       SELECT CASE(elemcode/100)

2438
       CASE( 2 )

2439
         CALL dLineNodalPBasisAll(u, dLBasisdx )

2440
       CASE( 3 ) 

2441
         IF( pElem ) THEN

2442
           CALL dTriangleNodalPBasisAll(u, v, dLBasisdx)

2443
         ELSE

2444
           CALL dTriangleNodalLBasisAll(u, v, dLBasisdx)

2445
         END IF

2446
       CASE( 4 ) 

2447
         CALL dQuadNodalPBasisAll(u, v, dLBasisdx )

2448
       CASE( 5 )

2449
         IF( pElem ) THEN

2450
           CALL dTetraNodalPBasisAll(u, v, w, dLBasisdx)

2451
         ELSE

2452
           CALL dTetraNodalLBasisAll(u, v, w, dLBasisdx)

2453
         END IF

2454
       CASE( 7 ) 

2455
         IF( pElem ) THEN

2456
           CALL dWedgeNodalPBasisAll(u, v, w, dLBasisdx) 

2457
         ELSE

2458
           CALL dWedgeNodalLBasisAll(u, v, w, dLBasisdx) 

2459
         END IF

2460
       CASE( 8 ) 

2461
         CALL dBrickNodalPBasisAll(u,v,w,dLBasisdx)

2462
       END SELECT

2463
       RETURN

2464
     END IF

2465
#endif         

2466
     

2467
     IF ( IsActivePElement(Element, USolver ) ) THEN

2468
       SELECT CASE(elemcode / 100 )

2469
       CASE(2)

2470
         CALL NodalFirstDerivatives1D( dLBasisdx, element, u )

2471
       CASE(3)

2472
         DO q=1,n

2473
           dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v)

2474
         END DO

2475
       CASE(4)

2476
         DO q=1,n

2477
           dLBasisdx(q,1:2) = dQuadNodalPBasis(q, u, v)

2478
         END DO

2479
       CASE(5)

2480
         DO q=1,n

2481
           dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w)

2482
         END DO

2483
       CASE( 6 )

2484
         DO q=1,n

2485
           dLBasisdx(q,1:3) = dPyramidNodalPBasis(q, u, v, w)

2486
         END DO

2487
       CASE( 7 ) 

2488
         DO q=1,n

2489
           dLBasisdx(q,1:3) = dWedgeNodalPBasis(q, u, v, w)

2490
         END DO

2491
       CASE( 8 ) 

2492
         DO q=1,n

2493
           dLBasisdx(q,1:3) = dBrickNodalPBasis(q, u, v, w)

2494
         END DO

2495
       END SELECT

2496
     ELSE

2497
       SELECT CASE(dim)

2498
       CASE(1)

2499
         CALL NodalFirstDerivatives1D( dLBasisdx, element, u )

2500
       CASE(2)

2501
         CALL NodalFirstDerivatives2D( dLBasisdx, element, u,v )

2502
       CASE(3)

2503
         IF ( elemcode / 100 == 6 ) THEN

2504
           NodalBasis=0

2505
           DO q=1,n

2506
             NodalBasis(q)  = 1.0d0

2507
             dLBasisdx(q,1) = FirstDerivativeInU3D(element,NodalBasis,u,v,w)

2508
             dLBasisdx(q,2) = FirstDerivativeInV3D(element,NodalBasis,u,v,w)

2509
             dLBasisdx(q,3) = FirstDerivativeInW3D(element,NodalBasis,u,v,w)

2510
             NodalBasis(q)  = 0.0d0

2511
           END DO

2512
         ELSE

2513
           CALL NodalFirstDerivatives3D( dLBasisdx, element, u,v,w )

2514
         END IF

2515
       END SELECT

2516
     END IF

2517
!------------------------------------------------------------------------------

2518
   END SUBROUTINE NodalFirstDerivatives

2519
!------------------------------------------------------------------------------

2520


2521


2522
!------------------------------------------------------------------------------

2523
!>  Return basis function degrees

2524
!------------------------------------------------------------------------------

2525
   SUBROUTINE ElementBasisDegree( Element, BasisDegree, USolver )

2526
!------------------------------------------------------------------------------

2527
     IMPLICIT NONE

2528


2529
     TYPE(Element_t), TARGET :: Element   !< Element structure

2530
     INTEGER :: BasisDegree(:)            !< Degree of each basis function in Basis(:) vector. 

2531
     TYPE(Solver_t), TARGET, OPTIONAL :: USolver

2532
!------------------------------------------------------------------------------

2533
!    Local variables

2534
!------------------------------------------------------------------------------

2535


2536
     REAL(KIND=dp) :: t,s

2537
     LOGICAL :: invert, degrees

2538
     INTEGER :: i, j, k, l, q, p, f, n, nb, dim, cdim, locali, localj,  &

2539
          tmp(4), direction(4), BDOFs, BodyId

2540


2541
     TYPE(Solver_t), POINTER :: pSolver

2542


2543
     LOGICAL :: SerendipityPBasis

2544


2545
     TYPE(Element_t) :: Bubble

2546
     TYPE(Element_t), POINTER :: Edge, Face, Parent

2547
!------------------------------------------------------------------------------

2548


2549
     IF( PRESENT( USolver ) ) THEN

2550
       pSolver => USolver

2551
     ELSE

2552
       pSolver => CurrentModel % Solver

2553
     END IF

2554


2555
     n    = Element % TYPE % NumberOfNodes

2556
     dim  = Element % TYPE % DIMENSION

2557
     cdim = CoordinateSystemDimension()

2558


2559


2560
     BasisDegree = 0

2561
     BasisDegree(1:n) = Element % Type % BasisFunctionDegree

2562


2563
     IF ( isActivePElement(element) ) THEN

2564


2565
       BodyId = Element % BodyId

2566
       IF (BodyId==0 .AND. ASSOCIATED(Element % BoundaryInfo)) THEN

2567
         Parent => Element % PDefs % LocalParent         

2568
         IF(ASSOCIATED(Parent)) BodyId = Parent % BodyId

2569
         IF( BodyId == 0 ) THEN

2570
           Parent => Element % BoundaryInfo % Left

2571
           IF( ASSOCIATED(Parent)) BodyId = Parent % BodyId

2572
         END IF

2573
         IF(BodyId == 0) THEN

2574
           Parent => Element % BoundaryInfo % Right

2575
           IF( ASSOCIATED(Parent)) BodyId = Parent % BodyId

2576
         END IF

2577
       END IF

2578
       IF (BodyId==0) THEN

2579
         CALL Warn('ElementBasisDegree', 'Element '//I2S(Element % ElementIndex)//' of type '//&

2580
             I2S(Element % TYPE % ElementCode)//' has 0 BodyId, assuming index 1')

2581
         BodyId = 1

2582
       END IF

2583


2584
       ! Check for need of P basis degrees and set degree of

2585
       ! linear basis if vector asked:

2586
       ! ---------------------------------------------------

2587
       BasisDegree(1:n) = 1

2588
       q = n

2589


2590
       SerendipityPBasis = Element % PDefs % Serendipity

2591
!------------------------------------------------------------------------------

2592
     SELECT CASE( Element % TYPE % ElementCode ) 

2593
!------------------------------------------------------------------------------

2594


2595
     ! P element code for line element:

2596
     ! --------------------------------

2597
     CASE(202)

2598
        ! Bubbles of line element

2599
        p = pSolver % Def_Dofs(2,BodyId,6)

2600
        nb = pSolver % Def_Dofs(2,BodyId,5)

2601
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

2602


2603
        IF (BDOFs > 0) THEN

2604
           p = getEffectiveBubbleP(element,p,bdofs)

2605
           ! For each bubble in line element get value of basis function

2606
           DO i=1, BDOFs

2607
             IF (q >= SIZE(BasisDegree)) CYCLE

2608
             q = q + 1

2609
             BasisDegree(q) = 1+i

2610
           END DO

2611
        END IF

2612


2613
!------------------------------------------------------------------------------

2614
! P element code for edges and bubbles of triangle

2615
     CASE(303)

2616
        ! Edges of triangle

2617
        IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN

2618
           ! For each edge calculate the value of edge basis function

2619
           DO i=1,3

2620
              Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) )

2621


2622
              ! For each dof in edge get value of p basis function 

2623
              DO k=1,Edge % BDOFs

2624
                 IF (q >= SIZE(BasisDegree)) CYCLE

2625
                 q = q + 1

2626
                 BasisDegree(q) = 1+k

2627
              END DO

2628
           END DO 

2629
        END IF

2630


2631
        ! Bubbles of p triangle      

2632


2633
        p = pSolver % Def_Dofs(3,BodyId,6)

2634
        nb = pSolver % Def_Dofs(3,BodyId,5)

2635
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

2636
        IF ( BDOFs > 0 ) THEN

2637
           ! Get element p

2638
           p = getEffectiveBubbleP(element,p,bdofs)

2639


2640
           DO i = 0,p-3

2641
              DO j = 0,p-i-3

2642
                 IF ( q >= SIZE(BasisDegree) ) CYCLE

2643
                 q = q + 1

2644
                 BasisDegree(q) = 3+i+j

2645
              END DO

2646
           END DO

2647
        END IF

2648
!------------------------------------------------------------------------------

2649
! P element code for quadrilateral edges and bubbles 

2650
     CASE(404)

2651
        ! Edges of p quadrilateral

2652
        IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN

2653
           ! For each edge begin node calculate values of edge functions 

2654
           DO i=1,4

2655
              Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) )

2656
              ! For each DOF in edge calculate value of p basis function

2657
              DO k=1,Edge % BDOFs

2658
                 IF ( q >= SIZE(BasisDegree) ) CYCLE

2659
                 q = q + 1

2660
                 BasisDegree(q) = 1+k

2661
              END DO              

2662
           END DO         

2663
        END IF

2664


2665
        ! Bubbles of p quadrilateral

2666
        p = pSolver % Def_Dofs(4,BodyId,6)

2667
        nb = pSolver % Def_Dofs(4,BodyId,5)

2668
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

2669
        IF ( BDOFs > 0 ) THEN

2670
          ! Get element P

2671
           p = getEffectiveBubbleP(element,p,bdofs)

2672
          

2673
           IF(SerendipityPBasis) THEN

2674
             DO i=2,(p-2)

2675
               DO j=2,(p-i)

2676
                  IF ( q >= SIZE(BasisDegree) ) CYCLE

2677
                  q = q + 1

2678
                  BasisDegree(q) = i+j

2679
               END DO

2680
             END DO

2681
           ELSE

2682
             DO i=0,p-2

2683
                DO j=0,p-2

2684
                   IF ( q >= SIZE(BasisDegree) ) CYCLE

2685
                   q = q + 1

2686
                   BasisDegree(q) = 2+i+j

2687
                END DO

2688
             END DO

2689
           END IF

2690
        END IF

2691
!------------------------------------------------------------------------------

2692
! P element code for tetrahedron edges, faces and bubbles

2693
     CASE(504) 

2694
        ! Edges of p tetrahedron

2695
        IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN   

2696
           ! For each edge calculate value of edge functions

2697
           DO i=1,6

2698
              Edge => CurrentModel % Solver % Mesh % Edges (Element % EdgeIndexes(i))

2699


2700
              ! Do not solve edge DOFS if there is not any

2701
              IF (Edge % BDOFs <= 0) CYCLE

2702


2703
              ! For each DOF in edge calculate value of edge functions 

2704
              ! and their derivatives for edge=i, i=k+1

2705
              DO k=1, Edge % BDOFs

2706
                 IF (q >= SIZE(BasisDegree)) CYCLE

2707
                 q = q + 1

2708
                 BasisDegree(q) = 1+k

2709
              END DO

2710
           END DO

2711
        END IF

2712


2713
        ! Faces of p tetrahedron

2714
        IF ( ASSOCIATED( Element % FaceIndexes )) THEN

2715
           ! For each face calculate value of face functions

2716
           DO F=1,4

2717
              Face => CurrentModel % Solver % Mesh % Faces (Element % FaceIndexes(F))

2718


2719
              ! Do not solve face DOFs if there is not any

2720
              IF (Face % BDOFs <= 0) CYCLE

2721


2722
              ! Get face p 

2723
              p = Face % PDefs % P

2724


2725
              ! For each DOF in face calculate value of face functions and 

2726
              ! their derivatives for face=F and index pairs 

2727
              ! i,j=0,..,p-3, i+j=0,..,p-3

2728
              DO i=0,p-3

2729
                 DO j=0,p-i-3

2730
                    IF (q >= SIZE(BasisDegree)) CYCLE

2731
                    q = q + 1 

2732
                    BasisDegree(q) = 3+i+j

2733
                 END DO

2734
              END DO

2735
           END DO

2736
        END IF

2737


2738
        ! Bubbles of p tetrahedron

2739
        p = pSolver % Def_Dofs(5,BodyId,6)

2740
        nb = pSolver % Def_Dofs(5,BodyId,5)

2741
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

2742
        IF ( BDOFs > 0 ) THEN

2743
           p = getEffectiveBubbleP(element,p,bdofs)

2744


2745
           DO i=0,p-4

2746
              DO j=0,p-i-4

2747
                 DO k=0,p-i-j-4

2748
                    IF (q >= SIZE(BasisDegree)) CYCLE

2749
                    q = q + 1

2750
                    BasisDegree(q) = 4+i+j+k

2751
                 END DO

2752
              END DO

2753
           END DO

2754
           

2755
        END IF

2756
!------------------------------------------------------------------------------

2757
! P element code for pyramid edges, faces and bubbles

2758
     CASE(605)

2759
        ! Edges of P Pyramid

2760
        IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN

2761
           ! For each edge in wedge, calculate values of edge functions

2762
           DO i=1,8

2763
              Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) )

2764


2765
              ! Do not solve edge dofs, if there is not any

2766
              IF (Edge % BDOFs <= 0) CYCLE

2767
              

2768
              ! For each DOF in edge calculate values of edge functions

2769
              ! and their derivatives for edge=i and i=k+1

2770
              DO k=1,Edge % BDOFs

2771
                 IF ( q >= SIZE(BasisDegree) ) CYCLE

2772
                 q = q + 1

2773
                 BasisDegree(q) = 1+k

2774
              END DO

2775
           END DO

2776
        END IF

2777
        

2778
        ! Faces of P Pyramid

2779
        IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

2780
           ! For each face in pyramid, calculate values of face functions

2781
           DO F=1,5

2782
              Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) )

2783


2784
              ! Do not solve face dofs, if there is not any

2785
              IF ( Face % BDOFs <= 0) CYCLE

2786
              

2787
              ! Get face p

2788
              p = Face % PDefs % P 

2789
              

2790
              ! Handle triangle and square faces separately

2791
              SELECT CASE(F)

2792
              CASE (1)

2793
                 ! For each face calculate values of functions from index

2794
                 ! pairs i,j=2,..,p-2 i+j=4,..,p

2795
!                DO i=2,p-2

2796
!                   DO j=2,p-i

2797
                 DO i=0,p-2

2798
                    DO j=0,p-2

2799
                       IF ( q >= SIZE(BasisDegree) ) CYCLE

2800
                       q = q + 1

2801
                       BasisDegree(q) = 2+i+j

2802
                    END DO

2803
                 END DO

2804


2805
              CASE (2,3,4,5)

2806
                 ! For each face calculate values of functions from index

2807
                 ! pairs i,j=0,..,p-3 i+j=0,..,p-3

2808
                 DO i=0,p-3

2809
                    DO j=0,p-i-3

2810
                       IF ( q >= SIZE(BasisDegree) ) CYCLE

2811
                       q = q + 1

2812
                       BasisDegree(q) = 3+i+j

2813
                    END DO

2814
                 END DO

2815
              END SELECT    

2816
           END DO

2817
        END IF

2818


2819
        ! Bubbles of P Pyramid

2820
        p = pSolver % Def_Dofs(6,BodyId,6)

2821
        nb = pSolver % Def_Dofs(6,BodyId,5)

2822
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

2823
        IF (BDOFs > 0) THEN 

2824
           ! Get element p

2825
           p = getEffectiveBubbleP(element,p,bdofs)

2826


2827
           ! Calculate value of bubble functions from indexes

2828
           ! i,j,k=0,..,p-3 i+j+k=0,..,p-3

2829
           DO i=0,p-3

2830
              DO j=0,p-i-3

2831
                 DO k=0,p-i-j-3

2832
                    IF ( q >= SIZE(BasisDegree)) CYCLE

2833
                    q = q + 1

2834
                    BasisDegree(q) = 3+i+j+k

2835
                 END DO

2836
              END DO

2837
           END DO

2838
        END IF

2839
        

2840
!------------------------------------------------------------------------------

2841
! P element code for wedge edges, faces and bubbles

2842
     CASE(706)

2843
        ! Edges of P Wedge

2844
        IF (ASSOCIATED( Element % EdgeIndexes ) ) THEN

2845
           ! For each edge in wedge, calculate values of edge functions

2846
           DO i=1,9

2847
              Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) )

2848


2849
              ! Do not solve edge dofs, if there is not any

2850
              IF (Edge % BDOFs <= 0) CYCLE

2851
              

2852
              ! For each DOF in edge calculate values of edge functions

2853
              ! and their derivatives for edge=i and i=k+1

2854
              DO k=1,Edge % BDOFs

2855
                 IF ( q >= SIZE(BasisDegree) ) CYCLE

2856
                 q = q + 1

2857
                 BasisDegree(q) = 1+k

2858
              END DO

2859
           END DO

2860
        END IF

2861


2862
        ! Faces of P Wedge 

2863
        IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

2864
           ! For each face in wedge, calculate values of face functions

2865
           DO F=1,5

2866
              Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) )

2867


2868
              ! Do not solve face dofs, if there is not any

2869
              IF ( Face % BDOFs <= 0) CYCLE

2870


2871
              p = Face % PDefs % P 

2872
              

2873
              ! Handle triangle and square faces separately

2874
              SELECT CASE(F)

2875
              CASE (1,2)

2876
                 ! For each face calculate values of functions from index

2877
                 ! pairs i,j=0,..,p-3 i+j=0,..,p-3

2878
                 DO i=0,p-3

2879
                    DO j=0,p-i-3

2880
                       IF ( q >= SIZE(BasisDegree) ) CYCLE

2881
                       q = q + 1

2882
                       BasisDegree(q) = 3+i+j

2883
                    END DO

2884
                 END DO

2885
              CASE (3,4,5)

2886
                 ! For each face calculate values of functions from index

2887
                 ! pairs i,j=2,..,p-2 i+j=4,..,p

2888
                 IF(SerendipityPBasis) THEN

2889
                   DO i=2,p-2

2890
                      DO j=2,p-i

2891
                         IF ( q >= SIZE(BasisDegree) ) CYCLE

2892
                         q = q + 1

2893
                         BasisDegree(q) = i+j

2894
                      END DO

2895
                   END DO

2896
                 ELSE

2897
                   DO i=0,p-2

2898
                      DO j=0,p-2

2899
                         IF ( q >= SIZE(BasisDegree) ) CYCLE

2900
                         q = q + 1

2901
                         BasisDegree(q) = 2+i+j

2902
                      END DO

2903
                   END DO

2904
                 END IF

2905
              END SELECT

2906
                           

2907
           END DO

2908
        END IF

2909


2910
        ! Bubbles of P Wedge

2911
        p = pSolver % Def_Dofs(7,BodyId,6)

2912
        nb = pSolver % Def_Dofs(7,BodyId,5)

2913
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

2914
        IF ( BDOFs > 0 ) THEN

2915
           ! Get p from element

2916
           p = getEffectiveBubbleP(element,p,bdofs)

2917


2918
           ! For each bubble calculate value of basis function and its derivative

2919
           ! for index pairs i,j=0,..,p-5 k=2,..,p-3 i+j+k=2,..,p-3

2920
           IF(SerendipityPBasis) THEN

2921
             DO i=0,p-5

2922
                DO j=0,p-5-i

2923
                   DO k=2,p-3-i-j

2924
                      IF ( q >= SIZE(BasisDegree) ) CYCLE

2925
                      q = q + 1

2926
                      BasisDegree(q) = 3+i+j+k

2927
                   END DO

2928
                END DO

2929
             END DO

2930
           ELSE

2931
             DO i=0,p-3

2932
                DO j=0,p-i-3

2933
                   DO k=0,p-2

2934
                      IF ( q >= SIZE(BasisDegree) ) CYCLE

2935
                      q = q + 1

2936
                      BasisDegree(q) = 3+i+j+k

2937
                   END DO

2938
                END DO

2939
             END DO

2940
           END IF

2941
        END IF

2942


2943
!------------------------------------------------------------------------------

2944
! P element code for brick edges, faces and bubbles

2945
     CASE(808) 

2946
        ! Edges of P brick

2947
        IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN

2948
           ! For each edge in brick, calculate values of edge functions 

2949
           DO i=1,12

2950
              Edge => CurrentModel % Solver % Mesh % Edges( Element % EdgeIndexes(i) )

2951


2952
              ! Do not solve edge dofs, if there is not any

2953
              IF (Edge % BDOFs <= 0) CYCLE

2954
              

2955
              ! For each DOF in edge calculate values of edge functions

2956
              ! and their derivatives for edge=i and i=k+1

2957
              DO k=1,Edge % BDOFs

2958
                 IF ( q >= SIZE(BasisDegree) ) CYCLE

2959
                 q = q + 1

2960
                 BasisDegree(q) = 1+k

2961
              END DO

2962
           END DO 

2963
        END IF

2964


2965
        ! Faces of P brick

2966
        IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

2967
           ! For each face in brick, calculate values of face functions

2968
           DO F=1,6

2969
              Face => CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(F) )

2970
                          

2971
              ! Do not calculate face values if no dofs

2972
              IF (Face % BDOFs <= 0) CYCLE

2973
              

2974
              ! Get p for face

2975
              p = Face % PDefs % P

2976


2977
              ! For each face calculate values of functions from index

2978
              ! pairs i,j=2,..,p-2 i+j=4,..,p

2979
              IF(SerendipityPBasis) THEN

2980
                DO i=2,p-2

2981
                   DO j=2,p-i

2982
                      IF ( q >= SIZE(BasisDegree) ) CYCLE

2983
                      q = q + 1

2984
                      BasisDegree(q) = i+j

2985
                   END DO

2986
                 END DO

2987
              ELSE

2988
                DO i=0,p-2

2989
                   DO j=0,p-2

2990
                      IF ( q >= SIZE(BasisDegree) ) CYCLE

2991
                      q = q + 1

2992
                      BasisDegree(q) = 2+i+j

2993
                   END DO

2994
                END DO

2995
              END IF

2996
           END DO

2997
        END IF

2998


2999
        ! Bubbles of p brick

3000
        p = pSolver % Def_Dofs(7,BodyId,6)

3001
        nb = pSolver % Def_Dofs(7,BodyId,5)

3002
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

3003
        IF ( BDOFs > 0 ) THEN

3004
           ! Get p from bubble DOFs 

3005
           p = getEffectiveBubbleP(element,p,bdofs)

3006


3007
           ! For each bubble calculate value of basis function and its derivative

3008
           ! for index pairs i,j,k=2,..,p-4, i+j+k=6,..,p

3009
           IF(SerendipityPBasis) THEN

3010
             DO i=2,p-4

3011
               DO j=2,p-i-2

3012
                 DO k=2,p-i-j

3013
                   IF ( q >= SIZE(BasisDegree) ) CYCLE

3014
                   q = q + 1

3015
                   BasisDegree(q) = i+j+k

3016
                 END DO

3017
               END DO

3018
             END DO

3019
           ELSE

3020
             DO i=0,p-2

3021
                DO j=0,p-2

3022
                   DO k=0,p-2

3023
                      IF ( q >= SIZE(BasisDegree) ) CYCLE

3024
                      q = q + 1

3025
                      BasisDegree(q) = 2+i+j+k

3026
                   END DO

3027
                END DO

3028
             END DO

3029
           END IF

3030
        END IF

3031


3032
     END SELECT

3033
     END IF ! P element flag check

3034
!------------------------------------------------------------------------------

3035
   END SUBROUTINE ElementBasisDegree

3036
!------------------------------------------------------------------------------

3037


3038


3039
   SUBROUTINE EdgeElementStyle(VList, PiolaVersion, SecondFamily, QuadraticApproximation, &

3040
       BasisDegree, Check ) 

3041


3042
     TYPE(ValueList_t), POINTER :: VList

3043
     LOGICAL :: PiolaVersion

3044
     LOGICAL, OPTIONAL :: SecondFamily

3045
     LOGICAL, OPTIONAL :: QuadraticApproximation

3046
     INTEGER, OPTIONAL :: BasisDegree

3047
     LOGICAL, OPTIONAL :: Check

3048
     

3049
     LOGICAL :: Found, Quadratic, Cubic, Second 

3050
     

3051
     Quadratic = ListGetLogical(VList,'Quadratic Approximation', Found )

3052
     Cubic = ListGetLogical(VList,'Cubic Approximation', Found )

3053
     

3054
     Second = ListGetLogical(Vlist,'Second Kind Basis', Found )

3055
     IF( Quadratic .OR. Cubic) THEN

3056
       PiolaVersion = .TRUE.

3057
     ELSE       

3058
       IF(Second) THEN

3059
         PiolaVersion = .TRUE.

3060
       ELSE    

3061
         PiolaVersion = ListGetLogical(Vlist,'Use Piola Transform', Found )

3062
       END IF

3063
     END IF

3064


3065
     IF(PRESENT(SecondFamily)) THEN

3066
       SecondFamily = Second

3067
     END IF

3068
     

3069
     IF(PRESENT(BasisDegree)) THEN

3070
       BasisDegree = 1

3071
       IF(Quadratic) THEN

3072
         BasisDegree = 2

3073
       ELSE IF (Cubic) THEN

3074
         BasisDegree = 3

3075
       END IF

3076
     END IF

3077


3078
     IF(PRESENT(QuadraticApproximation)) THEN

3079
       QuadraticApproximation = Quadratic

3080
     END IF

3081


3082
     ! When initializing the consistency of the keywords may be checked.

3083
     ! Also always add the Piola flag since it determines the type of IPs.

3084
     IF( PRESENT(Check)) THEN

3085
       IF(Check) THEN

3086
         IF(PiolaVersion) THEN

3087
           IF(.NOT. ListCheckPresent(Vlist,'Use Piola Transform')) THEN

3088
             IF(Quadratic .OR. Cubic) THEN

3089
               CALL Info('EdgeElementStyle','"Quadratic/Cubic Approximation" requested without Piola. ' &

3090
                   //'Setting "Use Piola Transform = True"')

3091
             ELSE IF( Second ) THEN

3092
               CALL Info('EdgeElementStyle','"Second Kind Basis" requested without Piola. ' &

3093
                   //'Setting "Use Piola Transform = True"')

3094
             END IF

3095
             CALL ListAddLogical(Vlist,'Use Piola Transform',.TRUE.)

3096
           END IF

3097
         END IF

3098
       END IF

3099
     END IF    

3100
     

3101
   END SUBROUTINE EdgeElementStyle

3102


3103
   

3104
!------------------------------------------------------------------------------

3105
!>  Return the referential description b(f(p)) of the basis function b(x),

3106
!>  with f mapping points p on a reference element to points x on a physical

3107
!>  element. The referential description of the spatial gradient field grad b 

3108
!>  and, if requested, the second spatial derivatives may also be returned.

3109
!>  Also return the square root of the determinant of the metric tensor

3110
!>  (=sqrt(det(J^TJ))) related to the mapping f.

3111
!------------------------------------------------------------------------------

3112
   RECURSIVE FUNCTION ElementInfo( Element, Nodes, u, v, w, detJ, &

3113
       Basis, dBasisdx, ddBasisddx, SecondDerivatives, Bubbles, BasisDegree, &

3114
       EdgeBasis, RotBasis, USolver ) RESULT(stat)

3115
!------------------------------------------------------------------------------

3116
     IMPLICIT NONE

3117


3118
     TYPE(Element_t), TARGET :: Element             !< Element structure

3119
     TYPE(Nodes_t)   :: Nodes                       !< Element nodal coordinates.

3120
     REAL(KIND=dp) :: u                             !< 1st local coordinate at which to calculate the basis function.

3121
     REAL(KIND=dp) :: v                             !< 2nd local coordinate.

3122
     REAL(KIND=dp) :: w                             !< 3rd local coordinate.

3123
     REAL(KIND=dp) :: detJ                          !< Square root of determinant of element coordinate system metric

3124
     REAL(KIND=dp) :: Basis(:)                      !< Basis function values at p=(u,v,w)

3125
     REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:)       !< Global first derivatives of basis functions at (u,v,w)

3126
     REAL(KIND=dp), OPTIONAL :: ddBasisddx(:,:,:)   !< Global second derivatives of basis functions at (u,v,w) if requested

3127
     LOGICAL, OPTIONAL :: SecondDerivatives         !< Are the second derivatives needed? (still present for historical reasons)

3128
     LOGICAL, OPTIONAL :: Bubbles                   !< Are the bubbles to be evaluated.

3129
     INTEGER, OPTIONAL :: BasisDegree(:)            !< Degree of each basis function in Basis(:) vector. 

3130
	                                                !! May be used with P element basis functions

3131
     REAL(KIND=dp), OPTIONAL :: EdgeBasis(:,:)      !< If present, the values of H(curl)-conforming basis functions B(f(p))

3132
     REAL(KIND=dp), OPTIONAL :: RotBasis(:,:)       !< The referential description of the spatial curl of B

3133
     TYPE(Solver_t), POINTER, OPTIONAL :: USolver   !< The solver used to call the basis functions.

3134
     LOGICAL :: Stat                                !< If .FALSE. element is degenerate.

3135
!------------------------------------------------------------------------------

3136
!    Local variables

3137
!------------------------------------------------------------------------------

3138
     TYPE(Solver_t), POINTER :: PSolver => NULL(), PrevSolver => NULL()

3139
     REAL(KIND=dp) :: BubbleValue, dBubbledx(3), t, s, LtoGMap(3,3)

3140
     LOGICAL :: invert, degrees, Compute2ndDerivatives

3141
     INTEGER :: i, j, k, l, q, p, f, n, nb, dim, cdim, locali, localj,  &

3142
          tmp(4), direction(4), GIndexes(Element % Type % NumberOfNodes)

3143
     INTEGER :: BodyId, EDOFs, BDOFs, Deg_Bubble, tetraType

3144
     REAL(KIND=dp) :: LinBasis(8), dLinBasisdx(8,3), ElmMetric(3,3)

3145


3146
     REAL(KIND=dp) :: NodalBasis(Element % TYPE % NumberOfNodes), &

3147
             dLBasisdx(MAX(SIZE(Nodes % x),SIZE(Basis)),3)

3148


3149
     REAL(KIND=dp), ALLOCATABLE :: ddlBasisddx(:,:,:)

3150


3151
     TYPE(Element_t) :: Bubble

3152
     TYPE(Element_t), POINTER :: Parent, Edge, Face

3153
     INTEGER :: EdgeBasisDegree

3154
     LOGICAL :: PerformPiolaTransform, Found, SerendipityPBasis

3155
     LOGICAL :: SecondFamily

3156
     LOGICAL :: SimplicialElements

3157
     

3158
     SAVE PrevSolver, EdgeBasisDegree, PerformPiolaTransform, SecondFamily

3159
!------------------------------------------------------------------------------

3160


3161
     IF( PRESENT( USolver ) ) THEN

3162
       pSolver => USolver

3163
     ELSE

3164
       pSolver => CurrentModel % Solver

3165
     END IF

3166
     

3167
     IF(PRESENT(EdgeBasis)) THEN       

3168
       IF( .NOT. ASSOCIATED( PrevSolver, PSolver ) ) THEN

3169
         PrevSolver => pSolver                  

3170
         CALL EdgeElementStyle(pSolver % Values, PerformPiolaTransform, SecondFamily, &

3171
             BasisDegree = EdgeBasisDegree )

3172
       END IF

3173
       IF( PerformPiolaTransform ) THEN

3174


3175
         SimplicialElements = ListGetLogical(pSolver % Values, 'Simplicial Mesh', Found )

3176
         

3177
         stat = EdgeElementInfo(Element,Nodes,u,v,w,detF=Detj,Basis=Basis, &

3178
             EdgeBasis=EdgeBasis,RotBasis=RotBasis,dBasisdx=dBasisdx,&

3179
             SecondFamily = SecondFamily, BasisDegree = EdgeBasisDegree, &

3180
             ApplyPiolaTransform = PerformPiolaTransform, &

3181
             SimplicialMesh = SimplicialElements)

3182
       ELSE

3183
         IF(Element % Type % ElementCode == 504 .AND. ANY([u,v,w] < 0.0) ) THEN

3184
           PRINT *,'Negative local coordinates for tet:',u,v,w

3185
         END IF

3186
         stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis, dBasisdx )

3187
         CALL GetEdgeBasis(Element,EdgeBasis,RotBasis,Basis,dBasisdx)         

3188
       END IF

3189
       RETURN

3190
     END IF

3191


3192
     stat = .TRUE.

3193
     n    = Element % TYPE % NumberOfNodes

3194
     dim  = Element % TYPE % DIMENSION

3195
     cdim = CoordinateSystemDimension()

3196


3197
     IF ( Element % TYPE % ElementCode == 101 ) THEN

3198
        detJ = 1.0d0

3199
        Basis(1) = 1.0d0

3200
        IF ( PRESENT(dBasisdx) ) dBasisdx(1,:) = 0.0d0

3201
        RETURN

3202
     END IF

3203


3204
     Compute2ndDerivatives = PRESENT(SecondDerivatives) .AND. PRESENT(ddBasisddx)

3205
     IF(Compute2ndDerivatives) Compute2ndDerivatives = SecondDerivatives

3206


3207
     IF(Compute2ndDerivatives) THEN

3208
       ALLOCATE(ddLBasisddx(MAX(SIZE(Nodes % x),SIZE(ddBasisddx)),3,3))

3209
       Basis = 0

3210
       ddLBasisddx = 0._dp

3211
       DO i=1,n

3212
         Basis(i) = 1

3213
         SELECT CASE(dim)

3214
         CASE(1)

3215
           ddLBasisddx(i,1,1) = SecondDerivatives1D(element,basis,u)

3216
         CASE(2)

3217
           ddLBasisddx(i,1:2,1:2) = SecondDerivatives2D(element,basis,u,v)

3218
         CASE(3)

3219
           SELECT CASE(Element % Type % ElementCode)

3220
           CASE(605)

3221
             IF(isActivePElement(Element,pSolver)) THEN

3222
               ddLBasisddx(i,:,:) = ddPyramidNodalPBasis(i,u,v,w)

3223
             ELSE

3224
               ddLBasisddx(i,:,:) = SecondDerivatives3D(element,basis,u,v,w)

3225
             END IF

3226
           CASE(706)

3227
             IF(isActivePElement(element,pSolver)) THEN

3228
               ddLBasisddx(i,:,:) = ddWedgeNodalPBasis(i,u,v,w)

3229
             ELSE

3230
               ddLBasisddx(i,:,:) = SecondDerivatives3D(element,basis,u,v,w)

3231
             END IF

3232
           CASE DEFAULT

3233
             ddLBasisddx(i,:,:) = SecondDerivatives3D(element,basis,u,v,w)

3234
           END SELECT

3235
         END SELECT

3236
         Basis(i) = 0

3237
       END DO

3238
     END IF

3239


3240
     Basis = 0.0d0

3241
     dLbasisdx = 0.0d0

3242
     CALL NodalBasisFunctions(n, Basis, element, u, v, w, pSolver)

3243
     CALL NodalFirstDerivatives(n, dLBasisdx, element, u, v, w, pSolver)

3244


3245
     q = n

3246


3247
!	dbasisdx(1:n,:) = dlbasisdx(1:n,:)

3248
!	if (compute2ndderivatives) ddbasisddx(1:n,:,:) = ddlbasisddx(1:n,:,:)

3249
!	detj = 1

3250
!	return

3251


3252
     ! P ELEMENT CODE:

3253
     ! ---------------

3254
     IF ( isActivePElement(element,pSolver) ) THEN

3255
      !

3256
      ! Check whether the polynomial degree of each basis functions is asked

3257
      ! and, if so, initialize by the degree of linear basis:

3258
      ! ---------------------------------------------------

3259
      degrees = .FALSE.

3260
      IF ( PRESENT(BasisDegree)) THEN 

3261
        degrees = .TRUE.

3262
        BasisDegree = 0

3263
        BasisDegree(1:n) = 1

3264
      END IF

3265


3266
      BodyId = Element % BodyId

3267
      IF (BodyId==0 .AND. ASSOCIATED(Element % BoundaryInfo)) THEN

3268
        Parent => Element % PDefs % LocalParent         

3269
        IF(ASSOCIATED(Parent)) BodyId = Parent % BodyId

3270
        IF( BodyId == 0 ) THEN

3271
          Parent => Element % BoundaryInfo % Left

3272
          IF( ASSOCIATED(Parent)) BodyId = Parent % BodyId

3273
        END IF

3274
        IF(BodyId == 0) THEN

3275
          Parent => Element % BoundaryInfo % Right

3276
          IF( ASSOCIATED(Parent)) BodyId = Parent % BodyId

3277
        END IF

3278
      END IF

3279


3280
      IF (BodyId==0) THEN

3281
        CALL Warn('ElementInfo', 'Element '//I2S(Element % ElementIndex)//' of type '//&

3282
            I2S(Element % TYPE % ElementCode)//' has 0 BodyId, assuming index 1')

3283
        BodyId = 1

3284
      END IF

3285


3286
      ! If running in parallel use global indexing in orienting degrees of freedom

3287
      GIndexes = Element % NodeIndexes

3288
      IF (ASSOCIATED(pSolver % Mesh % ParallelInfo % GlobalDOFs)) &

3289
        GIndexes = pSolver % Mesh % ParallelInfo % GlobalDOFs(GIndexes)

3290


3291
      SerendipityPBasis = Element % PDefs % Serendipity

3292


3293
!------------------------------------------------------------------------------

3294
     SELECT CASE( Element % TYPE % ElementCode ) 

3295
!------------------------------------------------------------------------------

3296


3297
     ! P element code for line element:

3298
     ! --------------------------------

3299
     CASE(202)

3300
        ! Get element p

3301
        p = pSolver % Def_Dofs(2,BodyId,6)

3302
        BDOFs = MAX(GetBubbleDOFs(Element, p), pSolver % Def_Dofs(2,BodyId,5))

3303


3304
        ! Bubbles of line element

3305
        IF (BDOFs > 0) THEN

3306
           ! For boundary element integration check direction

3307
           invert = .FALSE.

3308
           IF ( Element % PDefs % isEdge .AND. &

3309
                   GIndexes(1)>GIndexes(2) ) invert = .TRUE.

3310


3311
           ! For each bubble get the value of basis function

3312
           DO i=1, BDOFs

3313
              IF (q >= SIZE(Basis)) EXIT

3314
              q = q + 1

3315
              

3316
              Basis(q) = LineBubblePBasis(i+1,u,invert)

3317
              dLBasisdx(q,1) = dLineBubblePBasis(i+1,u,invert)

3318
              IF(Compute2ndDerivatives) THEN

3319
                ddLBasisddx(q,1,1) = ddLineBubblePBasis(i+1,u,invert)

3320
              END IF

3321
              

3322
              ! Polynomial degree of basis function to vector

3323
              IF (degrees) BasisDegree(q) = 1+i

3324
           END DO

3325
        END IF

3326


3327
!------------------------------------------------------------------------------

3328
     ! P element code for triangles:

3329
     CASE(303)

3330
        EDOFs = GetEdgeDOFs(Element, pSolver % Def_Dofs(3,BodyId,6))

3331
        ! Edges of triangle

3332
        IF ( ASSOCIATED( Element % EdgeIndexes ) .AND. EDOFs > 0) THEN

3333
           

3334
           ! For each edge calculate the value of edge basis function

3335
           edges_triangle: DO i=1,3

3336
              Edge => pSolver % Mesh % Edges( Element % EdgeIndexes(i) )

3337


3338
              ! Get local number of edge start and endpoint nodes

3339
              tmp(1:2) = getTriangleEdgeMap(i)

3340
              locali = tmp(1)

3341
              localj = tmp(2)

3342


3343
              ! Invert edge for parity if needed

3344
              invert = .FALSE.

3345
              IF ( GIndexes(locali)>GIndexes(localj) ) invert=.TRUE.

3346


3347
              ! For each edge DOF get the value of p-basis function

3348
              ! NOTE: Edges may not have correct information about the count of DOFs

3349
              !        per edge, so the following would not work:

3350
              !       EDOFs = GetEdgeDOFs(Edge, pSolver % Def_Dofs(2,BodyId,6))

3351
              !

3352
              DO k=1,EDOFs

3353
                 IF (q >= SIZE(Basis)) EXIT edges_triangle

3354
                 q = q + 1

3355
                 

3356
                 ! Value of basis functions for edge=i and i=k+1 by parity

3357
                 Basis(q) = TriangleEdgePBasis(i, k+1, u, v, invert)

3358
                 dLBasisdx(q,1:2) = dTriangleEdgePBasis(i, k+1, u, v, invert)

3359
                 IF(Compute2ndDerivatives) THEN

3360
                   ddLBasisddx(q,1:2,1:2) = ddTriangleEdgePBasis(i,k+1,u,v,invert)

3361
                 END IF

3362
                 

3363
                 ! Polynomial degree of basis function to vector

3364
                 IF (degrees) BasisDegree(q) = 1+k

3365
              END DO

3366
           END DO edges_triangle

3367
        END IF

3368


3369
        ! Bubbles of p triangle      

3370


3371
        ! Get element p

3372
        p = pSolver % Def_Dofs(3,BodyId,6)

3373
        nb = pSolver % Def_Dofs(3,BodyId,5)

3374
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

3375


3376
        IF (BDOFs > 0) THEN

3377
           p = getEffectiveBubbleP(element,p,bdofs)

3378
           

3379
           ! For boundary element direction needs to be calculated

3380
           IF (Element % PDefs % isEdge) THEN

3381
              direction = 0

3382
              ! Get direction of this face (mask for face = boundary element nodes)

3383
              direction(1:3) = getTriangleFaceDirection(Element, [ 1,2,3 ], GIndexes)

3384
           END IF

3385


3386
           bubbles_triangle: DO i = 0,p-3

3387
              DO j = 0,p-i-3

3388
                 IF ( q >= SIZE(Basis) ) EXIT bubbles_triangle

3389
                 q = q + 1

3390


3391
                 ! Get bubble basis functions and their derivatives

3392
                 ! 3d Boundary element has a direction

3393
                 IF (Element % PDefs % isEdge) THEN

3394
                    Basis(q) = TriangleEBubblePBasis(i,j,u,v,direction) 

3395
                    dLBasisdx(q,1:2) = dTriangleEBubblePBasis(i,j,u,v,direction)

3396


3397
                    IF(Compute2ndDerivatives) THEN

3398
                      ddLBasisddx(q,1:2,1:2) = ddTriangleEBubblePBasis(i,j,u,v,direction)

3399
                    END IF

3400
                 ELSE

3401
                 ! 2d element bubbles have no direction

3402
                    Basis(q) = TriangleBubblePBasis(i,j,u,v) 

3403
                    dLBasisdx(q,1:2) = dTriangleBubblePBasis(i,j,u,v)

3404


3405
                    IF(Compute2ndDerivatives) THEN

3406
                      ddLBasisddx(q,1:2,1:2) = ddTriangleBubblePBasis(i,j,u,v)

3407
                    END IF

3408
                 END IF

3409
                 

3410
                 ! Polynomial degree of basis function to vector

3411
                 IF (degrees) BasisDegree(q) = 3+i+j

3412
              END DO

3413
           END DO bubbles_triangle

3414
        END IF

3415
!------------------------------------------------------------------------------

3416
     ! P element code for quads:

3417
     CASE(404)

3418
        ! Edges of p quadrilateral

3419
        EDOFs = GetEdgeDOFs(Element, pSolver % Def_Dofs(4,BodyId,6))

3420
        IF ( ASSOCIATED( Element % EdgeIndexes ) ) THEN

3421
           ! For each edge calculate the values of edge basis functions 

3422
           edges_quad: DO i=1,4

3423
              Edge => pSolver % Mesh % Edges( Element % EdgeIndexes(i) )

3424


3425
              ! Choose correct parity by global edge dofs

3426
              tmp(1:2) = getQuadEdgeMap(i)

3427
              locali = tmp(1)

3428
              localj = tmp(2)

3429
              

3430
              ! Invert parity if needed

3431
              invert = .FALSE.

3432
              IF (GIndexes(locali) > GIndexes(localj)) invert = .TRUE. 

3433


3434
              ! For each DOF in edge calculate the value of p-basis function

3435
              DO k=1,EDOFs

3436
                 IF ( q >= SIZE(Basis) ) EXIT edges_quad

3437
                 q = q + 1

3438


3439
                 ! Get values of basis functions for edge=i and i=k+1 by parity

3440
                 IF (SerendipityPBasis) THEN

3441
                   Basis(q) = SD_QuadEdgePBasis(i,k+1,u,v,invert)

3442
                   ! Get value of derivatives of basis functions

3443
                   dLBasisdx(q,1:2) = SD_dQuadEdgePBasis(i,k+1,u,v,invert)

3444
                   IF (Compute2ndDerivatives) THEN

3445
                     ddLBasisddx(q,1:2,1:2) = SD_ddQuadEdgePBasis(i,k+1,u,v,invert)

3446
                   END IF

3447
                 ELSE

3448
                   Basis(q) = QuadEdgePBasis(i,k+1,u,v,invert)

3449
                   ! Get value of derivatives of basis functions

3450
                   dLBasisdx(q,1:2) = dQuadEdgePBasis(i,k+1,u,v,invert)

3451
                   IF (Compute2ndDerivatives) THEN

3452
                     ddLBasisddx(q,1:2,1:2) = ddQuadEdgePBasis(i,k+1,u,v,invert)

3453
                   END IF

3454
                 END IF

3455
                 

3456
                 ! Polynomial degree of basis function to vector

3457
                 IF (degrees) BasisDegree(q) = 1+k

3458
              END DO              

3459
           END DO edges_quad

3460
        END IF

3461


3462
        ! Bubbles of p quadrilateral, the number of which may have been defined explicitly or

3463
        ! be determined by the specified degree of approximation. However, we never omit bubbles

3464
        ! which are part of the FE space of the specified degree

3465
  

3466
        ! Get the specified element P:

3467
        p = pSolver % Def_Dofs(4,BodyId,6)

3468
        nb = pSolver % Def_Dofs(4,BodyId,5)

3469
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb) 

3470


3471
        IF (BDOFs > 0) THEN

3472
           p = getEffectiveBubbleP(element,p,bdofs)

3473


3474
           ! For boundary element direction needs to be calculated

3475
           IF (Element % PDefs % isEdge) THEN

3476
              direction = getSquareFaceDirection(Element, [ 1,2,3,4 ], GIndexes )

3477
           END IF

3478
          

3479
           ! For each bubble calculate the value of p basis function

3480
           ! and its derivatives for index pairs i,j>=2, i+j=4,...,p

3481
           IF(SerendipityPBasis) THEN

3482
             SD_bubbles_quad: DO i=2,p-2

3483
                DO j=2,p-i

3484
                  IF ( q >= SIZE(Basis) ) EXIT SD_bubbles_quad

3485
                  q = q + 1

3486
                 

3487
                  ! Get values of bubble functions

3488
                  ! 3D boundary elements have a direction

3489
                  IF (Element % PDefs % isEdge) THEN

3490
                    Basis(q) = SD_QuadBubblePBasis(i,j,u,v,direction)

3491
                    dLBasisdx(q,1:2) = SD_dQuadBubblePBasis(i,j,u,v,direction)

3492
                    IF (Compute2ndDerivatives) THEN

3493
                      ddLBasisddx(q,1:2,1:2) = SD_ddQuadBubblePBasis(i,j,u,v)

3494
                    END IF

3495
                  ELSE

3496
                    ! 2d element bubbles have no direction

3497
                    Basis(q) = SD_QuadBubblePBasis(i,j,u,v)

3498
                    dLBasisdx(q,1:2) = SD_dQuadBubblePBasis(i,j,u,v)

3499
                    IF (Compute2ndDerivatives) THEN

3500
                      ddLBasisddx(q,1:2,1:2) = SD_ddQuadBubblePBasis(i,j,u,v)

3501
                    END IF

3502
                  END IF

3503
                  ! Polynomial degree of basis function to vector

3504
                  IF (degrees) BasisDegree(q) = i+j

3505
                END DO

3506
             END DO SD_bubbles_quad

3507
           ELSE

3508
             bubbles_quad: DO i=0,p-2

3509
                DO j=0,p-2

3510
                  IF ( q >= SIZE(Basis) ) EXIT bubbles_quad

3511
                  q = q + 1

3512
                 

3513
                  ! Get values of bubble functions

3514
                  ! 3D boundary elements have a direction

3515
                  IF (Element % PDefs % isEdge) THEN

3516
                    Basis(q) = QuadBubblePBasis(i,j,u,v,direction)

3517
                    dLBasisdx(q,1:2) = dQuadBubblePBasis(i,j,u,v,direction)

3518
                    IF (Compute2ndDerivatives) THEN

3519
                      ddLBasisddx(q,1:2,1:2) = ddQuadBubblePBasis(i,j,u,v)

3520
                    END IF

3521
                  ELSE

3522
                    ! 2d element bubbles have no direction

3523
                    Basis(q) = QuadBubblePBasis(i,j,u,v)

3524
                    dLBasisdx(q,1:2) = dQuadBubblePBasis(i,j,u,v)

3525
                    IF (Compute2ndDerivatives) THEN

3526
                      ddLBasisddx(q,1:2,1:2) = ddQuadBubblePBasis(i,j,u,v)

3527
                    END IF

3528
                  END IF

3529
                  ! Polynomial degree of basis function to vector

3530
                  IF (degrees) BasisDegree(q) = 2+i+j

3531
                END DO

3532
             END DO bubbles_quad

3533
           END IF

3534
        END IF

3535
!------------------------------------------------------------------------------

3536
     ! P element code for tetrahedra:

3537
     CASE(504)

3538
        p = pSolver % Def_Dofs(5,BodyId,6)

3539
        EDOFs = GetEdgeDOFs(Element, p)

3540
        tetraType = Element % PDefs % TetraType

3541


3542
        ! Edges of p tetrahedron

3543
        IF ( ASSOCIATED( Element % EdgeIndexes ) .AND. EDOFs > 0) THEN   

3544
           ! For each edge i calculate the values of edge functions

3545
           edges_tetrahedron: DO i=1,6

3546
              Edge => pSolver % Mesh % Edges (Element % EdgeIndexes(i))

3547
              

3548
              ! For each edge DOF k calculate the value of edge function

3549
              ! and its derivatives

3550
              DO k=1, EDOFs

3551
                 IF (q >= SIZE(Basis)) EXIT edges_tetrahedron

3552
                 q = q + 1

3553


3554
                 Basis(q) = TetraEdgePBasis(i,k+1,u,v,w,tetraType)

3555
                 dLBasisdx(q,:) = dTetraEdgePBasis(i,k+1,u,v,w,tetraType)

3556
                 IF(Compute2ndDerivatives) THEN

3557
                    ddLBasisddx(q,:,:) = ddTetraEdgePBasis(i,k+1,u,v,w,tetraType)

3558
                 END IF

3559


3560
                 ! Polynomial degree of basis function to vector

3561
                 IF (degrees) BasisDegree(q) = 1+k

3562
              END DO

3563
           END DO edges_tetrahedron

3564
        END IF

3565


3566
        ! Faces of p tetrahedron

3567
        IF ( ASSOCIATED( Element % FaceIndexes )) THEN

3568
           ! For each face calculate values of face functions

3569
           faces_tetrahedron: DO F=1,4

3570
              Face => pSolver % Mesh % Faces (Element % FaceIndexes(F))

3571


3572
              ! Get face p 

3573
              !p = MAX(pSolver % Def_Dofs(5,BodyId,6), Face % PDefs % P)

3574


3575
              ! Do not solve face DOFs if there is not any

3576
              !IF (GetFaceDOFs(Element, p, F) <= 0) CYCLE

3577


3578
              tmp(1:3) = getTetraFaceMap(F,tetraType)

3579
              direction(1:3) = getTriangleFaceDirection( Element, tmp(1:3), GIndexes )

3580


3581
              ! For each DOF in face calculate values of face function and 

3582
              ! its derivatives for index pairs 

3583
              ! i,j=0,..,p-3, i+j=0,..,p-3

3584
              DO i=0,p-3

3585
                 DO j=0,p-i-3

3586
                    IF (q >= SIZE(Basis)) EXIT faces_tetrahedron

3587
                    q = q + 1 

3588
                  

3589
                    Basis(q) = TetraFacePBasis(F,i,j,u,v,w, tetraType )

3590
                    dLBasisdx(q,:) = dTetraFacePBasis(F,i,j,u,v,w, tetraType )

3591
                    IF(Compute2ndDerivatives) THEN

3592
                      ddLBasisddx(q,:,:) = ddTetraFacePBasis(F,i,j,u,v,w,tetraType )

3593
                    END IF

3594


3595
                    ! Polynomial degree of basis function to vector

3596
                    IF (degrees) BasisDegree(q) = 3+i+j

3597
                 END DO

3598
              END DO

3599
           END DO faces_tetrahedron

3600
        END IF

3601


3602
        ! Bubbles of p tetrahedron

3603
        nb = pSolver % Def_Dofs(5,BodyId,5)

3604
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb) 

3605
        IF ( BDOFs > 0 ) THEN

3606
           p = getEffectiveBubbleP(element,p,bdofs)

3607


3608
           ! For each bubble DOF calculate the value of bubble function

3609
           ! and its derivatives for index pairs

3610
           ! i,j,k=0,..,p-4 i+j+k=0,..,p-4

3611
           bubbles_tetrahedron: DO i=0,p-4

3612
              DO j=0,p-i-4

3613
                 DO k=0,p-i-j-4

3614
                    IF (q >= SIZE(Basis)) EXIT bubbles_tetrahedron

3615
                    q = q + 1

3616


3617
                    Basis(q) = TetraBubblePBasis(i,j,k,u,v,w)

3618
                    dLBasisdx(q,:) = dTetraBubblePBasis(i,j,k,u,v,w)

3619
                    IF(Compute2ndDerivatives) THEN

3620
                      ddLBasisddx(q,:,:) = ddTetraBubblePBasis(i,j,k,u,v,w)

3621
                    END IF

3622
                    ! Polynomial degree of basis function to vector

3623
                    IF (degrees) BasisDegree(q) = 4+i+j+k

3624
                 END DO

3625
              END DO

3626
           END DO bubbles_tetrahedron

3627
           

3628
        END IF

3629
!------------------------------------------------------------------------------

3630
     ! P element code for pyramids:

3631
     CASE(605)

3632


3633
        IF(SerendipityPBasis) THEN

3634
          CALL Fatal('ElementInfo', 'p-Pyramid not implemented for serendipity scheme, ' // &

3635
                      'please use the full scheme instead.')

3636
        END IF

3637


3638
        ! Edges of P Pyramid

3639
        p = pSolver % Def_Dofs(6,BodyId,6)

3640
        EDOFs = GetEdgeDOFs(Element, p)

3641
        IF (ASSOCIATED( Element % EdgeIndexes ) .AND. EDOFs > 0) THEN

3642
           ! For each edge calculate values of edge functions

3643
           edges_pyramid: DO i=1,8

3644
              Edge => pSolver % Mesh % Edges( Element % EdgeIndexes(i) )

3645


3646
              ! Get local indexes of current edge

3647
              tmp(1:2) = getPyramidEdgeMap(i)

3648
              locali = tmp(1)

3649
              localj = tmp(2)

3650


3651
              ! Determine edge direction

3652
              invert = .FALSE.

3653
              

3654
              ! Invert edge if local first node has greater global index than second one

3655
              IF ( GIndexes(locali) > GIndexes(localj) ) invert = .TRUE.

3656


3657
              ! For each edge DOF k calculate the value of edge function

3658
              ! and its derivatives

3659
              DO k=1,EDOFs

3660
                 IF ( q >= SIZE(Basis) ) EXIT edges_pyramid

3661
                 q = q + 1

3662


3663
                 ! Get values of edge basis functions and their derivatives

3664
                 Basis(q) = PyramidEdgePBasis(i,k+1,u,v,w,invert)

3665
                 dLBasisdx(q,:) = dPyramidEdgePBasis(i,k+1,u,v,w,invert)

3666
                 IF (Compute2ndDerivatives) THEN

3667
                   ddLBasisddx(q,:,:) = ddPyramidEdgePBasis(i,k+1,u,v,w,invert)

3668
                 END IF

3669
                 ! Polynomial degree of basis function to vector

3670
                 IF (degrees) BasisDegree(q) = 1+k

3671
              END DO

3672
           END DO edges_pyramid

3673
        END IF

3674


3675
        

3676
        ! Faces of P Pyramid

3677
        IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

3678
           ! For each face in pyramid, calculate the values of face functions

3679
           faces_pyramid: DO F=1,5

3680
              Face => pSolver % Mesh % Faces( Element % FaceIndexes(F) )

3681
              

3682
              ! Get face p

3683
              !p = MAX(pSolver % Def_Dofs(6,BodyId,6), Face % PDefs % P) 

3684


3685
              ! Do not solve face dofs, if there is not any

3686
              !IF (GetFaceDOFs(Element, p, F) <= 0) CYCLE

3687
              

3688
              ! Handle triangle and square faces separately

3689
              SELECT CASE(F)

3690
              CASE (1)

3691
                 direction = 0; invert=.FALSE.

3692
                 ! Get global direction vector for enforcing parity

3693
                 tmp(1:4) = getPyramidFaceMap(F)

3694
                 direction(1:4) = getSquareFaceDirection( Element, tmp(1:4), GIndexes )

3695


3696
                 ! For each face calculate the values of functions for index

3697
                 ! pairs i,j=2,..,p-2 i+j=4,..,p

3698


3699
!                DO i=0,p-2

3700
!                   DO j=0,p-i-2

3701
                 DO i=0,p-2

3702
                    DO j=0,p-2

3703
                       IF ( q >= SIZE(Basis) ) EXIT faces_pyramid

3704
                       q = q + 1

3705
                       

3706
                       Basis(q) = PyramidFacePBasis(F,i,j,u,v,w,direction)

3707
                       dLBasisdx(q,:) = dPyramidFacePBasis(F,i,j,u,v,w,direction)

3708
                       IF (Compute2ndDerivatives) THEN

3709
                         ddLBasisddx(q,:,:) = ddPyramidFacePBasis(F,i,j,u,v,w,direction)

3710
                       END IF

3711
                       

3712
                       ! Polynomial degree of basis function to vector

3713
                       IF (degrees) BasisDegree(q) = 2+i+j

3714
                    END DO

3715
                 END DO

3716


3717
              CASE (2,3,4,5)

3718
                 direction = 0

3719
                 ! Get global direction vector for enforcing parity

3720
                 tmp(1:4) = getPyramidFaceMap(F) 

3721
                 direction(1:3) = getTriangleFaceDirection( Element, tmp(1:3), GIndexes )

3722


3723
                 ! For each face calculate the values of functions for index

3724
                 ! pairs i,j=0,..,p-3 i+j=0,..,p-3

3725
                 DO i=0,p-3

3726
                    DO j=0,p-i-3

3727
                       IF ( q >= SIZE(Basis) ) EXIT faces_pyramid

3728
                       q = q + 1

3729


3730
                       Basis(q) = PyramidFacePBasis(F,i,j,u,v,w,direction)

3731
                       dLBasisdx(q,:) = dPyramidFacePBasis(F,i,j,u,v,w,direction)

3732
                       IF (Compute2ndDerivatives) THEN

3733
                         ddLBasisddx(q,:,:) = ddPyramidFacePBasis(F,i,j,u,v,w,direction)

3734
                       END IF

3735


3736
                       ! Polynomial degree of basis function to vector

3737
                       IF (degrees) BasisDegree(q) = 3+i+j

3738
                    END DO

3739
                 END DO

3740
              END SELECT    

3741
           END DO faces_pyramid

3742
        END IF

3743


3744
        ! Bubbles of P Pyramid

3745
        nb = pSolver % Def_Dofs(6,BodyId,5)

3746
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb) 

3747
        IF ( BDOFs > 0 ) THEN

3748
           p = getEffectiveBubbleP(element,p,bdofs)

3749
 

3750
           ! Calculate the values of bubble functions for indexes

3751
           ! i,j,k=0,..,p-3 i+j+k=0,..,p-3

3752
           bubbles_pyramid: DO i=0,p-3

3753
              DO j=0,p-i-3

3754
                 DO k=0,p-i-j-3

3755
                    IF ( q >= SIZE(Basis)) EXIT bubbles_pyramid

3756
                    q = q + 1

3757


3758
                    Basis(q) = PyramidBubblePBasis(i,j,k,u,v,w)

3759
                    dLBasisdx(q,:) = dPyramidBubblePBasis(i,j,k,u,v,w)

3760
                    IF (Compute2ndDerivatives) THEN

3761
                      ddLBasisddx(q,:,:) = ddPyramidBubblePBasis(i,j,k,u,v,w)

3762
                    END IF

3763
                    

3764
                    ! Polynomial degree of basis function to vector

3765
                    IF (degrees) BasisDegree(q) = 3+i+j+k

3766
                 END DO

3767
              END DO

3768
           END DO bubbles_pyramid

3769
        END IF

3770
        

3771
!------------------------------------------------------------------------------

3772
     ! P element code wedges:

3773
     CASE(706)

3774
        p = pSolver % Def_Dofs(7,BodyId,6)

3775
        EDOFs = GetEdgeDOFs(Element, p)

3776
        ! Edges of P Wedge

3777
        IF (ASSOCIATED( Element % EdgeIndexes ) .AND. EDOFs > 0) THEN

3778
           ! For each edge i calculate the values of edge functions

3779
           edges_prism: DO i=1,9

3780
              Edge => pSolver % Mesh % Edges( Element % EdgeIndexes(i) )

3781
              

3782
              ! Get local indexes of current edge

3783
              tmp(1:2) = getWedgeEdgeMap(i)

3784
              locali = tmp(1)

3785
              localj = tmp(2)

3786


3787
              ! Determine edge direction

3788
              invert = .FALSE.

3789
              ! Invert edge if local first node has greater global index than second one

3790
              IF ( GIndexes(locali) > GIndexes(localj) ) invert = .TRUE.

3791
       

3792
              ! For each edge DOF k calculate the value of edge function

3793
              ! and its derivatives

3794
              DO k=1,EDOFs

3795
                 IF ( q >= SIZE(Basis) ) EXIT edges_prism

3796
                 q = q + 1

3797


3798
                 ! Get values of edge basis functions and their derivatives

3799
                 IF(SerendipityPBasis) THEN

3800
                   Basis(q) = SD_WedgeEdgePBasis(i,k+1,u,v,w,invert)

3801
                   dLBasisdx(q,:) = SD_dWedgeEdgePBasis(i,k+1,u,v,w,invert)

3802
                   IF(Compute2ndDerivatives) THEN

3803
                     ddLBasisddx(q,:,:) = SD_ddWedgeEdgePBasis(i,k+1,u,v,w,invert)

3804
                   END IF

3805
                 ELSE

3806
                   Basis(q) = WedgeEdgePBasis(i,k+1,u,v,w,invert)

3807
                   dLBasisdx(q,:) = dWedgeEdgePBasis(i,k+1,u,v,w,invert)

3808
                   IF(Compute2ndDerivatives) THEN

3809
                     ddLBasisddx(q,:,:) = ddWedgeEdgePBasis(i,k+1,u,v,w,invert)

3810
                   END IF

3811
                 END IF

3812


3813
                 ! Polynomial degree of basis function to vector

3814
                 IF (degrees) BasisDegree(q) = 1+k

3815
              END DO

3816
           END DO edges_prism

3817
        END IF

3818


3819
        ! The faces of p-wedge 

3820
        IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

3821
           ! For each face in wedge, calculate the values of face functions

3822
           faces_prism: DO F=1,5

3823
              Face => pSolver % Mesh % Faces( Element % FaceIndexes(F) )

3824


3825
              !p = MAX(pSolver % Def_Dofs(7,BodyId,6), Face % PDefs % P) 

3826


3827
              ! Do not solve face dofs, if there is not any

3828
              !IF (GetFaceDOFs(Element, p, F) <= 0) CYCLE

3829
              

3830
              ! Handle triangle and square faces separately

3831
              SELECT CASE(F)

3832
              CASE (1,2)

3833
                 direction = 0

3834
                 ! Get global direction vector for enforcing parity

3835
                 tmp(1:4) = getWedgeFaceMap(F) 

3836
                 direction(1:3) = getTriangleFaceDirection( Element, tmp(1:3), GIndexes )

3837
                 

3838
                 ! For each face calculate the values of functions for index

3839
                 ! pairs i,j=0,..,p-3 i+j=0,..,p-3

3840
                 DO i=0,p-3

3841
                    DO j=0,p-i-3

3842
                       IF ( q >= SIZE(Basis) ) EXIT faces_prism

3843
                       q = q + 1

3844


3845
                       IF(SerendipityPBasis) THEN

3846
                         Basis(q) = SD_WedgeFacePBasis(F,i,j,u,v,w,direction)

3847
                         dLBasisdx(q,:) = SD_dWedgeFacePBasis(F,i,j,u,v,w,direction)

3848
                         IF(Compute2ndDerivatives) THEN

3849
                            ddLBasisddx(q,:,:) = SD_ddWedgeFacePBasis(F,i,j,u,v,w,direction)

3850
                         END IF

3851
                       ELSE

3852
                         Basis(q) = WedgeFacePBasis(F,i,j,u,v,w,direction)

3853
                         dLBasisdx(q,:) = dWedgeFacePBasis(F,i,j,u,v,w,direction)

3854
                         IF(Compute2ndDerivatives) THEN

3855
                            ddLBasisddx(q,:,:) = ddWedgeFacePBasis(F,i,j,u,v,w,direction)

3856
                         END IF

3857
                       END IF

3858


3859
                       ! Polynomial degree of basis function to vector

3860
                       IF (degrees) BasisDegree(q) = 3+i+j

3861
                    END DO

3862
                 END DO

3863
              CASE (3,4,5)

3864
                 direction = 0

3865
                 ! Get global direction vector for enforcing parity

3866
                 invert = .FALSE.

3867
                 tmp(1:4) = getWedgeFaceMap(F)

3868
                 direction(1:4) = getSquareFaceDirection( Element, tmp(1:4), GIndexes )

3869
                 

3870
                 ! First and second node must form a face in upper or lower triangle

3871
                 IF (.NOT. wedgeOrdering(direction)) THEN

3872
                    invert = .TRUE.

3873
                    tmp(1) = direction(2)

3874
                    direction(2) = direction(4)

3875
                    direction(4) = tmp(1)

3876
                 END IF

3877


3878
                 ! For each face calculate values of functions from index

3879
                 ! pairs i,j=2,..,p-2 i+j=4,..,p

3880
                 IF(SerendipityPBasis) THEN

3881
                   DO i=2,p-2

3882
                      DO j=2,p-i

3883
                         IF ( q >= SIZE(Basis) ) EXIT faces_prism

3884
                         q = q + 1

3885


3886
                         IF (.NOT. invert) THEN

3887
                            Basis(q) = SD_WedgeFacePBasis(F,i,j,u,v,w,direction)

3888
                            dLBasisdx(q,:) = SD_dWedgeFacePBasis(F,i,j,u,v,w,direction)

3889
                            IF(Compute2ndDerivatives) THEN

3890
                               ddLBasisddx(q,:,:) = SD_ddWedgeFacePBasis(F,i,j,u,v,w,direction)

3891
                            END IF

3892
                         ELSE

3893
                            Basis(q) = SD_WedgeFacePBasis(F,j,i,u,v,w,direction)

3894
                            dLBasisdx(q,:) = SD_dWedgeFacePBasis(F,j,i,u,v,w,direction)

3895
                            IF(Compute2ndDerivatives) THEN

3896
                               ddLBasisddx(q,:,:) = SD_ddWedgeFacePBasis(F,j,i,u,v,w,direction)

3897
                            END IF

3898
                         END IF

3899
                         ! Polynomial degree of basis function to vector

3900
                         IF (degrees) BasisDegree(q) = i+j

3901
                      END DO

3902
                   END DO

3903
                 ELSE

3904
                   DO i=0,p-2

3905
                      DO j=0,p-2

3906
                         IF ( q >= SIZE(Basis) ) EXIT faces_prism

3907
                         q = q + 1

3908


3909
                         Basis(q) = WedgeFacePBasis(F,i,j,u,v,w,direction)

3910
                         dLBasisdx(q,:) = dWedgeFacePBasis(F,i,j,u,v,w,direction)

3911
                         IF(Compute2ndDerivatives) THEN

3912
                            ddLBasisddx(q,:,:) = ddWedgeFacePBasis(F,i,j,u,v,w,direction)

3913
                         END IF

3914
  

3915
                         ! Polynomial degree of basis function to vector

3916
                         IF (degrees) BasisDegree(q) = 2+i+j

3917
                      END DO

3918
                   END DO

3919
                 END IF

3920
              END SELECT

3921
           END DO faces_prism

3922
        END IF

3923


3924
        ! Bubbles of P Wedge

3925
        nb = pSolver % Def_Dofs(7,BodyId,5)

3926
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb) 

3927
        IF ( BDOFs > 0 ) THEN

3928


3929
           p = getEffectiveBubbleP(element,p,bdofs)

3930
           

3931
           IF(SerendipityPBasis) THEN

3932
             ! For each bubble calculate the value of basis function and its derivative

3933
             ! for index pairs i,j=0,..,p-5 k=2,..,p-3 i+j+k=2,..,p-3

3934
             SD_bubbles_prism: DO i=0,p-5

3935
                DO j=0,p-5-i

3936
                   DO k=2,p-3-i-j

3937
                      IF ( q >= SIZE(Basis) ) EXIT SD_bubbles_prism

3938
                      q = q + 1

3939


3940
                      Basis(q) = SD_WedgeBubblePBasis(i,j,k,u,v,w)

3941
                      dLBasisdx(q,:) = SD_dWedgeBubblePBasis(i,j,k,u,v,w)

3942
                      IF(Compute2ndDerivatives) THEN

3943
                        ddLBasisddx(q,:,:) = SD_ddWedgeBubblePBasis(i,j,k,u,v,w)

3944
                      END IF

3945


3946
                      ! Polynomial degree of basis function to vector

3947
                      IF (degrees) BasisDegree(q) = 3+i+j+k

3948
                   END DO

3949
                END DO

3950
             END DO SD_bubbles_prism

3951
           ELSE

3952
             bubbles_prism: DO i=0,p-3

3953
                DO j=0,p-i-3

3954
                   DO k=0,p-2

3955
                      IF ( q >= SIZE(Basis) ) EXIT bubbles_prism

3956
                      q = q + 1

3957


3958
                      Basis(q) = WedgeBubblePBasis(i,j,k,u,v,w)

3959
                      dLBasisdx(q,:) = dWedgeBubblePBasis(i,j,k,u,v,w)

3960
                      IF(Compute2ndDerivatives) THEN

3961
                        ddLBasisddx(q,:,:) = ddWedgeBubblePBasis(i,j,k,u,v,w)

3962
                      END IF

3963


3964
                      ! Polynomial degree of basis function to vector

3965
                      IF (degrees) BasisDegree(q) = 2+i+j+k

3966
                   END DO

3967
                END DO

3968
             END DO bubbles_prism

3969
           END IF

3970
        END IF

3971


3972
!------------------------------------------------------------------------------

3973
     ! P element code for bricks:

3974
     CASE(808) 

3975
        p = pSolver % Def_Dofs(8,BodyId,6)

3976
        EDOFs = GetEdgeDOFs(Element, p)

3977
        ! Edges of P brick

3978
        IF ( ASSOCIATED( Element % EdgeIndexes ) .AND. EDOFs > 0) THEN

3979
           ! For each edge i calculate the values of edge functions 

3980
           edges_brick: DO i=1,12

3981
              Edge => pSolver % Mesh % Edges( Element % EdgeIndexes(i) )

3982
              

3983
              ! Get local indexes of current edge

3984
              tmp(1:2) = getBrickEdgeMap(i)

3985
              locali = tmp(1)

3986
              localj = tmp(2)

3987
              

3988
              ! Determine edge direction

3989
              invert = .FALSE.

3990
              

3991
              ! Invert edge if local first node has greater global index than second one

3992
              IF (GIndexes(locali)>GIndexes(localj)) invert = .TRUE.

3993
              

3994
              ! For each edge DOF k calculate the values of edge function

3995
              ! and its derivatives

3996
              DO k=1,EDOFs

3997
                 IF ( q >= SIZE(Basis) ) EXIT edges_brick

3998
                 q = q + 1

3999


4000
                 ! Get values of edge basis functions and their derivatives

4001
                 IF(SerendipityPBasis) THEN

4002
                   Basis(q) = SD_BrickEdgePBasis(i,k+1,u,v,w,invert)

4003
                   dLBasisdx(q,:) = SD_dBrickEdgePBasis(i,k+1,u,v,w,invert)

4004
                   IF (Compute2ndDerivatives) THEN

4005
                     ddLBasisddx(q,:,:) = SD_ddBrickEdgePBasis(i,k+1,u,v,w,invert)

4006
                   END IF

4007
                 ELSE

4008
                   Basis(q) = BrickEdgePBasis(i,k+1,u,v,w,invert)

4009
                   dLBasisdx(q,:) = dBrickEdgePBasis(i,k+1,u,v,w,invert)

4010
                   IF (Compute2ndDerivatives) THEN

4011
                     ddLBasisddx(q,:,:) = ddBrickEdgePBasis(i,k+1,u,v,w,invert)

4012
                   END IF

4013
                 END IF

4014


4015
                 ! Polynomial degree of basis function to vector

4016
                 IF (degrees) BasisDegree(q) = 1+k

4017
              END DO

4018
           END DO edges_brick

4019
        END IF

4020


4021
        ! Faces of P brick

4022
        IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

4023
          ! For each face in brick, calculate values of face functions

4024
          faces_brick: DO F=1,6

4025
             Face => pSolver % Mesh % Faces( Element % FaceIndexes(F) )

4026


4027
             ! Get p for face

4028
             !p = MAX(pSolver % Def_Dofs(8,BodyId,6), Face % PDefs % P)

4029
                          

4030
             ! Do not calculate face values if no dofs

4031
             !IF (GetFaceDOFs(Element, p, F)<= 0) CYCLE

4032
              

4033
             ! Generate direction vector for this face

4034
             tmp(1:4) = getBrickFaceMap(F)

4035
             direction(1:4) = getSquareFaceDirection(Element, tmp, GIndexes)

4036


4037
             ! For each face calculate the values of functions for index

4038
             ! pairs i,j=2,..,p-2 i+j=4,..,p

4039
             IF(SerendipityPBasis) THEN

4040
               DO i=2,p-2

4041
                 DO j=2,p-i

4042
                   IF ( q >= SIZE(Basis) ) EXIT faces_brick

4043


4044
                   q = q + 1

4045
                   Basis(q) = SD_BrickFacePBasis(F,i,j,u,v,w,direction)

4046
                   dLBasisdx(q,:) = SD_dBrickFacePBasis(F,i,j,u,v,w,direction)

4047
                   IF (Compute2ndDerivatives) THEN

4048
                     ddLBasisddx(q,:,:) = SD_ddBrickFacePBasis(F,i,j,u,v,w,direction)

4049
                   END IF

4050
                   ! Polynomial degree of basis function to vector

4051
                   IF (degrees) BasisDegree(q) = i+j

4052
                  END DO

4053
               END DO

4054
             ELSE

4055
               DO i=0,p-2

4056
                 DO j=0,p-2

4057
                   IF ( q >= SIZE(Basis) ) EXIT faces_brick

4058
 

4059
                   q = q + 1

4060
                   Basis(q) = BrickFacePBasis(F,i,j,u,v,w,direction)

4061
                   dLBasisdx(q,:) = dBrickFacePBasis(F,i,j,u,v,w,direction)

4062
                   IF (Compute2ndDerivatives) THEN

4063
                     ddLBasisddx(q,:,:) = ddBrickFacePBasis(F,i,j,u,v,w,direction)

4064
                   END IF

4065
                   ! Polynomial degree of basis function to vector

4066
                   IF (degrees) BasisDegree(q) = 2+i+j

4067
                 END DO

4068
               END DO

4069
             END IF

4070
          END DO faces_brick

4071
        END IF

4072


4073
        ! Bubbles of p brick

4074
        nb = pSolver % Def_Dofs(8,BodyId,5)

4075
        BDOFs = MAX(GetBubbleDOFs(Element, p), nb) 

4076
        IF ( BDOFs > 0 ) THEN

4077
          p = getEffectiveBubbleP(element,p,bdofs)

4078


4079
          IF(SerendipityPBasis) THEN

4080
            SD_bubbles_brick: DO i=2,p-4

4081
              DO j=2,p-i-2

4082
                DO k=2,p-i-j

4083
                   IF ( q >= SIZE(Basis)) EXIT SD_bubbles_brick

4084
                   q = q + 1

4085


4086
                   Basis(q) = SD_BrickBubblePBasis(i,j,k,u,v,w)

4087
                   dLBasisdx(q,:) = SD_dBrickBubblePBasis(i,j,k,u,v,w)

4088
                   IF (Compute2ndDerivatives) THEN

4089
                     ddLBasisddx(q,:,:) = SD_ddBrickBubblePBasis(i,j,k,u,v,w)

4090
                   END IF

4091
                    

4092
                   ! Polynomial degree of basis function to vector

4093
                   IF (degrees) BasisDegree(q) = i+j+k

4094
                END DO

4095
              END DO

4096
            END DO SD_bubbles_brick

4097
          ELSE 

4098
            bubbles_brick: DO i=0,p-2

4099
              DO j=0,p-2

4100
                DO k=0,p-2

4101
                  IF ( q >= SIZE(Basis)) EXIT bubbles_brick

4102
                  q = q + 1

4103


4104
                   Basis(q) = BrickBubblePBasis(i,j,k,u,v,w)

4105
                   dLBasisdx(q,:) = dBrickBubblePBasis(i,j,k,u,v,w)

4106
                   IF (Compute2ndDerivatives) THEN

4107
                     ddLBasisddx(q,:,:) = ddBrickBubblePBasis(i,j,k,u,v,w)

4108
                   END IF

4109
                    

4110
                   ! Polynomial degree of basis function to vector

4111
                   IF (degrees) BasisDegree(q) = 2+i+j+k

4112
                END DO

4113
              END DO

4114
            END DO bubbles_brick

4115
          END IF

4116
        END IF

4117


4118
     END SELECT

4119
     END IF ! P element flag check

4120
!------------------------------------------------------------------------------

4121


4122


4123
     ! Element (contravariant) metric and square root of determinant

4124
     !--------------------------------------------------------------

4125
#ifdef HAVE_QP

4126
     IF(Element % Status==0) THEN

4127
       stat = CheckMetric(q, Element, Nodes, dLBasisdx)

4128
       IF (stat) THEN

4129
         Element % Status = 1 ! good!!

4130
       ELSE

4131
         Element % Status = 2 ! bad !!

4132
       END IF

4133
     END IF

4134
#endif

4135


4136
     stat = .TRUE.

4137
     IF ( .NOT. ElementMetric( q, Element, Nodes, &

4138
           ElmMetric, detJ, dLBasisdx, LtoGMap ) ) THEN

4139
        stat = .FALSE.

4140
        RETURN

4141
     END IF

4142


4143
     ! Get global first derivatives:

4144
     !------------------------------

4145
     IF ( PRESENT(dBasisdx) ) THEN

4146
       dBasisdx = 0.0d0

4147
       DO i=1,q

4148
         DO j=1,cdim

4149
            DO k=1,dim

4150
              dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LtoGMap(j,k)

4151
            END DO

4152
         END DO

4153
       END DO

4154
     END IF

4155


4156
     ! Get matrix of second derivatives, if needed:

4157
     !---------------------------------------------

4158
     IF ( Compute2ndDerivatives ) THEN

4159
       CALL GlobalSecondDerivatives(Element,Nodes, &

4160
           ddBasisddx,u,v,w,ElmMetric,dLBasisdx,ddLBasisddx,q )

4161
     END IF

4162


4163
!------------------------------------------------------------------------------

4164
!    Generate bubble basis functions, if requested. Bubble basis is as follows:

4165
!    B_i (=(N_(i+n)) = B * N_i, where N_i:s are the nodal basis functions of

4166
!    the element, and B the basic bubble, i.e. the product of nodal basis

4167
!    functions of the corresponding linear element for triangles and tetras,

4168
!    and product of two diagonally opposed nodal basisfunctions of the

4169
!    corresponding (bi-,tri-)linear element for 1d-elements, quads and hexas.

4170
!------------------------------------------------------------------------------

4171
     IF ( PRESENT( Bubbles ) .AND. .NOT. isActivePElement(Element,pSolver)) THEN

4172
       Bubble % BDOFs = 0

4173
       NULLIFY( Bubble % PDefs )

4174
       NULLIFY( Bubble % EdgeIndexes )

4175
       NULLIFY( Bubble % FaceIndexes )

4176
       NULLIFY( Bubble % BubbleIndexes )

4177


4178
       IF ( Bubbles .AND. SIZE(Basis) >= 2*n ) THEN

4179


4180
         SELECT CASE(Element % TYPE % ElementCode / 100)

4181
           CASE(2)

4182


4183
              IF ( Element % TYPE % ElementCode == 202 ) THEN

4184
                LinBasis(1:n) = Basis(1:n)

4185
                dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim)

4186
              ELSE

4187
                Bubble % TYPE => GetElementType(202)

4188


4189
                stat = ElementInfo( Bubble, nodes, u, v, w, detJ, &

4190
                          LinBasis, dLinBasisdx )

4191
              END IF

4192


4193
              BubbleValue = LinBasis(1) * LinBasis(2)

4194


4195
              DO i=1,n

4196
                Basis(n+i) = Basis(i) * BubbleValue

4197
                DO j=1,cdim

4198
                  dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue

4199


4200
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4201
                       dLinBasisdx(1,j) * LinBasis(2)

4202


4203
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4204
                       dLinBasisdx(2,j) * LinBasis(1)

4205
                END DO

4206
              END DO

4207


4208
           CASE(3)

4209


4210
              IF ( Element % TYPE % ElementCode == 303 ) THEN

4211
                LinBasis(1:n) = Basis(1:n)

4212
                dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim)

4213
              ELSE

4214
                Bubble % TYPE => GetElementType(303)

4215


4216
                stat = ElementInfo( Bubble, nodes, u, v, w, detJ, &

4217
                            LinBasis, dLinBasisdx )

4218
              END IF

4219
  

4220
              BubbleValue = LinBasis(1) * LinBasis(2) * LinBasis(3)

4221


4222
              DO i=1,n

4223
                Basis(n+i) = Basis(i) * BubbleValue

4224
                DO j=1,cdim

4225
                  dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue

4226


4227
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4228
                       dLinBasisdx(1,j) * LinBasis(2) * LinBasis(3)

4229


4230
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4231
                       dLinBasisdx(2,j) * LinBasis(1) * LinBasis(3)

4232


4233
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4234
                       dLinBasisdx(3,j) * LinBasis(1) * LinBasis(2)

4235
                END DO

4236
              END DO

4237


4238
           CASE(4)

4239


4240
              IF ( Element % TYPE % ElementCode == 404 ) THEN

4241
                LinBasis(1:n) = Basis(1:n)

4242
                dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim)

4243
              ELSE

4244
                Bubble % TYPE => GetElementType(404)

4245


4246
                stat = ElementInfo( Bubble, nodes, u, v, w, detJ, &

4247
                             LinBasis, dLinBasisdx )

4248
              END IF

4249


4250
              BubbleValue = LinBasis(1) * LinBasis(3)

4251


4252
              DO i=1,n

4253
                Basis(n+i) = Basis(i) * BubbleValue

4254
                DO j=1,cdim

4255
                  dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue

4256


4257
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4258
                         dLinBasisdx(1,j) * LinBasis(3)

4259


4260
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4261
                         dLinBasisdx(3,j) * LinBasis(1)

4262
                END DO

4263
              END DO

4264


4265
           CASE(5)

4266


4267
              IF ( Element % TYPE % ElementCode == 504 ) THEN

4268
                LinBasis(1:n) = Basis(1:n)

4269
                dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim)

4270
              ELSE

4271
                Bubble % TYPE => GetElementType(504)

4272


4273
                stat = ElementInfo( Bubble, nodes, u, v, w, detJ, &

4274
                            LinBasis, dLinBasisdx )

4275
              END IF

4276


4277
              BubbleValue = LinBasis(1) * LinBasis(2) * LinBasis(3) * LinBasis(4)

4278
              DO i=1,n

4279
                Basis(n+i) = Basis(i) * BubbleValue

4280
                DO j=1,cdim

4281
                  dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue

4282


4283
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(1,j) * &

4284
                                    LinBasis(2) * LinBasis(3) * LinBasis(4)

4285


4286
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(2,j) * &

4287
                                    LinBasis(1) * LinBasis(3) * LinBasis(4)

4288


4289
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(3,j) * &

4290
                                    LinBasis(1) * LinBasis(2) * LinBasis(4)

4291


4292
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * dLinBasisdx(4,j) * &

4293
                                    LinBasis(1) * LinBasis(2) * LinBasis(3)

4294
                END DO

4295
              END DO

4296


4297
           CASE(8)

4298


4299
              IF ( Element % TYPE % ElementCode == 808 ) THEN

4300
                LinBasis(1:n) = Basis(1:n)

4301
                dLinBasisdx(1:n,1:cdim) = dBasisdx(1:n,1:cdim)

4302
              ELSE

4303
                Bubble % TYPE => GetElementType(808)

4304


4305
                stat = ElementInfo( Bubble, nodes, u, v, w, detJ, &

4306
                  LinBasis, dLinBasisdx )

4307
              END IF

4308


4309
              BubbleValue = LinBasis(1) * LinBasis(7)

4310


4311
              DO i=1,n

4312
                Basis(n+i) = Basis(i) * BubbleValue

4313
                DO j=1,cdim

4314
                  dBasisdx(n+i,j) = dBasisdx(i,j) * BubbleValue

4315


4316
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4317
                        dLinBasisdx(1,j) * LinBasis(7)

4318


4319
                  dBasisdx(n+i,j) = dBasisdx(n+i,j) + Basis(i) * &

4320
                        dLinBasisdx(7,j) * LinBasis(1)

4321
                END DO

4322
              END DO

4323


4324
         CASE DEFAULT

4325
 

4326
              WRITE( Message, '(a,i4,a)' ) 'Bubbles for element: ', &

4327
               Element % TYPE % ElementCode, ' are not implemented.'

4328
              CALL Error( 'ElementInfo', Message )

4329
              CALL Fatal( 'ElementInfo', 'Please use p-element basis instead.' )

4330


4331
         END SELECT

4332
       END IF

4333
     END IF

4334
!------------------------------------------------------------------------------

4335
   END FUNCTION ElementInfo

4336
!------------------------------------------------------------------------------

4337
   

4338
   ! SUBROUTINE ElementInfoVec_InitWork(m, n)

4339
   !   IMPLICIT NONE

4340


4341
   !   INTEGER, INTENT(IN) :: m, n

4342
   !   INTEGER :: allocstat

4343


4344
   !   allocstat = 0

4345
   !   IF (.NOT. ALLOCATED(BasisWrk)) THEN

4346
   !     ALLOCATE(BasisWrk(m,n), &

4347
   !             dBasisdxWrk(m,n,3), &

4348
   !             LtoGMapsWrk(m,3,3), &

4349
   !             DetJWrk(m), &

4350
   !             uWrk(m), vWrk(m), wWrk(m), STAT=allocstat)

4351
   !   ELSE IF (SIZE(BasisWrk,1) /= m .OR. SIZE(BasisWrk,2) /= n) THEN

4352
   !     DEALLOCATE(BasisWrk, dBasisdxWrk, LtoGMapsWrk, DetJWrk, uWrk, vWrk, wWrk)

4353
   !     ALLOCATE(BasisWrk(m,n), &

4354
   !             dBasisdxWrk(m,n,3), &

4355
   !             LtoGMapsWrk(m,3,3), &

4356
   !             DetJWrk(m), &

4357
   !             uWrk(m), vWrk(m), wWrk(m), STAT=allocstat)

4358
   !   END IF

4359


4360
   !   ! Check memory allocation status

4361
   !   IF (allocstat /= 0) THEN

4362
   !     CALL Error('ElementInfo_InitWork','Storage allocation for local element basis failed')

4363
   !   END IF

4364
   ! END SUBROUTINE ElementInfoVec_InitWork

4365


4366
   ! SUBROUTINE ElementInfoVec_FreeWork()

4367
   !   IMPLICIT NONE

4368


4369
   !   IF (ALLOCATED(BasisWrk)) THEN

4370
   !     DEALLOCATE(BasisWrk, dBasisdxWrk, LtoGMapsWrk, DetJWrk, uWrk, vWrk, wWrk)

4371
   !   END IF

4372
   ! END SUBROUTINE ElementInfoVec_FreeWork

4373


4374
!

4375
!------------------------------------------------------------------------------

4376
   FUNCTION ElementInfoVec( Element, Nodes, nc, u, v, w, detJ, nbmax, &

4377
               Basis, dBasisdx, USolver ) RESULT(retval)

4378
!------------------------------------------------------------------------------

4379
     IMPLICIT NONE

4380


4381
     TYPE(Element_t), TARGET :: Element    !< Element structure

4382
     TYPE(Nodes_t)   :: Nodes              !< Element nodal coordinates.

4383
     INTEGER, INTENT(IN) :: nc             !< Number of local coordinates to compute values of the basis function

4384
     REAL(KIND=dp), POINTER CONTIG :: u(:)  !< 1st local coordinates at which to calculate the basis function.

4385
     REAL(KIND=dp), POINTER CONTIG :: v(:)  !< 2nd local coordinates.

4386
     REAL(KIND=dp), POINTER CONTIG :: w(:)  !< 3rd local coordinates.

4387
     REAL(KIND=dp) CONTIG, INTENT(OUT) :: detJ(:) !< Square roots of determinants of element coordinate system metric at coordinates

4388
     INTEGER, INTENT(IN) :: nbmax          !< Maximum number of basis functions to compute

4389
     REAL(KIND=dp) CONTIG :: Basis(:,:)    !< Basis function values at (u,v,w)

4390
     REAL(KIND=dp) CONTIG, OPTIONAL :: dBasisdx(:,:,:)    !< Global first derivatives of basis functions at (u,v,w)

4391
     TYPE(Solver_t), TARGET, OPTIONAL :: USolver

4392
     LOGICAL :: retval                             !< If .FALSE. element is degenerate. or if local storage allocation fails

4393


4394
     ! Internal work arrays (always needed)

4395
     REAL(KIND=dp) :: uWrk(VECTOR_BLOCK_LENGTH), vWrk(VECTOR_BLOCK_LENGTH), wWrk(VECTOR_BLOCK_LENGTH)

4396
     REAL(KIND=dp) :: BasisWrk(VECTOR_BLOCK_LENGTH,nbmax)

4397
     REAL(KIND=dp) :: dBasisdxWrk(VECTOR_BLOCK_LENGTH,nbmax,3)

4398
     REAL(KIND=dp) :: DetJWrk(VECTOR_BLOCK_LENGTH)

4399
     REAL(KIND=dp) :: LtoGMapsWrk(VECTOR_BLOCK_LENGTH,3,3)

4400


4401
     TYPE(Solver_t), POINTER :: pSolver

4402
     

4403
     INTEGER :: i, l, n, dim, cdim, ll, ncl, lln

4404
     LOGICAL :: elem

4405
!DIR$ ATTRIBUTES ALIGN:64::uWrk, vWrk, wWrk, BasisWrk, dBasisdxWrk, DetJWrk, LtoGMapsWrk

4406
     

4407
     !------------------------------------------------------------------------------

4408
     ! Special case, Element: POINT

4409
     IF (Element % TYPE % ElementCODE == 101) THEN

4410
       DetJ(1:nc) = REAL(1, dp)

4411
       Basis(1:nc,1) = REAL(1, dp)

4412
       IF (PRESENT(dBasisdx)) THEN

4413
         DO i=1,nc

4414
           dBasisdx(i,1,1) = REAL(0, dp)

4415
         END DO

4416
       END IF

4417
       retval = .TRUE.

4418
       RETURN

4419
     END IF

4420
     

4421
     ! Set up workspace arrays 

4422
     ! CALL ElementInfoVec_InitWork(VECTOR_BLOCK_LENGTH, nbmax)

4423
     IF ( nbmax < Element % TYPE % NumberOfNodes ) THEN

4424
       CALL Fatal('ElementInfoVec','Not enough storage to compute local element basis')

4425
     END IF

4426


4427
     IF(PRESENT(dBasisdx))  &

4428
       dBasisdx = 0._dp ! avoid uninitialized stuff depending on coordinate dimension...

4429


4430
     IF( isActivePelement(Element) ) THEN

4431
       retval =  ElementInfoVec_ComputePElementBasis(Element,Nodes,nc,u,v,w,detJ,nbmax,Basis,&

4432
             uWrk,vWrk,wWrk,BasisWrk,dBasisdxWrk,DetJWrk,LtoGmapsWrk,dBasisdx,USolver)

4433
     ELSE

4434
       retval = .TRUE.

4435
       n    = Element % TYPE % NumberOfNodes

4436
       dim  = Element % TYPE % DIMENSION

4437
       cdim = CoordinateSystemDimension()

4438


4439
       DO ll=1,nc,VECTOR_BLOCK_LENGTH

4440
         lln = MIN(ll+VECTOR_BLOCK_LENGTH-1,nc)

4441
         ncl = lln-ll+1

4442


4443
         ! Block copy input

4444
         uWrk(1:ncl) = u(ll:lln)

4445
         IF (cdim > 1) THEN

4446
           vWrk(1:ncl) = v(ll:lln)

4447
         END IF

4448
         IF (cdim > 2) THEN

4449
           wWrk(1:ncl) = w(ll:lln)

4450
         END IF

4451


4452
         DO l=1,ncl

4453
           CALL NodalBasisFunctions(n, Basis(l,:), element, uWrk(l), vWrk(l), wWrk(l))

4454
           CALL NodalFirstDerivatives(n, dBasisdxWrk(l,:,:), element, uWrk(l), vWrk(l), wWrk(l))

4455
           !--------------------------------------------------------------

4456
         END DO

4457


4458
         ! Element (contravariant) metric and square root of determinant

4459
         !--------------------------------------------------------------

4460
         elem = ElementMetricVec( Element, Nodes, ncl, n, DetJWrk, &

4461
                nbmax, dBasisdxWrk, LtoGMapsWrk )

4462


4463
         IF (.NOT. elem) THEN

4464
           retval = .FALSE.

4465
           RETURN

4466
           END IF

4467


4468
         !_ELMER_OMP_SIMD

4469
         DO i=1,ncl

4470
           DetJ(i+ll-1)=DetJWrk(i)

4471
         END DO

4472


4473
         ! Get global basis functions

4474
         !--------------------------------------------------------------

4475
         ! First derivatives

4476
         IF (PRESENT(dBasisdx)) THEN

4477
!DIR$ FORCEINLINE

4478
           CALL ElementInfoVec_ElementBasisToGlobal(ncl, n, nbmax, dBasisdxWrk, dim, cdim, LtoGMapsWrk, ll, dBasisdx)

4479
         END IF

4480
       END DO

4481
     END IF

4482
   END FUNCTION ElementInfoVec

4483
     

4484
   FUNCTION ElementInfoVec_ComputePElementBasis(Element, Nodes, nc, u, v, w, DetJ, nbmax, Basis, &

4485
      uWrk, vWrk, wWrk, BasisWrk, dBasisdxWrk, DetJWrk, LtoGmapsWrk, dBasisdx, USolver) RESULT(retval)

4486
     IMPLICIT NONE

4487
     TYPE(Element_t), TARGET :: Element    !< Element structure

4488
     TYPE(Nodes_t)   :: Nodes              !< Element nodal coordinates.

4489
     INTEGER, INTENT(IN) :: nc             !< Number of local coordinates to compute values of the basis function

4490
     REAL(KIND=dp), POINTER CONTIG :: u(:)  !< 1st local coordinates at which to calculate the basis function.

4491
     REAL(KIND=dp), POINTER CONTIG :: v(:)  !< 2nd local coordinates.

4492
     REAL(KIND=dp), POINTER CONTIG :: w(:)  !< 3rd local coordinates.

4493
     REAL(KIND=dp) CONTIG, INTENT(OUT) :: detJ(:) !< Square roots of determinants of element coordinate system metric at coordinates

4494
     INTEGER, INTENT(IN) :: nbmax          !< Maximum number of basis functions to compute

4495
     REAL(KIND=dp) CONTIG :: Basis(:,:)    !< Basis function values at (u,v,w)

4496
     ! Internal work arrays

4497
     REAL(KIND=dp) :: uWrk(VECTOR_BLOCK_LENGTH), vWrk(VECTOR_BLOCK_LENGTH), wWrk(VECTOR_BLOCK_LENGTH)

4498
     REAL(KIND=dp) :: BasisWrk(VECTOR_BLOCK_LENGTH,nbmax)

4499
     REAL(KIND=dp) :: dBasisdxWrk(VECTOR_BLOCK_LENGTH,nbmax,3)

4500
     REAL(KIND=dp) :: DetJWrk(VECTOR_BLOCK_LENGTH)

4501
     REAL(KIND=dp) :: LtoGMapsWrk(VECTOR_BLOCK_LENGTH,3,3)

4502
     REAL(KIND=dp) CONTIG, OPTIONAL :: dBasisdx(:,:,:)    !< Global first derivatives of basis functions at (u,v,w)

4503
     TYPE(Solver_t), TARGET, OPTIONAL :: USolver

4504
     LOGICAL :: retval                    !< If .FALSE. element is degenerate. or if local storage allocation fails

4505


4506


4507
     !------------------------------------------------------------------------------

4508
     !    Local variables

4509
     !------------------------------------------------------------------------------

4510
     INTEGER :: EdgeDegree(H1Basis_MaxPElementEdges), &

4511
           FaceDegree(H1Basis_MaxPElementFaces), &

4512
           EdgeDirection(H1Basis_MaxPElementEdgeNodes,H1Basis_MaxPElementEdges), &

4513
           FaceDirection(H1Basis_MaxPElementFaceNodes,H1Basis_MaxPElementFaces)

4514


4515
     INTEGER :: cdim, dim, i, j, k, l, ll, lln, ncl, ip, n, p, nb, bdofs, &

4516
           nbp, nbq, nbdxp, allocstat, ncpad, EdgeMaxDegree, FaceMaxDegree, BodyId

4517


4518
     TYPE(Solver_t), POINTER :: pSolver

4519
     TYPE(Element_t), POINTER :: Parent

4520


4521
     LOGICAL :: invertBubble, elem, SerendipityPBasis

4522
 

4523
!DIR$ ATTRIBUTES ALIGN:64::EdgeDegree, FaceDegree

4524
!DIR$ ATTRIBUTES ALIGN:64::EdgeDirection, FaceDirection

4525
!DIR$ ASSUME_ALIGNED uWrk:64, vWrk:64, wWrk:64, BasisWrk:64, dBasisdxWrk:64, DetJWrk:64, LtoGMapsWrk:64

4526


4527
     IF( PRESENT( USolver ) ) THEN

4528
       pSolver => USolver

4529
     ELSE

4530
       pSolver => CurrentModel % Solver

4531
     END IF

4532


4533
     BodyId = Element % BodyId

4534
     IF( isActivePElement(Element)) THEN

4535
       IF (BodyId==0 .AND. ASSOCIATED(Element % BoundaryInfo)) THEN

4536
         Parent => Element % PDefs % LocalParent

4537
         IF(ASSOCIATED(Parent)) BodyId = Parent % BodyId

4538
       END IF

4539
       SerendipityPBasis = Element % PDefs % Serendipity

4540
     ELSE

4541
       IF (BodyId==0 .AND. ASSOCIATED(Element % BoundaryInfo)) THEN

4542
         Parent => Element % BoundaryInfo % Left

4543
         IF(ASSOCIATED(Parent)) BodyId = Parent % BodyId

4544
       END IF

4545
     END IF

4546


4547
     IF (BodyId==0) THEN

4548
       CALL Warn('ElementInfoVec', 'Element '//I2S(Element % ElementIndex)//' of type '//&

4549
           I2S(Element % TYPE % ElementCode)//' has 0 BodyId, assuming index 1')

4550
       BodyId = 1

4551
     END IF

4552


4553
     retval = .TRUE.

4554
     n    = Element % TYPE % NumberOfNodes

4555
     dim  = Element % TYPE % DIMENSION

4556
     cdim = CoordinateSystemDimension()

4557


4558
     dBasisdxWrk = 0._dp ! avoid uninitialized stuff depending on coordinate dimension...

4559


4560
     ! Block the computation for large values of input points

4561
     DO ll=1,nc,VECTOR_BLOCK_LENGTH

4562
       lln = MIN(ll+VECTOR_BLOCK_LENGTH-1,nc)

4563
       ncl = lln-ll+1

4564


4565
       ! Set number of computed basis functions

4566
       nbp = 0

4567
       nbdxp = 0

4568


4569
       ! Block copy input

4570
       uWrk(1:ncl) = u(ll:lln)

4571
       IF (cdim > 1) THEN

4572
         vWrk(1:ncl) = v(ll:lln)

4573
       END IF

4574
       IF (cdim > 2) THEN

4575
         wWrk(1:ncl) = w(ll:lln)

4576
       END IF

4577


4578
       ! Compute local p element basis

4579
       SELECT CASE (Element % Type % ElementCode)

4580
         ! Element: LINE

4581
       CASE (202)

4582
         ! Compute nodal basis

4583
         CALL H1Basis_LineNodal(ncl, uWrk, nbmax, BasisWrk, nbp)

4584
         ! Compute local first derivatives

4585
         CALL H1Basis_dLineNodal(ncl, uWrk, nbmax, dBasisdxWrk, nbdxp)

4586


4587
         ! Element bubble functions

4588
         p = pSolver % Def_Dofs(2,BodyId,6)

4589
         nb = pSolver % Def_Dofs(2,BodyId,5)

4590
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

4591


4592
         IF (BDOFs > 0) THEN

4593
           p = getEffectiveBubbleP(element,p,bdofs)

4594


4595
           ! For first round of blocked loop, compute edge direction

4596
           IF (ll==1) THEN

4597
             IF (Element % PDefs % isEdge .AND. &

4598
                   Element % NodeIndexes(1)> Element % NodeIndexes(2)) THEN

4599
               invertBubble = .TRUE.

4600
             ELSE

4601
               invertBubble = .FALSE.

4602
             END IF

4603
           END IF

4604


4605
           CALL H1Basis_LineBubbleP(ncl, uWrk, P, nbmax, BasisWrk, nbp, invertBubble)

4606
           CALL H1Basis_dLineBubbleP(ncl, uWrk, P, nbmax, dBasisdxWrk, nbdxp, invertBubble)

4607
         END IF

4608


4609
         ! Element: TRIANGLE

4610
       CASE (303)

4611
         ! Compute nodal basis

4612
         CALL H1Basis_TriangleNodalP(ncl, uWrk, vWrk, nbmax, BasisWrk, nbp)

4613
         ! Compute local first derivatives

4614
         CALL H1Basis_dTriangleNodalP(ncl, uWrk, vWrk, nbmax, dBasisdxWrk, nbdxp)

4615


4616
         IF (ASSOCIATED( Element % EdgeIndexes)) THEN

4617
           ! For first round of blocked loop, compute polynomial degrees and 

4618
           ! edge directions

4619
           IF (ll==1) THEN

4620
             CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, &

4621
                   Element, EdgeDegree, EdgeDirection, EdgeMaxDegree)

4622
           END IF

4623


4624
           ! Compute basis function values

4625
           IF (EdgeMaxDegree>1 ) THEN

4626
             nbq = nbp + SUM(EdgeDegree(1:3)-1)

4627
             IF(nbmax >= nbq ) THEN

4628
               CALL H1Basis_TriangleEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, BasisWrk, &

4629
                     nbp, EdgeDirection)

4630
               CALL H1Basis_dTriangleEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, dBasisdxWrk, &

4631
                     nbdxp, EdgeDirection)

4632
             END IF

4633
           END IF

4634
         END IF

4635


4636
         ! Element bubble functions

4637
         p = pSolver % Def_Dofs(3,BodyId,6)

4638
         nb = pSolver % Def_Dofs(3,BodyId,5)

4639
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

4640


4641
         IF (BDOFs > 0) THEN

4642
           p = getEffectiveBubbleP(element,p,bdofs)

4643


4644
           ! For first round of blocked loop, compute polynomial degrees and 

4645
           ! edge directions

4646
           IF (ll==1) THEN

4647
             IF (Element % PDefs % isEdge) THEN

4648
               ! Get 2D face direction

4649
               CALL H1Basis_GetFaceDirection(Element % Type % ElementCode, &

4650
                     1, Element % NodeIndexes, FaceDirection)

4651
             END IF

4652
           END IF

4653
           IF (Element % PDefs % isEdge) THEN

4654
             CALL H1Basis_TriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp, &

4655
                   FaceDirection(1:3,1))

4656
             CALL H1Basis_dTriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp, &

4657
                   FaceDirection(1:3,1))

4658
           ELSE

4659
             CALL H1Basis_TriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp)

4660
             CALL H1Basis_dTriangleBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp)

4661
           END IF

4662
         END IF

4663


4664
         ! QUADRILATERAL

4665
       CASE (404)

4666
         ! Compute nodal basis

4667
         CALL H1Basis_QuadNodal(ncl, uWrk, vWrk, nbmax, BasisWrk, nbp)

4668
         ! Compute local first derivatives

4669
         CALL H1Basis_dQuadNodal(ncl, uWrk, vWrk, nbmax, dBasisdxWrk, nbdxp)

4670


4671
         IF (ASSOCIATED( Element % EdgeIndexes )) THEN

4672
           ! For first round of blocked loop, compute polynomial degrees and 

4673
           ! edge directions

4674
           IF (ll==1) THEN

4675
             CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, &

4676
                   Element, EdgeDegree, EdgeDirection, EdgeMaxDegree)

4677
           END IF

4678


4679
           ! Compute basis function values

4680
           IF (EdgeMaxDegree > 1) THEN

4681
             nbq = nbp + SUM(EdgeDegree(1:4)-1)

4682
             IF(nbmax >= nbq) THEN

4683
               IF(SerendipityPBasis) THEN

4684
                 CALL H1Basis_SD_QuadEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

4685
                       EdgeDirection)

4686
                 CALL H1Basis_SD_dQuadEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

4687
                       EdgeDirection)

4688
               ELSE

4689
                 CALL H1Basis_QuadEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

4690
                       EdgeDirection)

4691
                 CALL H1Basis_dQuadEdgeP(ncl, uWrk, vWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

4692
                       EdgeDirection)

4693
               END IF

4694
             END IF

4695
           END IF

4696
         END IF

4697


4698
         ! Element bubble functions

4699
         p = pSolver % Def_Dofs(4,BodyId,6)

4700
         nb = pSolver % Def_Dofs(4,BodyId,5)

4701
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

4702


4703
         IF (BDOFs > 0) THEN

4704
           p = getEffectiveBubbleP(element,p,bdofs)

4705


4706
           IF(nbmax-nbp<getBubbleDOFs(Element,p)) THEN

4707
             IF(SerendipityPBasis) THEN

4708
               CALL Fatal("ElementInfoVec", &

4709
                 "Not enough space for storing bubble basis, check your #bubbles: i*(i-1)/2 (0,1,3,6,10,15,...)")

4710
             ELSE

4711
               CALL Fatal("ElementInfoVec", &

4712
                 "Not enough space for storing bubble basis, check your #bubbles: i^2 (0,1,4,9,16,25,...)")

4713
             END IF

4714
           END IF

4715


4716
           ! For first round of blocked loop, compute polynomial degrees and 

4717
           ! edge directions

4718
           IF (ll==1) THEN

4719
             IF (Element % PDefs % isEdge) THEN

4720
               ! Get 2D face direction

4721
               CALL H1Basis_GetFaceDirection(Element % Type % ElementCode, &

4722
                     1,  Element % NodeIndexes,  FaceDirection)

4723
             END IF

4724
           END IF

4725


4726
           IF (Element % PDefs % isEdge) THEN

4727
             IF(SerendipityPBasis) THEN

4728
               CALL H1Basis_SD_QuadBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp, &

4729
                     FaceDirection(1:4,1))

4730
               CALL H1Basis_SD_dQuadBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp, &

4731
                     FaceDirection(1:4,1))

4732
             ELSE

4733
               CALL H1Basis_QuadBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp, &

4734
                     FaceDirection(1:4,1))

4735
               CALL H1Basis_dQuadBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp, &

4736
                     FaceDirection(1:4,1))

4737
             END IF

4738
           ELSE

4739
             IF(SerendipityPBasis) THEN

4740
               CALL H1Basis_SD_QuadBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp)

4741
               CALL H1Basis_SD_dQuadBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp)

4742
             ELSE

4743
               CALL H1Basis_QuadBubbleP(ncl, uWrk, vWrk, P, nbmax, BasisWrk, nbp)

4744
               CALL H1Basis_dQuadBubbleP(ncl, uWrk, vWrk, P, nbmax, dBasisdxWrk, nbdxp)

4745
             END IF

4746
           END IF

4747
         END IF

4748


4749
         ! TETRAHEDRON

4750
       CASE (504)

4751
         ! Compute nodal basis

4752
         CALL H1Basis_TetraNodalP(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp)

4753


4754
         ! Compute local first derivatives

4755
         CALL H1Basis_dTetraNodalP(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp)

4756


4757
         IF (ASSOCIATED( Element % EdgeIndexes )) THEN

4758
           ! For first round of blocked loop, compute polynomial degrees and 

4759
           ! edge directions

4760
           IF (ll==1) THEN

4761
             ! Get polynomial degree of each edge

4762
             EdgeMaxDegree = 0

4763
             IF( CurrentModel % Solver % Mesh % MaxEdgeDofs == 0 ) THEN

4764
               CONTINUE             

4765
             ELSE

4766
               DO i=1,6

4767
                 EdgeDegree(i) = CurrentModel % Solver % &

4768
                       Mesh % Edges( Element % EdgeIndexes(i) ) % BDOFs + 1

4769
                 EdgeMaxDegree = MAX(EdgeDegree(i),EdgeMaxDegree)

4770
               END DO

4771
             END IF

4772


4773
             ! Tetrahedral directions are enforced by tetra element types

4774
             IF (EdgeMaxDegree > 1) THEN

4775
               CALL H1Basis_GetTetraEdgeDirection(Element % PDefs % TetraType, EdgeDirection)

4776
             END IF

4777
           END IF

4778


4779
           ! Compute basis function values

4780
           IF (EdgeMaxDegree > 1) THEN

4781
             nbq = nbp + SUM(EdgeDegree(1:6)-1)

4782
             IF(nbmax >= nbq) THEN

4783
               CALL H1Basis_TetraEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

4784
                     EdgeDirection)

4785
               CALL H1Basis_dTetraEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

4786
                     EdgeDirection)

4787
             END IF

4788
           END IF

4789
         END IF

4790


4791
         IF (ASSOCIATED( Element % FaceIndexes )) THEN

4792
           ! For first round of blocked loop, compute polynomial degrees and 

4793
           ! face directions

4794
           IF (ll==1) THEN

4795
             ! Get polynomial degree of each face

4796
             FaceMaxDegree = 0

4797


4798
             IF( CurrentModel % Solver % Mesh % MaxFaceDofs == 0 ) THEN

4799
               CONTINUE             

4800
             ELSE IF (CurrentModel % Solver % Mesh % MinFaceDOFs == &

4801
                   CurrentModel % Solver % Mesh % MaxFaceDOFs) THEN

4802
               FaceMaxDegree = CurrentModel % Solver % Mesh % Faces( Element % FaceIndexes(1) ) % PDefs % P

4803
               FaceDegree(1:Element % Type % NumberOfFaces) = FaceMaxDegree

4804
             ELSE

4805
               DO i=1,4

4806
                 IF (CurrentModel % Solver % Mesh % &

4807
                       Faces( Element % FaceIndexes(i) ) % BDOFs /= 0) THEN

4808
                   FaceDegree(i) = CurrentModel % Solver % Mesh % &

4809
                         Faces( Element % FaceIndexes(i) ) % PDefs % P

4810
                   FaceMaxDegree = MAX(FaceDegree(i), FaceMaxDegree)

4811
                 ELSE

4812
                   FaceDegree(i) = 0

4813
                 END IF

4814
               END DO

4815
             END IF

4816


4817
             IF (FaceMaxDegree > 1) THEN

4818
               CALL H1Basis_GetTetraFaceDirection(Element % PDefs % TetraType, FaceDirection)

4819
             END IF

4820
           END IF

4821


4822
           ! Compute basis function values

4823
           IF (FaceMaxDegree>1 ) THEN

4824
             nbq = nbp

4825
             DO i=1,4

4826
               DO j=0,FaceDegree(i)

4827
                  nbq = nbq + MAX(FaceDegree(i)-j-2,0)

4828
               END DO

4829
             END DO

4830
  

4831
             IF (nbmax >= nbq ) THEN

4832
               CALL H1Basis_TetraFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, &

4833
                     FaceDirection)

4834
               CALL H1Basis_dTetraFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, &

4835
                     FaceDirection)

4836
             END IF

4837
           END IF

4838
         END IF

4839


4840
         ! Element bubble functions

4841
         p = pSolver % Def_Dofs(5,BodyId,6)

4842
         nb = pSolver % Def_Dofs(5,BodyId,5)

4843
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

4844
         IF (BDOFs > 0) THEN

4845
           p = getEffectiveBubbleP(element,p,bdofs)

4846
           CALL H1Basis_TetraBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp)

4847
           CALL H1Basis_dTetraBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp)

4848
         END IF

4849


4850
       ! Pyramid

4851
       CASE (605)

4852
         IF(SerendipityPBasis) THEN

4853
           CALL Fatal('ElementInfoVec', 'p-Pyramid not available for serendipity scheme, ' // &

4854
                  'please use full polynomial scheme instead.' )

4855
         END IF

4856


4857
         ! Compute nodal basis

4858
         CALL H1Basis_PyramidNodalP(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp)

4859
         ! Compute local first derivatives

4860
         CALL H1Basis_dPYramidNodalP(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp)

4861


4862
         IF (ASSOCIATED( Element % EdgeIndexes )) THEN

4863
           ! For first round of blocked loop, compute polynomial degrees and 

4864
           ! edge directions

4865
           IF (ll==1) THEN

4866
             CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, &

4867
                   Element, EdgeDegree, EdgeDirection, EdgeMaxDegree)

4868
           END IF

4869


4870
           ! Compute basis function values

4871
           IF (EdgeMaxDegree > 1)THEN

4872
             nbq = nbp+SUM(EdgeDegree(1:8)-1)

4873
             IF(nbmax >= nbq) THEN

4874
               CALL H1Basis_PyramidEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

4875
                     EdgeDirection)

4876


4877
               CALL H1Basis_dPyramidEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

4878
                     EdgeDirection)

4879
             END IF

4880
           END IF

4881
         END IF

4882


4883
         IF (ASSOCIATED( Element % FaceIndexes )) THEN

4884
           ! For first round of blocked loop, compute polynomial degrees and 

4885
           ! face directions

4886
           IF (ll==1) THEN

4887
             CALL GetElementMeshFaceInfo(CurrentModel % Solver % Mesh, &

4888
                   Element, FaceDegree, FaceDirection, FaceMaxDegree)

4889
           END IF

4890


4891
           ! Compute basis function values

4892
           IF (FaceMaxDegree > 1 ) THEN

4893
             nbq = nbp

4894
             ! Square faces

4895
             DO i=1,1

4896
               DO j=0,FaceDegree(i)-2

4897
                 nbq = nbq + MAX(FaceDegree(i)-1,0)

4898
               END DO

4899
             END DO

4900


4901
             ! Triangle faces

4902
             DO i=2,5

4903
               DO j=0,FaceDegree(i)-3

4904
                 nbq = nbq + MAX(FaceDegree(i)-j-2,0)

4905
               END DO

4906
             END DO

4907
             

4908
             IF(nbmax >= nbq) THEN

4909
               CALL H1Basis_PyramidFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, &

4910
                     FaceDirection)

4911
               CALL H1Basis_dPyramidFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, &

4912
                     FaceDirection)

4913
             END IF

4914
           END IF

4915
         END IF

4916


4917
         ! Element bubble functions

4918
         p = pSolver % Def_Dofs(6,BodyId,6)

4919
         nb = pSolver % Def_Dofs(6,BodyId,5)

4920
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

4921
         IF (BDOFs > 0) THEN

4922
           p = getEffectiveBubbleP(element,p,bdofs)

4923


4924
           CALL H1Basis_PyramidBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp)

4925
           CALL H1Basis_dPyramidBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp)

4926
         END IF

4927


4928


4929
         ! WEDGE

4930
       CASE (706)

4931
         ! Compute nodal basis

4932
         CALL H1Basis_WedgeNodalP(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp)

4933
         ! Compute local first derivatives

4934
         CALL H1Basis_dWedgeNodalP(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp)

4935


4936
         IF (ASSOCIATED( Element % EdgeIndexes )) THEN

4937
           ! For first round of blocked loop, compute polynomial degrees and 

4938
           ! edge directions

4939
           IF (ll==1) THEN

4940
             CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, &

4941
                   Element, EdgeDegree, EdgeDirection, EdgeMaxDegree)

4942
           END IF

4943


4944
           ! Compute basis function values

4945
           IF (EdgeMaxDegree > 1)THEN

4946
             nbq = nbp+SUM(EdgeDegree(1:9)-1)

4947
             IF(nbmax >= nbq) THEN

4948
               IF(SerendipityPBasis) THEN

4949
                 CALL H1Basis_SD_WedgeEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

4950
                       EdgeDirection)

4951
                 CALL H1Basis_SD_dWedgeEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

4952
                       EdgeDirection)

4953
               ELSE

4954
                 CALL H1Basis_WedgeEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

4955
                       EdgeDirection)

4956
                 CALL H1Basis_dWedgeEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

4957
                       EdgeDirection)

4958
               END IF

4959
             END IF

4960
           END IF

4961
         END IF

4962


4963
         IF (ASSOCIATED( Element % FaceIndexes )) THEN

4964
           ! For first round of blocked loop, compute polynomial degrees and 

4965
           ! face directions

4966
           IF (ll==1) THEN

4967
             CALL GetElementMeshFaceInfo(CurrentModel % Solver % Mesh, &

4968
                   Element, FaceDegree, FaceDirection, FaceMaxDegree)

4969
           END IF

4970


4971
           ! Compute basis function values

4972
           IF (FaceMaxDegree > 1 ) THEN

4973
             nbq = nbp

4974
             ! Triangle faces

4975
             DO i=1,2

4976
               DO j=0,FaceDegree(i)-3

4977
                 nbq = nbq + MAX(FaceDegree(i)-j-2,0)

4978
               END DO

4979
             END DO

4980
             ! Square faces

4981
             DO i=3,5

4982
               IF(SerendipityPBasis) THEN

4983
                 DO j=2,FaceDegree(i)-2

4984
                   nbq = nbq + MAX(FaceDegree(i)-j-1,0)

4985
                 END DO

4986
               ELSE

4987
                 DO j=0,FaceDegree(i)-2

4988
                   nbq = nbq + MAX(FaceDegree(i)-1,0)

4989
                 END DO

4990
               END IF

4991
             END DO

4992
             

4993
             IF(nbmax >= nbq) THEN

4994
               IF(SerendipityPBasis) THEN

4995
                 CALL H1Basis_SD_WedgeFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, &

4996
                       FaceDirection)

4997
                 CALL H1Basis_SD_dWedgeFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, &

4998
                       FaceDirection)

4999
               ELSE

5000
                 CALL H1Basis_WedgeFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, &

5001
                       FaceDirection)

5002
                 CALL H1Basis_dWedgeFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, &

5003
                       FaceDirection)

5004
               END IF

5005
             END IF

5006
           END IF

5007
         END IF

5008


5009
         ! Element bubble functions

5010
         p = pSolver % Def_Dofs(7,BodyId,6)

5011
         nb = pSolver % Def_Dofs(7,BodyId,5)

5012
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

5013
         IF (BDOFs > 0) THEN

5014
           p = getEffectiveBubbleP(element,p,bdofs)

5015
           IF(SerendipityPBasis) THEN

5016
             CALL H1Basis_SD_WedgeBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp)

5017
             CALL H1Basis_SD_dWedgeBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp)

5018
           ELSE

5019
             CALL H1Basis_WedgeBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp)

5020
             CALL H1Basis_dWedgeBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp)

5021
           END IF

5022
         END IF

5023


5024
         ! HEXAHEDRON

5025
       CASE (808)

5026
         ! Compute local basis

5027
         CALL H1Basis_BrickNodal(ncl, uWrk, vWrk, wWrk, nbmax, BasisWrk, nbp)

5028
         ! Compute local first derivatives

5029
         CALL H1Basis_dBrickNodal(ncl, uWrk, vWrk, wWrk, nbmax, dBasisdxWrk, nbdxp)

5030


5031
         IF (ASSOCIATED( Element % EdgeIndexes )) THEN

5032
           ! For first round of blocked loop, compute polynomial degrees and 

5033
           ! edge directions

5034
           IF (ll==1) THEN

5035
             CALL GetElementMeshEdgeInfo(CurrentModel % Solver % Mesh, &

5036
                   Element, EdgeDegree, EdgeDirection, EdgeMaxDegree)

5037
           END IF

5038


5039
           ! Compute basis function values

5040
           IF (EdgeMaxDegree > 1) THEN

5041
             nbq = nbp + SUM(EdgeDegree(1:12)-1)

5042
             IF(nbmax >= nbq) THEN

5043
               IF(SerendipityPBasis) THEN

5044
                 CALL H1Basis_SD_BrickEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

5045
                       EdgeDirection)

5046
                 CALL H1Basis_SD_dBrickEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

5047
                       EdgeDirection)

5048
               ELSE

5049
                 CALL H1Basis_BrickEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, BasisWrk, nbp, &

5050
                       EdgeDirection)

5051
                 CALL H1Basis_dBrickEdgeP(ncl, uWrk, vWrk, wWrk, EdgeDegree, nbmax, dBasisdxWrk, nbdxp, &

5052
                       EdgeDirection)

5053
              END IF

5054
             END IF

5055
           END IF

5056
         END IF

5057


5058


5059
         IF (ASSOCIATED( Element % FaceIndexes )) THEN

5060
           ! For first round of blocked loop, compute polynomial degrees and 

5061
           ! face directions

5062
           IF (ll==1) THEN

5063
             CALL GetElementMeshFaceInfo(CurrentModel % Solver % Mesh, &

5064
                   Element, FaceDegree, FaceDirection, FaceMaxDegree)

5065
           END IF

5066


5067
           ! Compute basis function values

5068
           IF (FaceMaxDegree > 1) THEN

5069
             nbq = nbp

5070
             DO i=1,6

5071
               DO j=2,FaceDegree(i)

5072
                 nbq = nbq + MAX(FaceDegree(i)-j-1,0)

5073
               END DO

5074
             END DO

5075


5076
             IF(nbmax >= nbq) THEN

5077
               IF(SerendipityPBasis) THEN

5078
                 CALL H1Basis_SD_BrickFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, &

5079
                       FaceDirection)

5080
                 CALL H1Basis_SD_dBrickFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, &

5081
                       FaceDirection)

5082
               ELSE

5083
                 CALL H1Basis_BrickFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, BasisWrk, nbp, &

5084
                       FaceDirection)

5085
                 CALL H1Basis_dBrickFaceP(ncl, uWrk, vWrk, wWrk, FaceDegree, nbmax, dBasisdxWrk, nbdxp, &

5086
                       FaceDirection)

5087
               END IF

5088
             END IF

5089
           END IF

5090
         END IF

5091


5092
         

5093
         ! Element bubble functions

5094
         p = pSolver % Def_Dofs(8,BodyId,6)

5095
         nb = pSolver % Def_Dofs(8,BodyId,5)

5096
         BDOFs = MAX(GetBubbleDOFs(Element, p), nb)

5097
         IF (BDOFs > 0) THEN

5098
           p = getEffectiveBubbleP(element,p,bdofs)

5099


5100
           IF(nbmax-nbp<getBubbleDOFs(Element,p)) THEN

5101
             IF(SerendipityPBasis) THEN

5102
               CALL Fatal("ElementInfoVec", &

5103
                 "Not enough space for storing bubble basis, check your #bubbles: i*(i-1)*(i-1)/2 (0,1,4,10,16,...)")

5104
             ELSE

5105
               CALL Fatal("ElementInfoVec", &

5106
                 "Not enough space for storing bubble basis, check your #bubbles: i^3: (0,1,8,27,64,...)")

5107
             END IF

5108
           END IF

5109


5110
           IF(SerendipityPBasis) THEN

5111
             CALL H1Basis_SD_BrickBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp)

5112
             CALL H1Basis_SD_dBrickBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp)

5113
           ELSE

5114
             CALL H1Basis_BrickBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, BasisWrk, nbp)

5115
             CALL H1Basis_dBrickBubbleP(ncl, uWrk, vWrk, wWrk, P, nbmax, dBasisdxWrk, nbdxp)

5116
           END IF

5117
         END IF

5118


5119
         

5120
       CASE DEFAULT

5121
         WRITE( Message, '(a,i4,a)' ) 'Vectorized basis for element: ', &

5122
               Element % TYPE % ElementCode, ' not implemented.'

5123
         CALL Error( 'ElementInfoVec', Message )

5124
         CALL Fatal( 'ElementInfoVec', 'ElementInfoVec is still does not include pyramids.' )

5125
       END SELECT

5126


5127
       ! Copy basis function values to global array

5128
       DO j=1,nbp

5129
         DO i=1,ncl

5130
           Basis(i+ll-1,j)=BasisWrk(i,j)

5131
         END DO

5132
       END DO

5133


5134
       !--------------------------------------------------------------

5135
       ! Element (contravariant) metric and square root of determinant

5136
       !--------------------------------------------------------------

5137
       elem = ElementMetricVec( Element, Nodes, ncl, nbp, DetJWrk, &

5138
             nbmax, dBasisdxWrk, LtoGMapsWrk )

5139
       IF (.NOT. elem) THEN

5140
         retval = .FALSE.

5141
         RETURN

5142
       END IF

5143


5144
       !_ELMER_OMP_SIMD

5145
       DO i=1,ncl

5146
         DetJ(i+ll-1)=DetJWrk(i)

5147
       END DO

5148


5149
       ! Get global basis functions

5150
       !--------------------------------------------------------------

5151
       ! First derivatives

5152
       IF (PRESENT(dBasisdx)) THEN

5153
!DIR$ FORCEINLINE

5154
         CALL ElementInfoVec_ElementBasisToGlobal(ncl, nbp, nbmax, dBasisdxWrk, dim, cdim, LtoGMapsWrk, ll, dBasisdx)

5155
       END IF

5156
     END DO ! Block over Gauss points

5157


5158
  CONTAINS

5159
   

5160
     SUBROUTINE GetElementMeshEdgeInfo(Mesh, Element, EdgeDegree, EdgeDirection, EdgeMaxDegree)

5161
       IMPLICIT NONE

5162
       

5163
       TYPE(Mesh_t), INTENT(IN) :: Mesh

5164
       TYPE(Element_t), INTENT(IN) :: Element

5165
       INTEGER, INTENT(OUT) :: EdgeDegree(H1Basis_MaxPElementEdges), &

5166
               EdgeDirection(H1Basis_MaxPElementEdgeNodes,H1Basis_MaxPElementEdges)

5167
       INTEGER, INTENT(OUT) :: EdgeMaxDegree

5168
       INTEGER :: i

5169


5170
       EdgeMaxDegree = 0

5171


5172
       IF( Mesh % MaxEdgeDofs == 0 ) THEN

5173
         CONTINUE             

5174


5175
       ELSE IF (Mesh % MinEdgeDOFs == Mesh % MaxEdgeDOFs) THEN

5176
          EdgeDegree(1:Element % Type % NumberOfEdges) = Mesh % MaxEdgeDOFs + 1

5177
          EdgeMaxDegree = Mesh % MaxEdgeDOFs + 1

5178
       ELSE

5179
       ! Get polynomial degree of each edge separately

5180
!DIR$ LOOP COUNT MAX=12

5181
          DO i=1,Element % Type % NumberOfEdges

5182
             EdgeDegree(i) = Mesh % Edges( Element % EdgeIndexes(i) ) % BDOFs + 1

5183
             EdgeMaxDegree = MAX(EdgeDegree(i), EdgeMaxDegree)

5184
          END DO

5185
       END IF

5186


5187
       ! Get edge directions if needed

5188
       IF (EdgeMaxDegree > 1) THEN

5189
         CALL H1Basis_GetEdgeDirection(Element % Type % ElementCode, &

5190
                                       Element % Type % NumberOfEdges, &

5191
                                       Element % NodeIndexes, &

5192
                                       EdgeDirection)

5193
       END IF

5194
     END SUBROUTINE GetElementMeshEdgeInfo

5195
     

5196
     SUBROUTINE GetElementMeshFaceInfo(Mesh, Element, FaceDegree, FaceDirection, FaceMaxDegree)

5197
       IMPLICIT NONE

5198
       

5199
       TYPE(Mesh_t), INTENT(IN) :: Mesh

5200
       TYPE(Element_t), INTENT(IN) :: Element

5201
       INTEGER, INTENT(OUT) :: FaceDegree(H1Basis_MaxPElementFaces), &

5202
               FaceDirection(H1Basis_MaxPElementFaceNodes,H1Basis_MaxPElementFaces)

5203
       INTEGER, INTENT(OUT) :: FaceMaxDegree

5204
       INTEGER :: i

5205


5206
       ! Get polynomial degree of each face

5207
       FaceMaxDegree = 0

5208
       

5209
       IF( Mesh % MaxFaceDofs == 0 ) THEN

5210
         CONTINUE              

5211


5212
       ELSE IF (Mesh % MinFaceDOFs == Mesh % MaxFaceDOFs) THEN

5213
          FaceMaxDegree = Mesh % Faces( Element % FaceIndexes(1) ) % PDefs % P

5214
          FaceDegree(1:Element % Type % NumberOfFaces) = FaceMaxDegree

5215
       ELSE

5216
!DIR$ LOOP COUNT MAX=6

5217
          DO i=1,Element % Type % NumberOfFaces

5218
             IF (Mesh % Faces( Element % FaceIndexes(i) ) % BDOFs /= 0) THEN

5219
                FaceDegree(i) = Mesh % Faces( Element % FaceIndexes(i) ) % PDefs % P

5220
                FaceMaxDegree = MAX(FaceDegree(i), FaceMaxDegree)

5221
             ELSE

5222
                FaceDegree(i) = 0

5223
             END IF

5224
          END DO

5225
       END IF

5226


5227
       ! Get face directions

5228
       IF (FaceMaxDegree > 1) THEN

5229
         CALL H1Basis_GetFaceDirection(Element % Type % ElementCode, &

5230
                                       Element % Type % NumberOfFaces, &

5231
                                       Element % NodeIndexes, &

5232
                                       FaceDirection)

5233
       END IF

5234
     END SUBROUTINE GetElementMeshFaceInfo     

5235
!------------------------------------------------------------------------------

5236
   END FUNCTION ElementInfoVec_ComputePElementBasis

5237
!------------------------------------------------------------------------------

5238
   

5239
   SUBROUTINE ElementInfoVec_ElementBasisToGlobal(npts, nbasis, nbmax, dLBasisdx, dim, cdim, LtoGMap, offset, dBasisdx)

5240
     IMPLICIT NONE

5241


5242
     INTEGER, INTENT(IN) :: npts

5243
     INTEGER, INTENT(IN) :: nbasis

5244
     INTEGER, INTENT(IN) :: nbmax

5245
     REAL(KIND=dp), INTENT(IN) :: dLBasisdx(VECTOR_BLOCK_LENGTH,nbmax,3)

5246
     INTEGER, INTENT(IN) :: dim

5247
     INTEGER, INTENT(IN) :: cdim

5248
     REAL(KIND=dp), INTENT(IN) :: LtoGMap(VECTOR_BLOCK_LENGTH,3,3)

5249
     INTEGER, INTENT(IN) :: offset

5250
     REAL(KIND=dp) CONTIG :: dBasisdx(:,:,:)

5251


5252
     INTEGER :: i, j, l

5253
!DIR$ ASSUME_ALIGNED dLBasisdx:64, LtoGMap:64

5254


5255
     ! Map local basis function to global

5256
     SELECT CASE (dim)

5257
     CASE(1)

5258
       !DIR$ LOOP COUNT MAX=3

5259
       DO j=1,cdim

5260
         DO i=1,nbasis

5261
           !_ELMER_OMP_SIMD

5262
           DO l=1,npts

5263
             dBasisdx(l+offset-1,i,j) = dLBasisdx(l,i,1)*LtoGMap(l,j,1)

5264
           END DO

5265
         END DO

5266
       END DO

5267
     CASE(2)

5268
       !DIR$ LOOP COUNT MAX=3

5269
       DO j=1,cdim

5270
         DO i=1,nbasis

5271
           !_ELMER_OMP_SIMD

5272
           DO l=1,npts

5273
             ! Map local basis function to global

5274
             dBasisdx(l+offset-1,i,j) = dLBasisdx(l,i,1)*LtoGMap(l,j,1)+ &

5275
                   dLBasisdx(l,i,2)*LtoGMap(l,j,2)

5276
           END DO

5277
         END DO

5278
       END DO

5279
     CASE(3)

5280
       !DIR$ LOOP COUNT MAX=3

5281
       DO j=1,cdim

5282
         DO i=1,nbasis

5283
           !_ELMER_OMP_SIMD

5284
           DO l=1,npts

5285
             ! Map local basis function to global

5286
             dBasisdx(l+offset-1,i,j) = dLBasisdx(l,i,1)*LtoGMap(l,j,1)+ &

5287
                   dLBasisdx(l,i,2)*LtoGMap(l,j,2)+ &

5288
                   dLBasisdx(l,i,3)*LtoGMap(l,j,3)

5289
           END DO

5290
         END DO

5291
       END DO

5292
     END SELECT

5293


5294
   END SUBROUTINE ElementInfoVec_ElementBasisToGlobal

5295


5296
   

5297
!------------------------------------------------------------------------------

5298
!>  Returns just the size of the element at its center.

5299
!>  providing a more economical way than calling ElementInfo. 

5300
!------------------------------------------------------------------------------

5301
   FUNCTION ElementSize( Element, Nodes ) RESULT ( detJ )

5302


5303
     TYPE(Element_t) :: Element

5304
     TYPE(Nodes_t) :: Nodes

5305
     REAL(KIND=dp) :: detJ

5306


5307
     REAL(KIND=dp) :: u,v,w

5308
     REAL(KIND=dp), ALLOCATABLE :: Basis(:)

5309
     INTEGER :: n,family

5310
     LOGICAL :: Stat

5311


5312


5313
     family = Element % TYPE % ElementCode / 100

5314
     n = Element % TYPE % NumberOfNodes

5315
     ALLOCATE( Basis(n) )

5316


5317
     SELECT CASE ( family )

5318
       

5319
       CASE ( 1 ) ! node

5320
         DetJ = 1.0_dp

5321
         RETURN

5322


5323
       CASE ( 2 ) ! line

5324
         u = 0.0_dp

5325
         v = 0.0_dp

5326


5327
       CASE ( 3 ) ! tri

5328
         u = 0.5_dp

5329
         v = 0.5_dp

5330
         

5331
       CASE ( 4 ) ! quad

5332
         u = 0.0_dp

5333
         v = 0.0_dp

5334


5335
       CASE ( 5 ) ! tet

5336
         u = 0.5_dp

5337
         v = 0.5_dp

5338
         w = 0.5_dp

5339


5340
       CASE ( 6 ) ! pyramid

5341
         u = 0.0_dp

5342
         v = 0.0_dp

5343
         w = 0.0_dp

5344


5345
       CASE ( 7 ) ! wedge

5346
         u = 0.5_dp

5347
         v = 0.5_dp

5348
         w = 0.0_dp

5349


5350
       CASE ( 8 ) ! hex

5351
         u = 0.0_dp

5352
         v = 0.0_dp

5353
         w = 0.0_dp

5354
         

5355
       CASE DEFAULT

5356
         CALL Fatal('ElementSize','Not implemented for elementtype')

5357


5358
       END SELECT

5359


5360
       Stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis )

5361


5362
     END FUNCTION ElementSize

5363
!------------------------------------------------------------------------------

5364


5365


5366
!----------------------------------------------------------------------------------

5367
!>  Return H(div)-conforming face element basis function values and their divergence 

5368
!>  with respect to the reference element coordinates at a given point on the

5369
!>  reference element. Here the basis for a real element K is constructed by  

5370
!>  transforming the basis functions defined on the reference element k via the 

5371
!>  Piola transformation. The data for performing the Piola transformation is also returned.

5372
!>  Note that the reference element is chosen as in the p-approximation so that

5373
!>  the reference element edges/faces have the same length/area. This choice simplifies 

5374
!>  the associated assembly procedure.

5375
!>     With giving the optional argument ApplyPiolaTransform = .TRUE., this function

5376
!>  also performs the Piola transform, so that the basis functions and their spatial

5377
!>  div as defined on the physical element are returned.

5378
!>    The implementation is not yet complete as all element shapes are not supported. 

5379
!---------------------------------------------------------------------------------

5380
     RECURSIVE FUNCTION FaceElementInfo( Element, Nodes, u, v, w, F, detF, &

5381
         Basis, FBasis, DivFBasis, dBasisdx, BDM, Dual, BasisDegree, &

5382
         ApplyPiolaTransform, LeftHanded) RESULT(stat)

5383
!------------------------------------------------------------------------------

5384
       IMPLICIT NONE

5385


5386
       TYPE(Element_t), TARGET :: Element        !< Element structure

5387
       TYPE(Nodes_t) :: Nodes                    !< Data corresponding to the classic element nodes

5388
       REAL(KIND=dp) :: u                        !< 1st reference element coordinate at which the basis functions are evaluated

5389
       REAL(KIND=dp) :: v                        !< 2nd reference element coordinate

5390
       REAL(KIND=dp) :: w                        !< 3rd reference element coordinate

5391
       REAL(KIND=dp), OPTIONAL :: F(3,3)         !< The gradient F=Grad f, with f the element map f:k->K

5392
       REAL(KIND=dp) :: detF                     !< The absolute value of the determinant of the gradient matrix F

5393
       REAL(KIND=dp) :: Basis(:)                 !< Standard nodal basis functions evaluated at (u,v,w)

5394
       REAL(KIND=dp) :: FBasis(:,:)              !< Face element basis functions b spanning the reference element space   

5395
       REAL(KIND=dp), OPTIONAL :: DivFBasis(:)   !< The divergence of basis functions with respect to the local coordinates

5396
       REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:)  !< The first derivatives of the H1-conforming basis functions at (u,v,w)

5397
       LOGICAL, OPTIONAL :: BDM                  !< If .TRUE., a basis for BDM space is constructed

5398
       LOGICAL, OPTIONAL :: Dual                 !< If .TRUE., create an alternate dual basis

5399
       INTEGER, OPTIONAL :: BasisDegree          !< This has limited functionality at the moment

5400
       LOGICAL, OPTIONAL :: ApplyPiolaTransform  !< If  .TRUE., perform the Piola transform so that, instead of b

5401
                                                 !< and Div b, return  B(f(p)) and (div B)(f(p)) with B(x) the basis 

5402
                                                 !< functions on the physical element and div the spatial divergence operator.

5403
       LOGICAL, OPTIONAL :: LeftHanded           !< Indicates whether detF is negative

5404
       LOGICAL :: Stat                           !< Should be .FALSE. for a degenerate element but this is not yet checked

5405
!-----------------------------------------------------------------------------------------------------------------

5406
!      Local variables

5407
!------------------------------------------------------------------------------------------------------------

5408
       INTEGER, PARAMETER :: MaxDOFs = 48 ! The largest DOF count handled, revise when new elements are added

5409


5410
       TYPE(Mesh_t), POINTER :: Mesh

5411
       INTEGER, POINTER :: EdgeMap(:,:), FaceMap(:,:)

5412
       INTEGER :: SquareFaceMap(4)

5413
       INTEGER :: DOFs

5414
       INTEGER :: n, dim, cdim, q, i, j, k, I1, I2

5415
       INTEGER :: FDofMap(6,4), DofsPerFace, FaceIndices(4)

5416
       INTEGER :: Family, RTDegree, GIndexes(27)

5417
       REAL(KIND=dp) :: LF(3,3), LG(3,3)

5418
       REAL(KIND=dp) :: DivBasis(MaxDOFs)

5419
       REAL(KIND=dp) :: dLbasisdx(MAX(SIZE(Nodes % x),SIZE(Basis)),3), S, D1, D2, fun, dfun, wfun(2)

5420
       REAL(KIND=dp) :: WorkBasis(24,3), WorkDivBasis(24)

5421


5422
       LOGICAL :: ReverseSign(6), CreateBDMBasis, Parallel

5423
       LOGICAL :: CreateDualBasis

5424
       LOGICAL :: PerformPiolaTransform

5425
!-----------------------------------------------------------------------------------------------------

5426
       Mesh => CurrentModel % Solver % Mesh

5427


5428
       Parallel = ASSOCIATED(Mesh % ParallelInfo % GInterface)

5429


5430
       !--------------------------------------------------------------------

5431
       ! Check whether BDM or dual basis functions should be created and 

5432
       ! whether the Piola transform is already applied within this function.

5433
       !---------------------------------------------------------------------

5434
       CreateBDMBasis = .FALSE.

5435
       IF ( PRESENT(BDM) ) CreateBDMBasis = BDM

5436
       RTDegree = 0

5437
       IF (PRESENT(BasisDegree)) THEN

5438
         RTDegree = BasisDegree - 1

5439
         IF (BasisDegree > 2) CALL Fatal('ElementDescription::FaceElementInfo', 'Unsupported element degree')

5440
       END IF

5441
       CreateDualBasis = .FALSE.

5442
       IF ( PRESENT(Dual) ) CreateDualBasis = Dual

5443
       PerformPiolaTransform = .FALSE.

5444
       IF ( PRESENT(ApplyPiolaTransform) ) PerformPiolaTransform = ApplyPiolaTransform       

5445
       !-----------------------------------------------------------------------------------------------------

5446
       stat = .TRUE.

5447
       Basis = 0.0d0

5448
       FBasis = 0.0d0

5449
       IF (PRESENT(DivFBasis)) DivFBasis = 0.0d0

5450
       DivBasis = 0.0d0

5451
       LF = 0.0d0

5452


5453
       dLbasisdx = 0.0d0      

5454
       n = Element % TYPE % NumberOfNodes

5455
       dim = Element % TYPE % DIMENSION

5456
       cdim = CoordinateSystemDimension()

5457
       

5458
       IF ( Element % TYPE % ElementCode == 101 ) THEN

5459
          detF = 1.0d0

5460
          Basis(1) = 1.0d0

5461
          IF (PRESENT(dBasisdx)) dBasisdx(1,:) = 0.0d0

5462
          RETURN

5463
       END IF

5464


5465
       !-----------------------------------------------------------------------

5466
       ! The standard nodal basis functions on the reference element and

5467
       ! their derivatives with respect to the local coordinates. These define 

5468
       ! the mapping of the reference element to an actual element on the 

5469
       ! background mesh but are not the basis functions for face element approximation.

5470
       ! Remark: Using reference elements having the faces of the same area

5471
       ! simplifies the implementation of element assembly procedures.

5472
       !-----------------------------------------------------------------------

5473
       Family = Element % TYPE % ElementCode / 100

5474
       SELECT CASE(Family)

5475
       CASE(2)

5476
         DO q=1,2

5477
           Basis(q) = LineNodalPBasis(q, u)

5478
           dLBasisdx(q,1) = dLineNodalPBasis(q, u)

5479
         END DO

5480
         IF (RTDegree == 1) THEN

5481
           DOFs = 3

5482
           ! Basis(3) = LineBubblePBasis(2, u)

5483
           ! dLBasisdx(q,1) = dLineBubblePBasis(2, u)

5484
         ELSE

5485
           DOFs = 2

5486
         END IF

5487
       CASE(3)

5488
          DO q=1,n

5489
             Basis(q) = TriangleNodalPBasis(q, u, v)

5490
             dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 

5491
          END DO

5492
       CASE(4)

5493
          DO q=1,n

5494
             Basis(q) = QuadNodalPBasis(q, u, v)

5495
             dLBasisdx(q,1:2) = dQuadNodalPBasis(q, u, v) 

5496
          END DO

5497
       CASE(5)

5498
          DO q=1,n

5499
             Basis(q) = TetraNodalPBasis(q, u, v, w)

5500
             dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w)

5501
          END DO

5502
       CASE(8)

5503
         DO q=1,n

5504
           Basis(q) = BrickNodalPBasis(q, u, v, w)

5505
           dLBasisdx(q,1:3) = dBrickNodalPBasis(q, u, v, w)

5506
         END DO

5507
       CASE DEFAULT

5508
          CALL Fatal('ElementDescription::FaceElementInfo','Unsupported element type')

5509
       END SELECT          

5510


5511
       

5512
       GIndexes(1:n) = Element % NodeIndexes(1:n)

5513
       IF( Parallel ) GIndexes(1:n) = Mesh % ParallelInfo % GlobalDOFs(GIndexes(1:n))             

5514
       

5515
       !-----------------------------------------------------------------------

5516
       ! Get data for performing the Piola transformation...

5517
       !-----------------------------------------------------------------------

5518
       stat = PiolaTransformationData(n, Element, Nodes, LF, detF, dLBasisdx) 

5519
       !------------------------------------------------------------------------

5520
       ! ... in order to define the basis for the element space X(K) via 

5521
       ! applying the Piola transformation as

5522
       !    X(K) = { B | B = 1/(det F) F b(f^{-1}(x)) }

5523
       ! with b giving the face element basis function on the reference element k,

5524
       ! f mapping k to the actual element K, i.e. K = f(k) and F = Grad f. This 

5525
       ! function returns the local basis functions b and their divergence (with respect

5526
       ! to local coordinates) evaluated at the integration point. The effect of 

5527
       ! the Piola transformation need to be considered when integrating, so we 

5528
       ! shall return also the values of F and det F.

5529
       !

5530
       ! The construction of face element bases could be done in an alternate way for 

5531
       ! triangles and tetrahedra, while the chosen approach has the benefit that

5532
       ! it generalizes to other cases. For example general quadrilaterals may now 

5533
       ! be handled in the same way.

5534
       !---------------------------------------------------------------------------

5535
       IF (PRESENT(dBasisdx) .AND. cdim == dim) THEN

5536
         LG = 0.0d0

5537
         IF (cdim == dim) THEN

5538
           SELECT CASE(Element % TYPE % ElementCode / 100)

5539
           CASE(3,4)

5540
             LG(1,1) = 1.0d0/detF * LF(2,2)

5541
             LG(1,2) = -1.0d0/detF * LF(1,2)

5542
             LG(2,1) = -1.0d0/detF * LF(2,1)

5543
             LG(2,2) = 1.0d0/detF * LF(1,1)

5544
           CASE(5,6,7,8)

5545
             CALL InvertMatrix3x3(LF,LG,detF)       

5546
           CASE DEFAULT

5547
             CALL Fatal('ElementDescription::FaceElementInfo','Unsupported element type')

5548
           END SELECT

5549
           LG(1:dim,1:dim) = TRANSPOSE( LG(1:dim,1:dim) )

5550
         END IF

5551
       END IF

5552
       

5553
       SELECT CASE(Element % TYPE % ElementCode / 100)

5554
       CASE(2)

5555
         ! TO DO: Implement possible sign reversions

5556
         FBasis(1,1) = -Basis(1)

5557
         DivBasis(1) = -dLBasisdx(q,1)

5558
         FBasis(2,1) = Basis(2)

5559
         DivBasis(2) = -dLBasisdx(q,2)

5560
         IF (RTDegree > 0) THEN

5561
           FBasis(3,1) = 4.0d0 * Basis(1) * Basis(2)

5562
           DivBasis(2) = 4.0d0 * dLBasisdx(1,1) * Basis(2) + 4.0d0 * Basis(1) * dLBasisdx(2,1)

5563
         END IF

5564
        

5565
       CASE(3)

5566
          !----------------------------------------------------------------

5567
          ! Note that the global orientation of face normal is taken to be

5568
          ! n = t x e_z where the tangent vector t is aligned with

5569
          ! the element edge and points towards the node that has

5570
          ! a larger global index.

5571
          !---------------------------------------------------------------

5572
          EdgeMap => GetEdgeMap(3)

5573
          !EdgeMap => GetEdgeMap(GetElementFamily(Element))

5574


5575
          !-----------------------------------------------------------------------------------

5576
          ! Check first whether a sign reversion will be needed as face dofs have orientation.

5577
          !-----------------------------------------------------------------------------------

5578
          CALL FaceElementOrientation(Element, ReverseSign)

5579


5580
          IF (CreateBDMBasis) THEN

5581
             !----------------------------------------------------------------------------

5582
             ! This is for the BDM space of degree k=1.

5583
             !----------------------------------------------------------------------------

5584
             DOFs = 6

5585
             DofsPerFace = 2

5586
             !----------------------------------------------------------------------------

5587
             ! First tabulate the basis functions in the default order.

5588
             !----------------------------------------------------------------------------

5589
             ! Two basis functions defined on face 12:

5590
             !-------------------------------------------------

5591
             FBasis(1,1) = sqrt(3.0d0)/6.0d0 * (-sqrt(3.0d0) + u + v)             

5592
             FBasis(1,2) = sqrt(3.0d0)/6.0d0 * (-sqrt(3.0d0) + 3.0d0 * u + v)

5593
             DivBasis(1) = sqrt(3.0d0)/3.0d0

5594
             

5595
             FBasis(2,1) = sqrt(3.0d0)/6.0d0 * (sqrt(3.0d0) + u - v)             

5596
             FBasis(2,2) = sqrt(3.0d0)/6.0d0 * (-sqrt(3.0d0) - 3.0d0 * u + v)

5597
             DivBasis(2) = sqrt(3.0d0)/3.0d0

5598


5599
             ! Two basis functions defined on face 23:

5600
             

5601
             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)

5602
             FBasis(3,2) = 1.0d0/6.0d0 * ( -3.0d0+sqrt(3.0d0) ) * v

5603
             DivBasis(3) = sqrt(3.0d0)/3.0d0

5604


5605
             FBasis(4,1) = 1.0d0/6.0d0 * (-3.0d0+sqrt(3.0d0)+(-3.0d0+sqrt(3.0d0))*u + 2.0d0*sqrt(3.0d0)*v)

5606
             FBasis(4,2) = 1.0d0/6.0d0 * ( 3.0d0+sqrt(3.0d0) ) * v

5607
             DivBasis(4) = sqrt(3.0d0)/3.0d0

5608


5609


5610
             ! Two basis functions defined on face 31:

5611


5612
             FBasis(5,1) = 1.0d0/( 3.0d0+sqrt(3.0d0) ) * ( 1.0d0 - u - v - sqrt(3.0d0)*v ) 

5613
             FBasis(5,2) = ( 3.0d0+2.0d0*sqrt(3.0d0) ) * v /(3.0d0*(1.0d0+sqrt(3.0d0)))

5614
             DivBasis(5) = sqrt(3.0d0)/3.0d0

5615


5616
             FBasis(6,1) = 1.0d0/6.0d0 * (-3.0d0-sqrt(3.0d0)+(3.0d0+sqrt(3.0d0))*u + 2.0d0*sqrt(3.0d0)*v)

5617
             FBasis(6,2) = 1.0d0/6.0d0 * ( -3.0d0+sqrt(3.0d0) ) * v

5618
             DivBasis(6) = sqrt(3.0d0)/3.0d0

5619


5620
             !-----------------------------------------------------

5621
             ! Now do the reordering and sign reversion:

5622
             !-----------------------------------------------------

5623
             DO q=1,3

5624
               IF (ReverseSign(q)) THEN

5625
                 DO j=1,DofsPerFace

5626
                   i = (q-1)*DofsPerFace + j

5627
                   WorkBasis(j,1:2) = FBasis(i,1:2)

5628
                   WorkDivBasis(j) = DivBasis(i)

5629
                 END DO

5630
                 i = 2*q - 1

5631
                 FBasis(i,1:2) = -WorkBasis(2,1:2)

5632
                 DivBasis(i) = -WorkDivBasis(2)

5633
                 i = 2*q

5634
                 FBasis(i,1:2) = -WorkBasis(1,1:2)

5635
                 DivBasis(i) = -WorkDivBasis(1)

5636
               END IF

5637
             END DO

5638


5639
          ELSE

5640
             SELECT CASE (RTDegree)

5641
             CASE(0) 

5642
               DOFs = 3

5643


5644
               FBasis(1,1) = SQRT(3.0d0)/6.0d0 * u

5645
               FBasis(1,2) = -0.5d0 + SQRT(3.0d0)/6.0d0 * v

5646
               DivBasis(1) =  SQRT(3.0d0)/3.0d0

5647
               IF (ReverseSign(1)) THEN

5648
                 FBasis(1,:) = -FBasis(1,:)

5649
                 DivBasis(1) = -DivBasis(1)

5650
               END IF

5651


5652
               FBasis(2,1) = SQRT(3.0d0)/6.0d0 * (1.0d0 + u)

5653
               FBasis(2,2) = SQRT(3.0d0)/6.0d0 * v

5654
               DivBasis(2) =  SQRT(3.0d0)/3.0d0        

5655
               IF (ReverseSign(2)) THEN

5656
                 FBasis(2,:) = -FBasis(2,:)

5657
                 DivBasis(2) = -DivBasis(2)

5658
               END IF

5659


5660
               FBasis(3,1) = SQRT(3.0d0)/6.0d0 * (-1.0d0 + u)

5661
               FBasis(3,2) = SQRT(3.0d0)/6.0d0 * v

5662
               DivBasis(3) =  SQRT(3.0d0)/3.0d0          

5663
               IF (ReverseSign(3)) THEN

5664
                 FBasis(3,:) = -FBasis(3,:)

5665
                 DivBasis(3) = -DivBasis(3)

5666
               END IF

5667


5668
             CASE(1)

5669
               !

5670
               ! We use a non-hierarchic basis which is motivated by flux reconstruction.

5671
               ! The degrees of freedom associated with the element faces (edges) can be

5672
               ! integrated for a given flux q as (q.n,w) where the weights are the Lagrange

5673
               ! basis functions.

5674
               DOFs = 8

5675
               !-------------------------------------------------

5676
               ! Two basis functions defined on the face 12.

5677
               !-------------------------------------------------

5678
               WorkBasis(3,1) = SQRT(3.0d0)/6.0d0 * u

5679
               WorkBasis(3,2) = -0.5d0 + SQRT(3.0d0)/6.0d0 * v

5680
               WorkDivBasis(3) = SQRT(3.0d0)/3.0d0

5681
               IF (ReverseSign(1)) THEN

5682
                 WorkBasis(3,:) = -WorkBasis(3,:)

5683
                 WorkDivBasis(3) = -WorkDivBasis(3)

5684
               END IF

5685


5686
               wfun(1) = 4.0d0 * Basis(1) - 2.0d0 * Basis(2)

5687
               wfun(2) = 4.0d0 * Basis(2) - 2.0d0 * Basis(1)

5688
               WorkBasis(1,1:2) = wfun(1) * WorkBasis(3,1:2)

5689
               WorkBasis(2,1:2) = wfun(2) * WorkBasis(3,1:2)

5690
               WorkDivBasis(1) = wfun(1) * WorkDivBasis(3) + &

5691
                   SUM(WorkBasis(3,1:2) * (4.0d0 * dLBasisdx(1,1:2) - 2.0d0 * dLBasisdx(2,1:2)))

5692
               WorkDivBasis(2) = wfun(2) * WorkDivBasis(3) + &

5693
                   SUM(WorkBasis(3,1:2) * (4.0d0 * dLBasisdx(2,1:2) - 2.0d0 * dLBasisdx(1,1:2)))

5694
               

5695
               i = EdgeMap(1,1)

5696
               j = EdgeMap(1,2)

5697
               IF (GIndexes(j)<GIndexes(i)) THEN

5698
                 FBasis(1,1:2) = WorkBasis(2,1:2)

5699
                 DivBasis(1) = WorkDivBasis(2) 

5700
                 FBasis(2,1:2) = WorkBasis(1,1:2)

5701
                 DivBasis(2) = WorkDivBasis(1)  

5702
               ELSE

5703
                 FBasis(1,1:2) = WorkBasis(1,1:2)

5704
                 DivBasis(1) = WorkDivBasis(1)

5705
                 FBasis(2,1:2) = WorkBasis(2,1:2)

5706
                 DivBasis(2) = WorkDivBasis(2)

5707
               END IF

5708


5709
               !-------------------------------------------------

5710
               ! Two basis functions defined on the face 23.

5711
               !-------------------------------------------------

5712
               WorkBasis(3,1) = SQRT(3.0d0)/6.0d0 * (1.0d0 + u)

5713
               WorkBasis(3,2) = SQRT(3.0d0)/6.0d0 * v

5714
               WorkDivBasis(3) =  SQRT(3.0d0)/3.0d0        

5715
               IF (ReverseSign(2)) THEN

5716
                 WorkBasis(3,:) = -WorkBasis(3,:)

5717
                 WorkDivBasis(3) = -WorkDivBasis(3)

5718
               END IF

5719


5720
               wfun(1) = 4.0d0 * Basis(2) - 2.0d0 * Basis(3)

5721
               wfun(2) = 4.0d0 * Basis(3) - 2.0d0 * Basis(2)

5722
               WorkBasis(1,1:2) = wfun(1) * WorkBasis(3,1:2)

5723
               WorkBasis(2,1:2) = wfun(2) * WorkBasis(3,1:2)

5724
               WorkDivBasis(1) = wfun(1) * WorkDivBasis(3) + &

5725
                   SUM(WorkBasis(3,1:2) * (4.0d0 * dLBasisdx(2,1:2) - 2.0d0 * dLBasisdx(3,1:2)))

5726
               WorkDivBasis(2) = wfun(2) * WorkDivBasis(3) + &

5727
                   SUM(WorkBasis(3,1:2) * (4.0d0 * dLBasisdx(3,1:2) - 2.0d0 * dLBasisdx(2,1:2)))

5728


5729
               i = EdgeMap(2,1)

5730
               j = EdgeMap(2,2)

5731
               IF (GIndexes(j)<GIndexes(i)) THEN

5732
                 FBasis(3,1:2) = WorkBasis(2,1:2)

5733
                 DivBasis(3) = WorkDivBasis(2) 

5734
                 FBasis(4,1:2) = WorkBasis(1,1:2)

5735
                 DivBasis(4) = WorkDivBasis(1)  

5736
               ELSE

5737
                 FBasis(3,1:2) = WorkBasis(1,1:2)

5738
                 DivBasis(3) = WorkDivBasis(1)

5739
                 FBasis(4,1:2) = WorkBasis(2,1:2)

5740
                 DivBasis(4) = WorkDivBasis(2)

5741
               END IF

5742
               

5743
               !-------------------------------------------------

5744
               ! Two basis functions defined on the face 31.

5745
               !-------------------------------------------------

5746
               WorkBasis(3,1) = SQRT(3.0d0)/6.0d0 * (-1.0d0 + u)

5747
               WorkBasis(3,2) = SQRT(3.0d0)/6.0d0 * v

5748
               WorkDivBasis(3) =  SQRT(3.0d0)/3.0d0          

5749
               IF (ReverseSign(3)) THEN

5750
                 WorkBasis(3,:) = -WorkBasis(3,:)

5751
                 WorkDivBasis(3) = -WorkDivBasis(3)

5752
               END IF

5753
               

5754
               wfun(1) = 4.0d0 * Basis(3) - 2.0d0 * Basis(1)

5755
               wfun(2) = 4.0d0 * Basis(1) - 2.0d0 * Basis(3)

5756
               WorkBasis(1,1:2) = wfun(1) * WorkBasis(3,1:2)

5757
               WorkBasis(2,1:2) = wfun(2) * WorkBasis(3,1:2)

5758
               WorkDivBasis(1) = wfun(1) * WorkDivBasis(3) + &

5759
                   SUM(WorkBasis(3,1:2) * (4.0d0 * dLBasisdx(3,1:2) - 2.0d0 * dLBasisdx(1,1:2)))

5760
               WorkDivBasis(2) = wfun(2) * WorkDivBasis(3) + &

5761
                   SUM(WorkBasis(3,1:2) * (4.0d0 * dLBasisdx(1,1:2) - 2.0d0 * dLBasisdx(3,1:2)))

5762
               

5763
               i = EdgeMap(3,1)

5764
               j = EdgeMap(3,2)

5765
               IF (GIndexes(j)<GIndexes(i)) THEN

5766
                 FBasis(5,1:2) = WorkBasis(2,1:2)

5767
                 DivBasis(5) = WorkDivBasis(2) 

5768
                 FBasis(6,1:2) = WorkBasis(1,1:2)

5769
                 DivBasis(6) = WorkDivBasis(1)  

5770
               ELSE

5771
                 FBasis(5,1:2) = WorkBasis(1,1:2)

5772
                 DivBasis(5) = WorkDivBasis(1)

5773
                 FBasis(6,1:2) = WorkBasis(2,1:2)

5774
                 DivBasis(6) = WorkDivBasis(2)

5775
               END IF

5776


5777
               !-------------------------------------------------

5778
               ! Two basis functions defined on the interior 123.

5779
               ! Note: The ordering of these functions is not specified,

5780
               !       although the choice is made unique.

5781
               !-------------------------------------------------               

5782
               WorkBasis(1,1) = SQRT(3.0d0)/6.0d0 * u

5783
               WorkBasis(1,2) = -0.5d0 + SQRT(3.0d0)/6.0d0 * v

5784
               WorkDivBasis(1) = Basis(3) * SQRT(3.0d0)/3.0d0 + SUM(WorkBasis(1,1:2) * dLBasisdx(3,1:2))

5785
               WorkBasis(1,1:2) = Basis(3) * WorkBasis(1,1:2)

5786
               

5787
               WorkBasis(2,1) = SQRT(3.0d0)/6.0d0 * (1.0d0 + u)

5788
               WorkBasis(2,2) = SQRT(3.0d0)/6.0d0 * v

5789
               WorkDivBasis(2) = Basis(1) * SQRT(3.0d0)/3.0d0 + SUM(WorkBasis(2,1:2) * dLBasisdx(1,1:2))

5790
               WorkBasis(2,1:2) = Basis(1) * WorkBasis(2,1:2)

5791
               

5792
               WorkBasis(3,1) = SQRT(3.0d0)/6.0d0 * (-1.0d0 + u)

5793
               WorkBasis(3,2) = SQRT(3.0d0)/6.0d0 * v

5794
               WorkDivBasis(3) = Basis(2) * SQRT(3.0d0)/3.0d0 + SUM(WorkBasis(3,1:2) * dLBasisdx(2,1:2))

5795
               WorkBasis(3,1:2) = Basis(2) * WorkBasis(3,1:2)

5796
               

5797
               FaceIndices(1:3) = GIndexes(1:3)

5798
               IF ( FaceIndices(1) < FaceIndices(2) ) THEN

5799
                 k = 1

5800
               ELSE

5801
                 k = 2

5802
               END IF

5803
               IF ( FaceIndices(k) > FaceIndices(3) ) THEN

5804
                 k = 3

5805
               END IF

5806


5807
               SELECT CASE(k)

5808
               CASE(1)

5809
                 FBasis(7,1:2) = WorkBasis(1,1:2)

5810
                 DivBasis(7) = WorkDivBasis(1)

5811
                 FBasis(8,1:2) = WorkBasis(3,1:2)

5812
                 DivBasis(8) = WorkDivBasis(3)

5813
               CASE(2)

5814
                 FBasis(7,1:2) = WorkBasis(1,1:2)

5815
                 DivBasis(7) = WorkDivBasis(1)

5816
                 FBasis(8,1:2) = WorkBasis(2,1:2)

5817
                 DivBasis(8) = WorkDivBasis(2)

5818
               CASE(3)

5819
                 FBasis(7,1:2) = WorkBasis(2,1:2)

5820
                 DivBasis(7) = WorkDivBasis(2)

5821
                 FBasis(8,1:2) = WorkBasis(3,1:2)

5822
                 DivBasis(8) = WorkDivBasis(3)

5823
               END SELECT

5824
               

5825
             END SELECT

5826
          END IF

5827
          

5828
       CASE(4)

5829
          DOFs = 6

5830
          !--------------------------------------------------------------------

5831
          ! Quadrilateral Arnold-Boffi-Falk (ABF) element basis of degree k=0

5832
          !--------------------------------------------------------------------

5833
          EdgeMap => GetEdgeMap(4)

5834
          SquareFaceMap(:) = (/ 1,2,3,4 /)          

5835


5836
          IF (.NOT. CreateDualBasis) THEN

5837
             !-------------------------------------------------

5838
             ! Four basis functions defined on the edges

5839
             !-------------------------------------------------

5840
             i = EdgeMap(1,1)

5841
             j = EdgeMap(1,2)

5842
             FBasis(1,1) = 0.0d0

5843
             FBasis(1,2) = -((-1.0d0 + v)*v)/4.0d0

5844
             DivBasis(1) = (1.0d0 - 2*v)/4.0d0

5845
             IF(GIndexes(j)<GIndexes(i)) THEN

5846
               FBasis(1,:) = -FBasis(1,:)

5847
               DivBasis(1) = -DivBasis(1)

5848
             END IF

5849


5850
             i = EdgeMap(2,1)

5851
             j = EdgeMap(2,2)

5852
             FBasis(2,1) = (u*(1.0d0 + u))/4.0d0

5853
             FBasis(2,2) = 0.0d0

5854
             DivBasis(2) = (1 + 2.0d0*u)/4.0d0

5855
             IF(GIndexes(j)<GIndexes(i)) THEN

5856
               FBasis(2,:) = -FBasis(2,:)

5857
               DivBasis(2) = -DivBasis(2)

5858
             END IF

5859


5860
             i = EdgeMap(3,1)

5861
             j = EdgeMap(3,2)

5862
             FBasis(3,1) = 0.0d0

5863
             FBasis(3,2) = (v*(1.0d0 + v))/4.0d0

5864
             DivBasis(3) = (1.0d0 + 2.0d0*v)/4.0d0

5865
             IF(GIndexes(j)<GIndexes(i)) THEN

5866
               FBasis(3,:) = -FBasis(3,:)

5867
               DivBasis(3) = -DivBasis(3)

5868
             END IF

5869


5870
             i = EdgeMap(4,1)

5871
             j = EdgeMap(4,2)

5872
             FBasis(4,1) = -((-1.0d0 + u)*u)/4.0d0

5873
             FBasis(4,2) = 0.0d0

5874
             DivBasis(4) = (1.0d0 - 2.0d0*u)/4.0d0

5875
             IF(GIndexes(j)<GIndexes(i)) THEN

5876
               FBasis(4,:) = -FBasis(4,:)

5877
               DivBasis(4) = -DivBasis(4)

5878
             END IF

5879


5880
             !--------------------------------------------------------------------

5881
             ! Additional two basis functions associated with the element interior

5882
             !-------------------------------------------------------------------

5883
             WorkBasis(1,:) = 0.0d0

5884
             WorkBasis(2,:) = 0.0d0

5885
             WorkDivBasis(:) = 0.0d0

5886


5887
             WorkBasis(1,1) = 0.0d0

5888
             WorkBasis(1,2) = (-1.0d0 + v**2)/2.0d0

5889
             WorkDivBasis(1) = v

5890


5891
             WorkBasis(2,1) = (1.0d0 - u**2)/2.0d0

5892
             WorkBasis(2,2) = 0.0d0

5893
             WorkDivBasis(2) = -u

5894


5895
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

5896
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

5897


5898
             FBasis(5,:) = D1 * WorkBasis(I1,:)

5899
             DivBasis(5) = D1 * WorkDivBasis(I1)

5900
             FBasis(6,:) = D2 * WorkBasis(I2,:)

5901
             DivBasis(6) = D2 * WorkDivBasis(I2)   

5902
          ELSE

5903
             !---------------------------------------------------------------------------

5904
             ! Create alternate basis functions for the ABF space so that these basis

5905
             ! functions are dual to the standard basis functions when the mesh is regular.

5906
             ! First four basis functions which are dual to the standard edge basis 

5907
             ! functions:

5908
             !----------------------------------------------------------------------------

5909
             i = EdgeMap(1,1)

5910
             j = EdgeMap(1,2)

5911
             FBasis(1,1) = 0.0d0

5912
             FBasis(1,2) = (-3.0d0*(-1.0d0 - 2.0d0*v + 5.0d0*v**2))/4.0d0

5913
             DivBasis(1) = (-3.0d0*(-1.0d0 + 5.0d0*v))/2.0d0

5914
             IF(GIndexes(j)<GIndexes(i)) THEN

5915
               FBasis(1,:) = -FBasis(1,:)

5916
               DivBasis(1) = -DivBasis(1)

5917
             END IF

5918


5919
             i = EdgeMap(2,1)

5920
             j = EdgeMap(2,2)

5921
             FBasis(2,1) = (3.0d0*(-1.0d0 + 2.0d0*u + 5.0d0*u**2))/4.0d0

5922
             FBasis(2,2) = 0.0d0

5923
             DivBasis(2) = (3.0d0*(1.0d0 + 5.0d0*u))/2.0d0

5924
             IF(GIndexes(j)<GIndexes(i)) THEN

5925
                FBasis(2,:) = -FBasis(2,:)

5926
                DivBasis(2) = -DivBasis(2)

5927
             END IF

5928


5929
             i = EdgeMap(3,1)

5930
             j = EdgeMap(3,2)

5931
             FBasis(3,1) = 0.0d0

5932
             FBasis(3,2) = (3.0d0*(-1.0d0 + 2.0d0*v + 5.0d0*v**2))/4.0d0

5933
             DivBasis(3) = (3.0d0*(1.0d0 + 5.0d0*v))/2.0d0

5934
             IF(GIndexes(j)<GIndexes(i)) THEN

5935
               FBasis(3,:) = -FBasis(3,:)

5936
               DivBasis(3) = -DivBasis(3)

5937
             END IF

5938


5939
             i = EdgeMap(4,1)

5940
             j = EdgeMap(4,2)

5941
             FBasis(4,1) = (-3.0d0*(-1.0d0 - 2.0d0*u + 5.0d0*u**2))/4.0d0

5942
             FBasis(4,2) = 0.0d0

5943
             DivBasis(4) = (-3.0d0*(-1.0d0 + 5.0d0*u))/2.0d0

5944
             IF(GIndexes(j)<GIndexes(i)) THEN

5945
               FBasis(4,:) = -FBasis(4,:)

5946
               DivBasis(4) = -DivBasis(4)

5947
             END IF

5948


5949
             !-------------------------------------------------------------------------

5950
             ! Additional two dual basis functions associated with the element interior

5951
             !-------------------------------------------------------------------------

5952
             WorkBasis(1,:) = 0.0d0

5953
             WorkBasis(2,:) = 0.0d0

5954
             WorkDivBasis(:) = 0.0d0

5955


5956
             WorkBasis(1,1) = 0.0d0

5957
             WorkBasis(1,2) = (3.0d0*(-3.0d0 + 5.0d0*v**2))/8.0d0

5958
             WorkDivBasis(1) = 15.0d0*v/4.0d0

5959


5960
             WorkBasis(2,1) = (3.0d0*(3.0d0 - 5.0d0*u**2))/8.0d0

5961
             WorkBasis(2,2) = 0.0d0

5962
             WorkDivBasis(2) = -15.0d0*u/4.0d0

5963


5964
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))              

5965
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

5966


5967
             FBasis(5,:) = D1 * WorkBasis(I1,:)

5968
             DivBasis(5) = D1 * WorkDivBasis(I1)

5969
             FBasis(6,:) = D2 * WorkBasis(I2,:)

5970
             DivBasis(6) = D2 * WorkDivBasis(I2)

5971
          END IF

5972


5973
       CASE(5)

5974
          !-----------------------------------------

5975
          ! This branch is for handling tetrahedra

5976
          !-----------------------------------------------------------------------------------

5977
          ! Check first whether a sign reversion will be needed as face dofs have orientation.

5978
          ! If the sign is not reversed, the positive value of the degree of freedom produces

5979
          ! positive outward flux from the element through the face handled.

5980
          !-----------------------------------------------------------------------------------

5981
          CALL FaceElementOrientation(Element, ReverseSign)

5982


5983
          IF (CreateBDMBasis) THEN

5984
             DOFs = 12

5985
             DofsPerFace = 3 ! This choice is used for the BDM space of degree k=1

5986
             !----------------------------------------------------------------------------

5987
             ! Create a table of BDM basis functions in the default order

5988
             !----------------------------------------------------------------------------

5989
             ! Face {213}:

5990
             WorkBasis(1,1) = (3*Sqrt(6.0d0) + 2*Sqrt(6.0d0)*u - 3*Sqrt(2.0d0)*v - 3*w)/12.0

5991
             WorkBasis(1,2) = (-2*Sqrt(2.0d0) - 3*Sqrt(2.0d0)*u + Sqrt(3.0d0)*w)/12.0

5992
             WorkBasis(1,3) = (-8 - 12*u + 4*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w)/12.0

5993


5994
             WorkBasis(2,1) = (2*Sqrt(6.0d0)*u + 3*(-Sqrt(6.0d0) + Sqrt(2.0d0)*v + w))/12.0

5995
             WorkBasis(2,2) = (-2*Sqrt(2.0d0) + 3*Sqrt(2.0d0)*u + Sqrt(3.0d0)*w)/12.0

5996
             WorkBasis(2,3) = u + (-8 + 4*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w)/12.0

5997


5998
             WorkBasis(3,1) = -u/(2.0*Sqrt(6.0d0))

5999
             WorkBasis(3,2) = (Sqrt(2.0d0) + 3*Sqrt(6.0d0)*v - 2*Sqrt(3.0d0)*w)/12.0

6000
             WorkBasis(3,3) = (4 - 8*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w)/12.0

6001


6002
             ! Face {124}:

6003
             WorkBasis(4,1) = (2*Sqrt(6.0d0)*u + 3*(-Sqrt(6.0d0) + Sqrt(2.0d0)*v + w))/12.0

6004
             WorkBasis(4,2) = (-6*Sqrt(2.0d0) + 9*Sqrt(2.0d0)*u + 2*Sqrt(6.0d0)*v + 3*Sqrt(3.0d0)*w)/12.0

6005
             WorkBasis(4,3) = -w/(2.0*Sqrt(6.0d0))

6006
             WorkBasis(5,1) = (3*Sqrt(6.0d0) + 2*Sqrt(6.0d0)*u - 3*Sqrt(2.0d0)*v - 3*w)/12.0

6007
             WorkBasis(5,2) = (-6*Sqrt(2.0d0) - 9*Sqrt(2.0d0)*u + 2*Sqrt(6.0d0)*v + 3*Sqrt(3.0d0)*w)/12.0

6008
             WorkBasis(5,3) = -w/(2.0*Sqrt(6.0d0))

6009
             WorkBasis(6,1) = -u/(2.0*Sqrt(6.0d0))

6010
             WorkBasis(6,2) = (3*Sqrt(2.0d0) - Sqrt(6.0d0)*v - 6*Sqrt(3.0d0)*w)/12.0

6011
             WorkBasis(6,3) = (5*w)/(2.0*Sqrt(6.0d0))

6012


6013
             ! Face {234}:

6014
             WorkBasis(7,1) = (5*Sqrt(6.0d0) + 5*Sqrt(6.0d0)*u - 6*Sqrt(2.0d0)*v - 6*w)/12.0

6015
             WorkBasis(7,2) = -v/(2.0*Sqrt(6.0d0))

6016
             WorkBasis(7,3) = -w/(2.0*Sqrt(6.0d0))

6017
             WorkBasis(8,1) = (-Sqrt(6.0d0) - Sqrt(6.0d0)*u + 6*Sqrt(2.0d0)*v - 3*w)/12.0

6018
             WorkBasis(8,2) = (5*Sqrt(6.0)*v - 3*Sqrt(3.0d0)*w)/12.0

6019
             WorkBasis(8,3) = -w/(2.0*Sqrt(6.0d0))

6020
             WorkBasis(9,1) = (-Sqrt(6.0d0) - Sqrt(6.0d0)*u + 9*w)/12.0

6021
             WorkBasis(9,2) = (-(Sqrt(6.0d0)*v) + 3*Sqrt(3.0d0)*w)/12.0

6022
             WorkBasis(9,3) = (5*w)/(2.0*Sqrt(6.0d0))

6023


6024
             ! Face {314}:             

6025
             WorkBasis(10,1) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - 6*Sqrt(2.0d0)*v + 3*w)/12.0

6026
             WorkBasis(10,2) = (5*Sqrt(6.0d0)*v - 3*Sqrt(3.0d0)*w)/12.0

6027
             WorkBasis(10,3) = -w/(2.0*Sqrt(6.0d0))

6028
             WorkBasis(11,1) = (-5*Sqrt(6.0d0) + 5*Sqrt(6.0d0)*u + 6*Sqrt(2.0d0)*v + 6*w)/12.0

6029
             WorkBasis(11,2) = -v/(2.0*Sqrt(6.0d0))

6030
             WorkBasis(11,3) = -w/(2.0*Sqrt(6.0d0))

6031
             WorkBasis(12,1) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - 9*w)/12.0

6032
             WorkBasis(12,2) = (-(Sqrt(6.0d0)*v) + 3*Sqrt(3.0d0)*w)/12.0

6033
             WorkBasis(12,3) = (5*w)/(2.0*Sqrt(6.0d0))

6034


6035
             !----------------------------------------------------------------------

6036
             ! Find out how face basis functions must be ordered so that the global

6037
             ! indexing convention is respected. 

6038
             !-----------------------------------------------------------------------

6039
             CALL FaceElementBasisOrdering(Element, FDofMap(1:4,1:3))

6040


6041
             !-----------------------------------------------------

6042
             ! Now do the actual reordering and sign reversion

6043
             !-----------------------------------------------------

6044
             DO q=1,4

6045
                IF (ReverseSign(q)) THEN

6046
                   S = -1.0d0

6047
                ELSE

6048
                   S = 1.0d0

6049
                END IF

6050


6051
                DO j=1,DofsPerFace

6052
                   k = FDofMap(q,j)

6053
                   i = (q-1)*DofsPerFace + j

6054
                   FBasis(i,:) = S * WorkBasis((q-1)*DofsPerFace+k,:)

6055
                   DivBasis(i) = S * sqrt(3.0d0)/(2.0d0*sqrt(2.0d0))

6056
                END DO

6057
             END DO

6058


6059
          ELSE

6060
             DOFs = 4

6061
             !-------------------------------------------------------------------------

6062
             ! The basis functions that define RT space on reference element

6063
             !-----------------------------------------------------------------------

6064
             FBasis(1,1) = SQRT(2.0d0)/4.0d0 * u

6065
             FBasis(1,2) = -SQRT(6.0d0)/12.0d0 + SQRT(2.0d0)/4.0d0 * v

6066
             FBasis(1,3) = -1.0d0/SQRT(3.0d0) + SQRT(2.0d0)/4.0d0 * w

6067
             DivBasis(1) = 3.0d0*SQRT(2.0d0)/4.0d0

6068
             IF ( ReverseSign(1) ) THEN

6069
                FBasis(1,:) = -FBasis(1,:)

6070
                DivBasis(1) = -DivBasis(1)

6071
             END IF

6072


6073
             FBasis(2,1) = SQRT(2.0d0)/4.0d0 * u

6074
             FBasis(2,2) = -SQRT(6.0d0)/4.0d0 + SQRT(2.0d0)/4.0d0 * v

6075
             FBasis(2,3) = SQRT(2.0d0)/4.0d0 * w

6076
             DivBasis(2) = 3.0d0*SQRT(2.0d0)/4.0d0

6077
             IF ( ReverseSign(2) ) THEN

6078
                FBasis(2,:) = -FBasis(2,:)

6079
                DivBasis(2) = -DivBasis(2)

6080
             END IF

6081


6082
             FBasis(3,1) = SQRT(2.0d0)/4.0d0 + SQRT(2.0d0)/4.0d0 * u

6083
             FBasis(3,2) = SQRT(2.0d0)/4.0d0 * v

6084
             FBasis(3,3) = SQRT(2.0d0)/4.0d0 * w

6085
             DivBasis(3) = 3.0d0*SQRT(2.0d0)/4.0d0

6086
             IF ( ReverseSign(3) ) THEN

6087
                FBasis(3,:) = -FBasis(3,:)

6088
                DivBasis(3) = -DivBasis(3)

6089
             END IF

6090


6091
             FBasis(4,1) = -SQRT(2.0d0)/4.0d0 + SQRT(2.0d0)/4.0d0 * u

6092
             FBasis(4,2) = SQRT(2.0d0)/4.0d0 * v

6093
             FBasis(4,3) = SQRT(2.0d0)/4.0d0 * w

6094
             DivBasis(4) = 3.0d0*SQRT(2.0d0)/4.0d0

6095
             IF ( ReverseSign(4) ) THEN

6096
                FBasis(4,:) = -FBasis(4,:)

6097
                DivBasis(4) = -DivBasis(4)

6098
             END IF

6099
          END IF

6100
       CASE(8)

6101
         !--------------------------------------------------------------

6102
         ! This branch is for handling brick elements

6103
         !--------------------------------------------------------------  

6104
         ! Check first whether a sign reverse will be needed.

6105
         ! If the sign is not reversed, the positive value of the degree of freedom produces

6106
         ! positive outward flux from the element through the face handled.

6107
         !-----------------------------------------------------------------------------------

6108
         CALL FaceElementOrientation(Element, ReverseSign)

6109


6110
         DOFs = 48   ! 4 DOFs per face and 24 elementwise DOFs

6111
         DofsPerFace = 4

6112
         WorkBasis = 0.0d0

6113


6114
         !

6115
         ! Face 2143:

6116
         !

6117
         SquareFaceMap(:) = (/ 2,1,4,3 /)

6118
         DO q=1,4

6119
           WorkBasis(q,3) = -1.0d0 * QuadNodalPBasis(SquareFaceMap(q), u, v) * LineNodalPBasis(1, w)

6120
           WorkDivBasis(q) = -1.0d0 * QuadNodalPBasis(SquareFaceMap(q), u, v) * dLineNodalPBasis(1, w)

6121
         END DO

6122


6123
         !

6124
         ! Face 5678:

6125
         !

6126
         DO q=1,4

6127
           WorkBasis(4+q,3) = QuadNodalPBasis(q, u, v) * LineNodalPBasis(2, w)

6128
           WorkDivBasis(4+q) = QuadNodalPBasis(q, u, v) * dLineNodalPBasis(2, w)

6129
         END DO

6130
         

6131
         !

6132
         ! Face 1265:

6133
         !         

6134
         DO q=1,4

6135
           WorkBasis(8+q,2) = -1.0d0 * QuadNodalPBasis(q, u, w) * LineNodalPBasis(1, v)

6136
           WorkDivBasis(8+q) = -1.0d0 * QuadNodalPBasis(q, u, w) * dLineNodalPBasis(1, v)

6137
         END DO

6138


6139
         !

6140
         ! Face 2376:

6141
         !         

6142
         DO q=1,4

6143
           WorkBasis(12+q,1) = QuadNodalPBasis(q, v, w) * LineNodalPBasis(2, u)

6144
           WorkDivBasis(12+q) = QuadNodalPBasis(q, v, w) * dLineNodalPBasis(2, u)

6145
         END DO

6146


6147
         !

6148
         ! Face 3487:

6149
         !

6150
         SquareFaceMap(:) = (/ 2,1,4,3 /)

6151
         DO q=1,4

6152
           WorkBasis(16+q,2) = QuadNodalPBasis(SquareFaceMap(q), u, w) * LineNodalPBasis(2, v)

6153
           WorkDivBasis(16+q) = QuadNodalPBasis(SquareFaceMap(q), u, w) * dLineNodalPBasis(2, v)

6154
         END DO

6155


6156
         !

6157
         ! Face 4152:

6158
         !

6159
         SquareFaceMap(:) = (/ 2,1,4,3 /)

6160
         DO q=1,4

6161
           WorkBasis(20+q,1) = -1.0d0 * QuadNodalPBasis(SquareFaceMap(q), v, w) * LineNodalPBasis(1, u)

6162
           WorkDivBasis(20+q) = -1.0d0 * QuadNodalPBasis(SquareFaceMap(q), v, w) * dLineNodalPBasis(1, u)

6163
         END DO

6164


6165
         !----------------------------------------------------------------------

6166
         ! Find out how face basis functions must be ordered so that the global

6167
         ! indexing convention is respected. 

6168
         !-----------------------------------------------------------------------

6169
         CALL FaceElementBasisOrdering(Element, FDofMap(1:6,1:4))

6170


6171
         !-----------------------------------------------------

6172
         ! Now do the actual reordering and sign reverses

6173
         !-----------------------------------------------------

6174
         DO q=1,6

6175
           IF (ReverseSign(q)) THEN

6176
             S = -1.0d0

6177
           ELSE

6178
             S = 1.0d0

6179
           END IF

6180


6181
           DO j=1,DofsPerFace

6182
             k = FDofMap(q,j)

6183
             i = (q-1)*DofsPerFace + j

6184
             FBasis(i,:) = S * WorkBasis((q-1)*DofsPerFace+k,:)

6185
             DivBasis(i) = S * WorkDivBasis((q-1)*DofsPerFace+k)

6186
           END DO

6187
         END DO

6188


6189
         !

6190
         ! 24 interior basis functions (8 per coordinate direction)

6191
         !

6192
         k = 24

6193
         DO j=1,2

6194
           SELECT CASE(j)

6195
           CASE(1)

6196
             fun = 1.0d0

6197
             dfun = 0.0d0

6198
           CASE(2)

6199
             fun = 2.0d0 * u

6200
             dfun = 2.0d0

6201
           END SELECT

6202
           DO q=1,4

6203
             k = k + 1

6204
             FBasis(k,1) = QuadNodalPBasis(q, v, w) * LineNodalPBasis(1, u) * LineNodalPBasis(2, u) * fun

6205
             DivBasis(k) = QuadNodalPBasis(q, v, w) * ( dLineNodalPBasis(1, u) * LineNodalPBasis(2, u) * fun + &

6206
                 LineNodalPBasis(1, u) * dLineNodalPBasis(2, u) * fun + &

6207
                 LineNodalPBasis(1, u) * LineNodalPBasis(2, u) * dfun )

6208
           END DO

6209
         END DO

6210


6211
         DO j=1,2

6212
           SELECT CASE(j)

6213
           CASE(1)

6214
             fun = 1.0d0

6215
             dfun = 0.0d0

6216
           CASE(2)

6217
             fun = 2.0d0 * v

6218
             dfun = 2.0d0

6219
           END SELECT

6220
           DO q=1,4

6221
             k = k + 1

6222
             FBasis(k,2) = QuadNodalPBasis(q, u, w) * LineNodalPBasis(1, v) * LineNodalPBasis(2, v) * fun

6223
             DivBasis(k) = QuadNodalPBasis(q, u, w) * ( dLineNodalPBasis(1, v) * LineNodalPBasis(2, v) * fun + &

6224
                 LineNodalPBasis(1, v) * dLineNodalPBasis(2, v) * fun + &

6225
                 LineNodalPBasis(1, v) * LineNodalPBasis(2, v) * dfun )

6226
           END DO

6227
         END DO

6228


6229
         DO j=1,2

6230
           SELECT CASE(j)

6231
           CASE(1)

6232
             fun = 1.0d0

6233
             dfun = 0.0d0

6234
           CASE(2)

6235
             fun = 2.0d0 * w

6236
             dfun = 2.0d0

6237
           END SELECT

6238
           DO q=1,4

6239
             k = k + 1

6240
             FBasis(k,3) = QuadNodalPBasis(q, u, v) * LineNodalPBasis(1, w) * LineNodalPBasis(2, w) * fun

6241
             DivBasis(k) = QuadNodalPBasis(q, u, v) * ( dLineNodalPBasis(1, w) * LineNodalPBasis(2, w) * fun + &

6242
                 LineNodalPBasis(1, w) * dLineNodalPBasis(2, w) * fun + &

6243
                 LineNodalPBasis(1, w) * LineNodalPBasis(2, w) * dfun )

6244
           END DO

6245
         END DO

6246


6247
       CASE DEFAULT

6248
          CALL Fatal('ElementDescription::FaceElementInfo','Unsupported element type')

6249
       END SELECT

6250


6251
       IF (PerformPiolaTransform) THEN

6252
         DO j=1,DOFs

6253
           DO k=1,dim

6254
             WorkBasis(1,k) = SUM( LF(k,1:dim) * FBasis(j,1:dim) )

6255
           END DO

6256
           FBasis(j,1:dim) = 1.0d0/DetF * WorkBasis(1,1:dim)

6257
           

6258
           DivBasis(j) = 1.0d0/DetF * DivBasis(j)

6259
         END DO

6260
         ! Make the returned value DetF to act as a metric term for integration

6261
         ! over the volume of the element:

6262
         IF (PRESENT(LeftHanded)) LeftHanded = detF < 0.0d0

6263
         DetF = ABS(DetF)

6264
       END IF

6265


6266
       ! ----------------------------------------------------------------------

6267
       ! Get global first derivatives of the nodal basis functions if wanted:

6268
       ! ----------------------------------------------------------------------

6269
       IF ( PRESENT(dBasisdx) ) THEN

6270
         dBasisdx = 0.0d0

6271
         IF (cdim == dim) THEN       

6272
           DO i=1,n

6273
             DO j=1,dim

6274
               DO k=1,dim

6275
                 dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LG(j,k)

6276
               END DO

6277
             END DO

6278
           END DO

6279
         ELSE

6280
           CALL Warn('ElementDescription::FaceElementInfo', &

6281
               'Cannot return gradient for elements embedded in a higher-dimensional space')

6282
         END IF

6283
       END IF

6284
       

6285
       IF (PRESENT(F)) F = LF

6286
       IF (PRESENT(DivFBasis)) DivFBasis(1:DOFs) = DivBasis(1:DOFs)

6287
!-----------------------------------------------------------------------------

6288
     END FUNCTION FaceElementInfo

6289
!------------------------------------------------------------------------------

6290


6291


6292
!----------------------------------------------------------------------------------------------

6293
!> This function returns data for performing the Piola transformation 

6294
!------------------------------------------------------------------------------------------------

6295
     FUNCTION PiolaTransformationData(nn,Element,Nodes,F,DetF,dLBasisdx) RESULT(Success)

6296
!-------------------------------------------------------------------------------------------------

6297
       INTEGER :: nn                   !< The number of classic nodes used in the element mapping

6298
       TYPE(Element_t) :: Element      !< Element structure

6299
       TYPE(Nodes_t) :: Nodes          !< Data corresponding to the classic element nodes

6300
       REAL(KIND=dp) :: F(:,:)         !< The gradient of the element mapping

6301
       REAL(KIND=dp) :: DetF           !< The determinant of the gradient matrix (or the Jacobian matrix)

6302
       REAL(KIND=dp) :: dLBasisdx(:,:) !< Derivatives of nodal basis functions with respect to local coordinates

6303
       LOGICAL :: Success              !< Could and should return .FALSE. if the element is degenerate

6304
!-----------------------------------------------------------------------------------------------------

6305
!      Local variables

6306
!-------------------------------------------------------------------------------------------------

6307
       REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z

6308
       INTEGER :: cdim,dim,n,i

6309
!-------------------------------------------------------------------------------------------------

6310
       x => Nodes % x

6311
       y => Nodes % y

6312
       z => Nodes % z     

6313


6314
       ! cdim = CoordinateSystemDimension()

6315
       n = MIN( SIZE(x), nn )

6316
       dim  = Element % TYPE % DIMENSION

6317


6318
       !------------------------------------------------------------------------------

6319
       ! The gradient of the element mapping K = f(k), with k the reference element

6320
       !------------------------------------------------------------------------------

6321
       F = 0.0d0

6322
       DO i=1,dim

6323
          F(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) )

6324
          F(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) )

6325
          !IF (dim == 3) &

6326
          ! In addition to the case dim = 3, the following entries may be useful  

6327
          ! with dim=2 when natural BCs in 3-D are handled. 

6328
          F(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) )

6329
       END DO

6330


6331
       SELECT CASE( dim )

6332
       CASE(1)

6333
          DetF = sqrt(SUM(F(1:3,1)**2))

6334
       CASE (2)

6335
          DetF = F(1,1)*F(2,2) - F(1,2)*F(2,1)

6336
       CASE(3)

6337
          DetF = F(1,1) * ( F(2,2)*F(3,3) - F(2,3)*F(3,2) ) + &

6338
               F(1,2) * ( F(2,3)*F(3,1) - F(2,1)*F(3,3) ) + &

6339
               F(1,3) * ( F(2,1)*F(3,2) - F(2,2)*F(3,1) )

6340
       END SELECT

6341


6342
       success = .TRUE.

6343
!------------------------------------------------

6344
     END FUNCTION PiolaTransformationData

6345
!------------------------------------------------

6346


6347
!-----------------------------------------------------------------------------------

6348
!> Get information about whether a sign reversion will be needed to obtain right

6349
!> DOFs for face (vector) elements. If the sign is not reversed, the positive value of 

6350
!> the degree of freedom produces positive outward flux from the element through 

6351
!> the face handled.

6352
!-----------------------------------------------------------------------------------

6353
SUBROUTINE FaceElementOrientation(Element, ReverseSign, FaceIndex, Nodes)

6354
!-----------------------------------------------------------------------------------

6355
  IMPLICIT NONE

6356


6357
  TYPE(Element_t), INTENT(IN) :: Element       !< A 3-D/2-D element having 2-D/1-D faces 

6358
  LOGICAL, INTENT(OUT) :: ReverseSign(:)       !< Face-wise information about the sign reversions

6359
  INTEGER, OPTIONAL, INTENT(IN) :: FaceIndex   !< Check just one face that is specified here

6360
  TYPE(Nodes_t), OPTIONAL :: Nodes             !< An inactive variable related to code verification

6361
!-----------------------------------------------------------------------------------

6362
  TYPE(Mesh_t), POINTER :: Mesh

6363
  LOGICAL :: Parallel

6364
  

6365
  INTEGER, POINTER :: FaceMap(:,:)

6366
  INTEGER, TARGET :: TetraFaceMap(4,3), BrickFaceMap(6,4)

6367
  INTEGER :: FaceIndices(4), GIndexes(27)

6368
  INTEGER :: j, q, first_face, last_face

6369


6370
  ! Some inactive variables that were used in the code verification

6371
  LOGICAL :: ReverseSign2(4), CheckSignReversions

6372
  INTEGER :: n, i, k, A, B, C, D, I1, I2

6373
  REAL(KIND=dp) :: t1(3), t2(3), m(3), e(3), D1, D2

6374
!-----------------------------------------------------------------------------------

6375
  ReverseSign(:) = .FALSE.

6376


6377
  IF (PRESENT(FaceIndex)) THEN

6378
    first_face = FaceIndex

6379
    last_face = FaceIndex

6380
  ELSE

6381
    first_face = 1

6382
  END IF

6383


6384
  Mesh => CurrentModel % Solver % Mesh

6385
  Parallel = ASSOCIATED(Mesh % ParallelInfo % GInterface)

6386


6387
  n = Element % Type % NumberOfNodes

6388
  GIndexes(1:n) = Element % NodeIndexes(1:n)

6389
  IF( Parallel ) GIndexes(1:n) = Mesh % ParallelInfo % GlobalDOFs(GIndexes(1:n))

6390
  

6391
  SELECT CASE(Element % TYPE % ElementCode / 100)

6392
  CASE(3)

6393
    FaceMap => GetEdgeMap(3) 

6394


6395
    IF (.NOT. PRESENT(FaceIndex)) last_face = 3

6396
    IF (SIZE(ReverseSign) < last_face) CALL Fatal('FaceElementOrientation', &

6397
        'Too small array for listing element faces')

6398
    

6399
    DO q=first_face,last_face

6400
      FaceIndices(1:2) = GIndexes((FaceMap(q,1:2)))

6401
      IF (FaceIndices(2) < FaceIndices(1)) ReverseSign(q) = .TRUE.

6402
    END DO

6403


6404
  CASE(4)

6405
    FaceMap => GetEdgeMap(4)

6406


6407
    IF (.NOT. PRESENT(FaceIndex)) last_face = 4

6408
    IF (SIZE(ReverseSign) < last_face) CALL Fatal('FaceElementOrientation', &

6409
        'Too small array for listing element faces')

6410
    

6411
    DO q=first_face,last_face

6412
      FaceIndices(1:2) = GIndexes((FaceMap(q,1:2)))

6413
      IF (FaceIndices(2) < FaceIndices(1)) ReverseSign(q) = .TRUE.

6414
    END DO

6415


6416
  CASE(5)

6417
    TetraFaceMap(1,:) = (/ 2, 1, 3 /)

6418
    TetraFaceMap(2,:) = (/ 1, 2, 4 /)

6419
    TetraFaceMap(3,:) = (/ 2, 3, 4 /) 

6420
    TetraFaceMap(4,:) = (/ 3, 1, 4 /)

6421


6422
    FaceMap => TetraFaceMap

6423


6424
    IF (.NOT. PRESENT(FaceIndex)) last_face = 4

6425
    IF (SIZE(ReverseSign) < last_face) CALL Fatal('FaceElementOrientation', &

6426
        'Too small array for listing element faces')

6427


6428
    DO q=first_face,last_face

6429
      FaceIndices(1:3) = GIndexes(FaceMap(q,1:3))

6430
      IF ( (FaceIndices(1) < FaceIndices(2)) .AND. (FaceIndices(1) < FaceIndices(3)) ) THEN

6431
        IF (FaceIndices(3) < FaceIndices(2)) THEN

6432
          ReverseSign(q) = .TRUE.

6433
        END IF

6434
      ELSE IF ( ( FaceIndices(2) < FaceIndices(1) ) .AND. ( FaceIndices(2) < FaceIndices(3) ) ) THEN

6435
        IF ( FaceIndices(1) < FaceIndices(3) ) THEN

6436
          ReverseSign(q) = .TRUE.

6437
        END IF

6438
      ELSE  

6439
        IF ( FaceIndices(2) < FaceIndices(1) ) THEN

6440
          ReverseSign(q) = .TRUE.

6441
        END IF

6442
      END IF

6443
    END DO

6444


6445
    !----------------------------------------------------------------------

6446
    ! Another way for finding sign reversions in the case of tetrahedron. 

6447
    ! This code is retained here, although it was used for verification purposes...

6448
    !----------------------------------------------------------------------

6449
    CheckSignReversions = .FALSE.

6450
    IF (CheckSignReversions) THEN

6451
      DO q=1,4

6452
        ReverseSign2(q) = .FALSE.

6453
        i = FaceMap(q,1)

6454
        j = FaceMap(q,2)

6455
        k = FaceMap(q,3)

6456


6457
        IF ( ( GIndexes(i) < GIndexes(j) ) .AND. ( GIndexes(i) < GIndexes(k) ) ) THEN

6458
          A = i

6459
          IF (GIndexes(j) < GIndexes(k)) THEN

6460
            B = j

6461
            C = k

6462
          ELSE

6463
            B = k

6464
            C = j

6465
          END IF

6466
        ELSE IF ( ( GIndexes(j) < GIndexes(i) ) .AND. ( GIndexes(j) < GIndexes(k) ) ) THEN

6467
          A = j

6468
          IF (GIndexes(i) < GIndexes(k)) THEN

6469
            B = i

6470
            C = k

6471
          ELSE

6472
            B = k

6473
            C = i

6474
          END IF

6475
        ELSE

6476
          A = k

6477
          IF (GIndexes(i) < GIndexes(j)) THEN

6478
            B = i

6479
            C = j

6480
          ELSE

6481
            B = j

6482
            C = i

6483
          END IF

6484
        END IF

6485


6486
        t1(1) = Nodes % x(B) - Nodes % x(A)

6487
        t1(2) = Nodes % y(B) - Nodes % y(A)              

6488
        t1(3) = Nodes % z(B) - Nodes % z(A)

6489


6490
        t2(1) = Nodes % x(C) - Nodes % x(A)

6491
        t2(2) = Nodes % y(C) - Nodes % y(A)              

6492
        t2(3) = Nodes % z(C) - Nodes % z(A)

6493


6494
        m(1:3) = CrossProduct(t1,t2)

6495


6496
        SELECT CASE(q)

6497
        CASE(1)

6498
          D = 4

6499
        CASE(2)

6500
          D = 3 

6501
        CASE(3)

6502
          D = 1

6503
        CASE(4)

6504
          D = 2                   

6505
        END SELECT

6506


6507
        e(1) = Nodes % x(D) - Nodes % x(A)

6508
        e(2) = Nodes % y(D) - Nodes % y(A)                

6509
        e(3) = Nodes % z(D) - Nodes % z(A)  

6510


6511
        IF ( SUM(m(1:3) * e(1:3)) > 0.0d0 ) ReverseSign2(q) = .TRUE.

6512


6513
      END DO

6514


6515
      IF ( ANY(ReverseSign(1:4) .NEQV. ReverseSign2(1:4)) ) THEN

6516
        PRINT *, 'CONFLICTING SIGN REVERSIONS SUGGESTED'

6517
        PRINT *, ReverseSign(1:4)

6518
        PRINT *, ReverseSign2(1:4)

6519
        STOP EXIT_ERROR

6520
      END IF

6521
    END IF

6522


6523
  CASE(8)

6524
    !

6525
    ! Write the face map such that by default the normal points outwards

6526
    ! from the brick:

6527
    !

6528
    BrickFaceMap(1,:) = (/ 2, 1, 4, 3 /)

6529
    BrickFaceMap(2,:) = (/ 5, 6, 7, 8 /)

6530
    BrickFaceMap(3,:) = (/ 1, 2, 6, 5 /)

6531
    BrickFaceMap(4,:) = (/ 2, 3, 7, 6 /)

6532
    BrickFaceMap(5,:) = (/ 3, 4, 8, 7 /)

6533
    BrickFaceMap(6,:) = (/ 4, 1, 5, 8 /)

6534


6535
    FaceMap => BrickFaceMap

6536


6537
    IF (.NOT. PRESENT(FaceIndex)) last_face = 6

6538
    IF (SIZE(ReverseSign) < last_face) CALL Fatal('FaceElementOrientation', &

6539
        'Too small array for listing element faces')

6540


6541
    DO q=first_face,last_face

6542
      FaceIndices(1:4) = GIndexes(FaceMap(q,1:4))    

6543
      CALL SquareFaceDofsOrdering(I1, I2, D1, D2, FaceIndices(1:4), ReverseSign(q))

6544
    END DO

6545


6546
  CASE DEFAULT

6547
    CALL Fatal('FaceElementOrientation', 'Unsupported element family')

6548
  END SELECT

6549
!-----------------------------------------------------------------------------------

6550
END SUBROUTINE FaceElementOrientation

6551
!-----------------------------------------------------------------------------------

6552


6553
!-----------------------------------------------------------------------------------

6554
!> This subroutine produces information about how the basis functions of face (vector)

6555
!> elements have to be reordered to conform with the global ordering convention.

6556
!-----------------------------------------------------------------------------------

6557
SUBROUTINE FaceElementBasisOrdering(Element, FDofMap, FaceIndex, ReverseSign)

6558
!-----------------------------------------------------------------------------------

6559
  IMPLICIT NONE

6560


6561
  TYPE(Element_t), INTENT(IN) :: Element       !< A 3-D element having 2-D faces

6562
  INTEGER, INTENT(OUT) :: FDofMap(:,:)         !< Face-wise information for the basis permutation  

6563
  INTEGER, OPTIONAL, INTENT(IN) :: FaceIndex   !< Check just one face that is specified here

6564
  LOGICAL, OPTIONAL, INTENT(OUT) :: ReverseSign(:) !< For bricks face-wise information about the sign reversions

6565
!-----------------------------------------------------------------------------------

6566
  TYPE(Mesh_t), POINTER :: Mesh 

6567
  LOGICAL :: Parallel

6568
  LOGICAL :: ReverseNormal(6)

6569
  INTEGER, POINTER :: FaceMap(:,:)

6570
  INTEGER, TARGET :: TetraFaceMap(4,3), BrickFaceMap(6,4), FaceIndices(4), GIndexes(27)

6571
  INTEGER :: n, i, j, k, l, q, first_face, last_face

6572
!-----------------------------------------------------------------------------------

6573
  FDofMap = 0

6574
  ReverseNormal(:) = .FALSE.

6575


6576
  IF (PRESENT(FaceIndex)) THEN

6577
    first_face = FaceIndex

6578
    last_face = FaceIndex

6579
  ELSE

6580
    first_face = 1

6581
  END IF

6582


6583
  Mesh => CurrentModel % Solver % Mesh

6584
  Parallel = ASSOCIATED(Mesh % ParallelInfo % GInterface)

6585
  

6586
  n = Element % TYPE % NumberOfNodes

6587
  GIndexes(1:n) = Element % NodeIndexes(1:n)

6588
  IF( Parallel ) GIndexes(1:n) = Mesh % ParallelInfo % GlobalDOFs(GIndexes(1:n))

6589
  

6590


6591
  SELECT CASE(Element % TYPE % ElementCode / 100)

6592
  CASE(5)

6593
    !

6594
    ! This handles the tetrahedron of Nedelec's second family

6595
    !

6596
    TetraFaceMap(1,:) = (/ 2, 1, 3 /)

6597
    TetraFaceMap(2,:) = (/ 1, 2, 4 /)

6598
    TetraFaceMap(3,:) = (/ 2, 3, 4 /) 

6599
    TetraFaceMap(4,:) = (/ 3, 1, 4 /)

6600


6601
    FaceMap => TetraFaceMap

6602


6603
    IF (.NOT. PRESENT(FaceIndex)) last_face = 4

6604


6605
    DO q=first_face,last_face

6606
      FaceIndices(1:3) = GIndexes(FaceMap(q,1:3))

6607
      IF ( ( FaceIndices(1) < FaceIndices(2) ) .AND. ( FaceIndices(1) < FaceIndices(3) ) ) THEN

6608
        FDofMap(q,1) = 1

6609
        IF (FaceIndices(2) < FaceIndices(3)) THEN

6610
          FDofMap(q,2) = 2

6611
          FDofMap(q,3) = 3                      

6612
        ELSE

6613
          FDofMap(q,2) = 3

6614
          FDofMap(q,3) = 2

6615
        END IF

6616
      ELSE IF ( ( FaceIndices(2) < FaceIndices(1) ) .AND. ( FaceIndices(2) < FaceIndices(3) ) ) THEN

6617
        FDofMap(q,1) = 2

6618
        IF (FaceIndices(1) < FaceIndices(3)) THEN

6619
          FDofMap(q,2) = 1

6620
          FDofMap(q,3) = 3

6621
        ELSE

6622
          FDofMap(q,2) = 3

6623
          FDofMap(q,3) = 1

6624
        END IF

6625
      ELSE

6626
        FDofMap(q,1) = 3

6627
        IF (FaceIndices(1) < FaceIndices(2)) THEN

6628
          FDofMap(q,2) = 1

6629
          FDofMap(q,3) = 2 

6630
        ELSE

6631
          FDofMap(q,2) = 2

6632
          FDofMap(q,3) = 1 

6633
        END IF

6634
      END IF

6635
    END DO

6636


6637
  CASE(8)

6638
    !

6639
    ! Write the face map such that by default the normal points outwards

6640
    ! from the brick:

6641
    !

6642
    BrickFaceMap(1,:) = (/ 2, 1, 4, 3 /)

6643
    BrickFaceMap(2,:) = (/ 5, 6, 7, 8 /)

6644
    BrickFaceMap(3,:) = (/ 1, 2, 6, 5 /)

6645
    BrickFaceMap(4,:) = (/ 2, 3, 7, 6 /)

6646
    BrickFaceMap(5,:) = (/ 3, 4, 8, 7 /)

6647
    BrickFaceMap(6,:) = (/ 4, 1, 5, 8 /)

6648


6649
    FaceMap => BrickFaceMap

6650


6651
    IF (.NOT. PRESENT(FaceIndex)) last_face = 6

6652


6653
    DO q=first_face,last_face

6654
      FaceIndices(1:4) = GIndexes(FaceMap(q,1:4))

6655
    

6656
!      CALL SquareFaceDofsOrdering(I1, I2, D1, D2, FaceIndices(1:4), ReverseSign(q))

6657


6658
      i = 1

6659
      j = 2

6660
      IF ( FaceIndices(i) < FaceIndices(j) ) THEN

6661
        k = i

6662
      ELSE

6663
        k = j

6664
      END IF

6665
      i = 4

6666
      j = 3 

6667
      IF ( FaceIndices(i) < FaceIndices(j) ) THEN

6668
        l = i

6669
      ELSE

6670
        l = j

6671
      END IF

6672
      IF ( FaceIndices(k) > FaceIndices(l) ) THEN

6673
        k = l

6674
      END IF

6675
!      A = k

6676


6677
      SELECT CASE(k)

6678
      CASE(1)

6679
        FDofMap(q,1) = 1

6680
        FDofMap(q,3) = 3

6681
        IF ( FaceIndices(2) < FaceIndices(4) ) THEN

6682
          FDofMap(q,2) = 2

6683
          FDofMap(q,4) = 4

6684
        ELSE

6685
          FDofMap(q,2) = 4

6686
          FDofMap(q,4) = 2

6687
          ReverseNormal(q) = .TRUE.

6688
        END IF

6689
      CASE(2)

6690
        FDofMap(q,2) = 1

6691
        FDofMap(q,4) = 3

6692
        IF ( FaceIndices(3) < FaceIndices(1) ) THEN

6693
          FDofMap(q,1) = 4

6694
          FDofMap(q,3) = 2

6695
        ELSE

6696
          FDofMap(q,1) = 2

6697
          FDofMap(q,3) = 4

6698
          ReverseNormal(q) = .TRUE.

6699
        END IF

6700
      CASE(3)

6701
        FDofMap(q,3) = 1

6702
        FDofMap(q,1) = 3

6703
        IF ( FaceIndices(4) < FaceIndices(2) ) THEN

6704
          FDofMap(q,2) = 4

6705
          FDofMap(q,4) = 2

6706
        ELSE

6707
          FDofMap(q,2) = 2

6708
          FDofMap(q,4) = 4

6709
          ReverseNormal(q) = .TRUE.

6710
        END IF

6711
      CASE(4)

6712
        FDofMap(q,4) = 1

6713
        FDofMap(q,2) = 3

6714
        IF ( FaceIndices(1) < FaceIndices(3) ) THEN

6715
          FDofMap(q,1) = 2

6716
          FDofMap(q,3) = 4

6717
        ELSE

6718
          FDofMap(q,1) = 4

6719
          FDofMap(q,3) = 2

6720
          ReverseNormal(q) = .TRUE.

6721
        END IF

6722
      CASE DEFAULT

6723
        CALL Fatal('ElementDescription::FaceElementBasisOrdering','Erratic square face Indices')

6724
      END SELECT

6725


6726
    END DO

6727


6728
    IF (PRESENT(ReverseSign)) ReverseSign(1:6) = ReverseNormal(1:6)

6729


6730
  CASE DEFAULT

6731
    CALL Fatal('FaceElementBasisOrdering', 'Unsupported element family')

6732
  END SELECT

6733
!-----------------------------------------------------------------------------------

6734
END SUBROUTINE FaceElementBasisOrdering

6735
!-----------------------------------------------------------------------------------

6736


6737


6738
!------------------------------------------------------------------------------

6739
!> Here the given element can be supposed to be some face of its parent element.

6740
!> The index of the face in reference to the parent element and pointer

6741
!> to the face are returned. The given element and the face returned are thus

6742
!> representations of the same entity but they may still be indexed differently.

6743
!------------------------------------------------------------------------------

6744
SUBROUTINE PickActiveFace(Mesh, Parent, Element, Face, ActiveFaceId)

6745
!------------------------------------------------------------------------------

6746
  IMPLICIT NONE

6747
  TYPE(Mesh_t), POINTER, INTENT(IN) :: Mesh  

6748
  TYPE(Element_t), POINTER, INTENT(IN) :: Parent, Element

6749
  TYPE(Element_t), POINTER, INTENT(OUT) :: Face

6750
  INTEGER, INTENT(OUT) :: ActiveFaceId

6751
!------------------------------------------------------------------------------

6752
  INTEGER :: matches, k, l

6753
!------------------------------------------------------------------------------

6754
  SELECT CASE(Element % TYPE % ElementCode / 100)

6755
  CASE(2)

6756
    IF ( ASSOCIATED(Parent % EdgeIndexes) ) THEN

6757
      DO ActiveFaceId=1,Parent % TYPE % NumberOfEdges

6758
        Face => Mesh % Edges(Parent % EdgeIndexes(ActiveFaceId))

6759
        matches = 0

6760
        DO k=1,Element % TYPE % NumberOfNodes

6761
          DO l=1,Face % TYPE % NumberOfNodes

6762
            IF (Element % NodeIndexes(k) == Face % NodeIndexes(l)) &

6763
                matches=matches+1

6764
          END DO

6765
        END DO

6766
        IF (matches==Element % TYPE % NumberOfNodes) EXIT

6767
      END DO

6768
    ELSE

6769
      matches = 0

6770
    END IF

6771
  CASE(3,4)

6772
    IF ( ASSOCIATED(Parent % FaceIndexes) ) THEN

6773
      DO ActiveFaceId=1,Parent % TYPE % NumberOfFaces

6774
        Face => Mesh % Faces(Parent % FaceIndexes(ActiveFaceId))

6775
        IF ((Element % TYPE % ElementCode / 100) /= (Face % TYPE % ElementCode / 100)) CYCLE

6776
        matches = 0

6777
        DO k=1,Element % TYPE % NumberOfNodes

6778
          DO l=1,Face % TYPE % NumberOfNodes

6779
            IF (Element % NodeIndexes(k) == Face % NodeIndexes(l)) &

6780
                matches=matches+1

6781
          END DO

6782
        END DO

6783
        IF (matches == Element % TYPE % NumberOfNodes ) EXIT

6784
      END DO

6785
    ELSE

6786
      matches = 0

6787
    END IF

6788
  CASE DEFAULT

6789
    CALL Fatal('PickActiveFace', 'Element variable is of a wrong dimension')

6790
  END SELECT

6791


6792
  IF (matches /= Element % TYPE % NumberOfNodes) THEN

6793
    Face => NULL()

6794
    ActiveFaceId = 0

6795
    CALL Warn('PickActiveFace', 'The element is not a face of given parent')

6796
  END IF

6797
!------------------------------------------------------------------------------

6798
END SUBROUTINE PickActiveFace

6799
!------------------------------------------------------------------------------

6800


6801


6802
!------------------------------------------------------------------------------

6803
!> Perform the cross product of two vectors

6804
!------------------------------------------------------------------------------

6805
     FUNCTION CrossProduct( v1, v2 ) RESULT( v3 )

6806
!------------------------------------------------------------------------------

6807
       IMPLICIT NONE

6808
       REAL(KIND=dp) :: v1(3), v2(3), v3(3)

6809
       v3(1) =  v1(2)*v2(3) - v1(3)*v2(2)

6810
       v3(2) = -v1(1)*v2(3) + v1(3)*v2(1)

6811
       v3(3) =  v1(1)*v2(2) - v1(2)*v2(1)

6812
!------------------------------------------------------------------------------

6813
     END FUNCTION CrossProduct

6814
!------------------------------------------------------------------------------

6815


6816


6817
!----------------------------------------------------------------------------------

6818
!>  Return H(curl)-conforming edge element basis function values and their Curl  

6819
!>  with respect to the reference element coordinates at a given point on the

6820
!>  reference element. Here the basis for a real element K is constructed by  

6821
!>  transforming the basis functions defined on the reference element k via a version

6822
!>  of the Piola transformation designed for functions in H(curl). This construction

6823
!>  differs from the approach taken in the alternate subroutine GetEdgeBasis, which

6824
!>  does not make reference to the Piola transformation and hence may have limitations

6825
!>  in its extendability. The data for performing the Piola transformation is also returned.

6826
!>  Note that the reference element is chosen as in the p-approximation so that

6827
!>  the reference element edges/faces have the same length/area. This choice simplifies

6828
!>  the associated assembly procedure.

6829
!>     With giving the optional argument ApplyPiolaTransform = .TRUE., this function

6830
!>  also performs the Piola transform, so that the basis functions and their spatial

6831
!>  curl as defined on the physical element are returned.

6832
!>     In the lowest-order case this function returns the basis functions belonging

6833
!>  to the optimal family which is not subject to degradation of convergence on

6834
!>  meshes consisting of non-affine physical elements. The second-order elements

6835
!>  are members of the Nedelec's first family and are constructed in a hierarchic

6836
!>  fashion (the lowest-order basis functions give a partial construction of

6837
!>  the second-order basis).

6838
!---------------------------------------------------------------------------------

6839
     FUNCTION EdgeElementInfo( Element, Nodes, u, v, w, F, G, detF, &

6840
          Basis, EdgeBasis, RotBasis, dBasisdx, SecondFamily, BasisDegree, &

6841
          ApplyPiolaTransform, ReadyEdgeBasis, ReadyRotBasis, &

6842
          TangentialTrMapping, SimplicialMesh) RESULT(stat)

6843
!------------------------------------------------------------------------------

6844
       IMPLICIT NONE

6845


6846
       TYPE(Element_t), TARGET :: Element        !< Element structure

6847
       TYPE(Nodes_t) :: Nodes                    !< Data corresponding to the classic element nodes

6848
       REAL(KIND=dp) :: u                        !< 1st reference element coordinate at which the basis functions are evaluated

6849
       REAL(KIND=dp) :: v                        !< 2nd local coordinate

6850
       REAL(KIND=dp) :: w                        !< 3rd local coordinate

6851
       REAL(KIND=dp), OPTIONAL :: F(3,3)         !< The gradient F=Grad f, with f the element map f:k->K

6852
       REAL(KIND=dp), OPTIONAL :: G(3,3)         !< The transpose of the inverse of the gradient F

6853
       REAL(KIND=dp) :: detF                     !< The determinant of the gradient matrix F

6854
       REAL(KIND=dp) :: Basis(:)                 !< H1-conforming basis functions evaluated at (u,v,w)

6855
       REAL(KIND=dp) :: EdgeBasis(:,:)           !< The basis functions b spanning the reference element space

6856
       REAL(KIND=dp), OPTIONAL :: RotBasis(:,:)  !< The Curl of the edge basis functions with respect to the local coordinates

6857
       REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:)  !< The first derivatives of the H1-conforming basis functions at (u,v,w)

6858
       LOGICAL, OPTIONAL :: SecondFamily         !< If .TRUE., a Nedelec basis of the second kind is returned (only simplicial elements)

6859
       INTEGER, OPTIONAL :: BasisDegree          !< The approximation degree 2 is also supported

6860
       LOGICAL, OPTIONAL :: ApplyPiolaTransform  !< If  .TRUE., perform the Piola transform so that, instead of b

6861
                                                 !< and Curl b, return  B(f(p)) and (curl B)(f(p)) with B(x) the basis 

6862
                                                 !< functions on the physical element and curl the spatial curl operator.

6863
                                                 !< In this case the absolute value of detF is returned.

6864
       REAL(KIND=dp), OPTIONAL :: ReadyEdgeBasis(:,:) !< A pretabulated edge basis function can be given

6865
       REAL(KIND=dp), OPTIONAL :: ReadyRotBasis(:,:)  !< The preretabulated Curl of the edge basis function

6866
       LOGICAL, OPTIONAL :: TangentialTrMapping  !< To return b x n, with n=(0,0,1) the normal to the 2D reference element.

6867
                                                 !< The Piola transform is then the usual div-conforming version.    

6868
       LOGICAL, OPTIONAL :: SimplicialMesh       !< Use an alternate basis of the first kind, needs simplicial elements

6869
       LOGICAL :: Stat                           !< .FALSE. for a degenerate element

6870
!-----------------------------------------------------------------------------------------------------------------

6871
!      Local variables

6872
!------------------------------------------------------------------------------------------------------------

6873
       TYPE(Mesh_t), POINTER :: Mesh

6874
       TYPE(Element_t), POINTER :: Parent, Face, pElement

6875
       INTEGER :: n, dim, cdim, q, i, j, k, l, A, I1, I2, I3, FaceIndices(4)

6876
       REAL(KIND=dp) :: dLbasisdx(MAX(SIZE(Nodes % x),SIZE(Basis)),3), WorkBasis(4,3), WorkCurlBasis(4,3)

6877
       REAL(KIND=dp) :: D1, D2, B(3), curlB(3), GT(3,3), LG(3,3), LF(3,3)

6878
       REAL(KIND=dp) :: ElmMetric(3,3), detJ, CurlBasis(54,3)

6879
       REAL(KIND=dp) :: t(3), s(3), v1, v2, v3, h1, h2, h3, dh1, dh2, dh3, grad(2)

6880
       REAL(KIND=dp) :: LBasis(Element % TYPE % NumberOfNodes), Beta(4), EdgeSign(16)

6881
       REAL(KIND=dp) :: fs1, fs2

6882
       REAL(KIND=dp) :: sfun, tfun, hfun, grad_sfun(3), grad_tfun(3), grad_hfun(3)

6883
       REAL(KIND=dp) :: svec(3), tvec(3), hvec(3), grad_svec(3,3), grad_tvec(3,3), grad_hvec(3,3)

6884
       REAL(KIND=dp) :: WorkWeight(2), grad_weight(2,1:3)

6885
       LOGICAL :: Create2ndKindBasis, PerformPiolaTransform, UsePretabulatedBasis, Parallel

6886
       LOGICAL :: SecondOrder, ThirdOrder, ApplyTraceMapping, Found

6887
       LOGICAL :: ReverseSign(4)

6888
       LOGICAL :: ScaleFaceBasis, RedefineFaceBasis

6889
       LOGICAL :: Simplicial

6890
       INTEGER, POINTER :: EdgeMap(:,:)

6891
       INTEGER :: TriangleFaceMap(3), SquareFaceMap(4), BrickFaceMap(6,4), PrismSquareFaceMap(3,4), DOFs, GIndexes(27)

6892
       INTEGER :: ActiveFaceId, EDOFs, FDOFs

6893
!----------------------------------------------------------------------------------------------------------

6894
       RedefineFaceBasis = .TRUE. ! Left as an emergency switch to revert to the original (ill-conditioned) basis

6895
       ScaleFaceBasis = .TRUE.

6896
       fs1 = 28.0d0

6897
       fs2 = 84.0d0

6898
       

6899
       Mesh => CurrentModel % Solver % Mesh

6900
       Parallel = ASSOCIATED(Mesh % ParallelInfo % GInterface)

6901


6902
       stat = .TRUE.

6903
       Basis = 0.0d0

6904
       EdgeBasis = 0.0d0

6905
       WorkBasis = 0.0d0

6906
       CurlBasis = 0.0d0

6907
       LG = 0.0d0

6908
       !--------------------------------------------------------------------------------------------

6909
       ! Check whether ready edge basis function values are available to reduce computation.

6910
       ! If they are available, this function is used primarily to obtain the Piola transformation.

6911
       !--------------------------------------------------------------------------------------------

6912
       UsePretabulatedBasis = .FALSE.

6913
       IF ( PRESENT(ReadyEdgeBasis) .AND. PRESENT(ReadyRotBasis) ) UsePretabulatedBasis = .TRUE.

6914
       !------------------------------------------------------------------------------------------

6915
       ! Check whether the Nedelec basis functions of the second kind or higher order basis

6916
       ! functions should be created and whether the Piola transform is already applied within 

6917
       ! this function.

6918
       !------------------------------------------------------------------------------------------

6919
       Create2ndKindBasis = .FALSE.

6920
       IF ( PRESENT(SecondFamily) ) Create2ndKindBasis = SecondFamily

6921
       SecondOrder = .FALSE.

6922
       ThirdOrder = .FALSE.

6923
       IF ( PRESENT(BasisDegree) ) THEN

6924
         SecondOrder = BasisDegree == 2

6925
         IF (.NOT. SecondOrder) ThirdOrder = BasisDegree == 3 

6926
       END IF

6927
       PerformPiolaTransform = .FALSE.

6928
       IF ( PRESENT(ApplyPiolaTransform) ) PerformPiolaTransform = ApplyPiolaTransform

6929
       

6930
       ApplyTraceMapping = .FALSE.

6931
       IF ( PRESENT(TangentialTrMapping) ) ApplyTraceMapping = TangentialTrMapping

6932


6933
       Simplicial = .FALSE.

6934
       IF ( PRESENT(SimplicialMesh) ) Simplicial = SimplicialMesh

6935
       IF (Simplicial .AND. .NOT.(Element % TYPE % ElementCode / 100 == 2 .OR. &

6936
           Element % TYPE % ElementCode / 100 == 3 .OR. &

6937
           Element % TYPE % ElementCode / 100 == 5)) THEN

6938
         CALL Fatal('EdgeElementInfo', 'Simplicial Mesh = True, but the element is not simplicial')

6939
       END IF

6940
           

6941
       !-------------------------------------------------------------------------------------------

6942
       dLbasisdx = 0.0d0      

6943
       n = Element % TYPE % NumberOfNodes

6944
       dim = Element % TYPE % DIMENSION

6945
       cdim = CoordinateSystemDimension()

6946


6947
       IF ( Element % TYPE % ElementCode == 101 ) THEN

6948
         detF = 1.0d0

6949
         Basis(1) = 1.0d0

6950
         IF ( PRESENT(dBasisdx) ) dBasisdx(1,:) = 0.0d0

6951
         RETURN

6952
       END IF

6953


6954
       GIndexes(1:n) = Element % NodeIndexes(1:n)

6955
       IF( Parallel ) GIndexes(1:n) = Mesh % ParallelInfo % GlobalDOFs(GIndexes(1:n))

6956
            

6957
       !IF (cdim == 3 .AND. dim==1) THEN

6958
       !  CALL Warn('EdgeElementInfo', 'Traces of 2-D edge elements have not been implemented yet')

6959
       !  RETURN

6960
       !END IF

6961


6962
       !-----------------------------------------------------------------------

6963
       ! The standard nodal basis functions on the reference element and

6964
       ! their derivatives with respect to the local coordinates. These define 

6965
       ! the mapping of the reference element to an actual element on the background 

6966
       ! mesh but are not the basis functions for the edge element approximation.

6967
       ! Remark: Using reference elements having the edges of the same length

6968
       ! simplifies the implementation of element assembly procedures.

6969
       !-----------------------------------------------------------------------

6970
       SELECT CASE(Element % TYPE % ElementCode / 100)

6971
       CASE(2)

6972
         IF (SecondOrder .AND. n==3) CALL Fatal('EdgeElementInfo', &

6973
             'The lowest-order background mesh needed for trace evaluation over an edge')

6974
         IF (Create2ndKindBasis) CALL Fatal('EdgeElementInfo', &

6975
             'Traces of 2-D edge elements (the 2nd family) have not been implemented yet')

6976
         IF (SecondOrder) THEN

6977
           DOFs = 2

6978
         ELSE

6979
           DOFs = 1

6980
         END IF

6981
         DO q=1,2

6982
           Basis(q) = LineNodalPBasis(q, u)

6983
           dLBasisdx(q,1) = dLineNodalPBasis(q, u)

6984
         END DO

6985
       CASE(3)

6986
         IF (SecondOrder .OR. ThirdOrder) THEN

6987
           ! DOFs is the number of H(curl)-conforming basis functions:

6988
           IF (SecondOrder) THEN

6989
             IF (Create2ndKindBasis) THEN

6990
               DOFs = 12

6991
             ELSE

6992
               DOFs = 8

6993
             END IF

6994
             IF (.NOT.(n==3 .OR. n==6)) CALL Fatal('EdgeElementInfo', 'A 3-node or 6-node background element expected')

6995
           ELSE

6996
             IF (Create2ndKindBasis) THEN

6997
               DOFs = 20

6998
             ELSE

6999
               DOFs = 15

7000
             END IF

7001
             IF (.NOT. n==3) CALL Fatal('EdgeElementInfo', 'A 3-node background element expected')

7002
           END IF

7003
             

7004
           IF (n == 6) THEN

7005
             ! Here the element of the background mesh is of type 306.

7006
             ! The Lagrange interpolation basis on the p-approximation reference element:

7007
             Basis(1) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v))/6.0d0

7008
             dLBasisdx(1,1) = -0.5d0 + u + v/Sqrt(3.0d0)

7009
             dLBasisdx(1,2) = (-Sqrt(3.0d0) + 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0

7010
             Basis(2) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(3.0d0 - 2.0d0*Sqrt(3.0d0)*v))/6.0d0

7011
             dLBasisdx(2,1) = 0.5d0 + u - v/Sqrt(3.d0)

7012
             dLBasisdx(2,2) = (-Sqrt(3.0d0) - 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0

7013
             Basis(3) = (v*(-Sqrt(3.0d0) + 2.0d0*v))/3.0d0

7014
             dLBasisdx(3,1) = 0.0d0

7015
             dLBasisdx(3,2) =  -(1.0d0/Sqrt(3.0d0)) + (4.0d0*v)/3.0d0

7016
             Basis(4) = (3.0d0 - 3.0d0*u**2 - 2.0d0*Sqrt(3.0d0)*v + v**2)/3.0d0

7017
             dLBasisdx(4,1) = -2.0d0*u

7018
             dLBasisdx(4,2) = (-2.0d0*(Sqrt(3.0d0) - v))/3.0d0

7019
             Basis(5) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - v)*v)/3.0d0

7020
             dLBasisdx(5,1) =  (2.0d0*v)/Sqrt(3.0d0)

7021
             dLBasisdx(5,2) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 2.0d0*v))/3.0d0

7022
             Basis(6) = (-2.0d0*v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v))/3.0d0           

7023
             dLBasisdx(6,1) = (-2.0d0*v)/Sqrt(3.0d0)

7024
             dLBasisdx(6,2) = (-2.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 2.0d0*v))/3.0d0

7025
           ELSE

7026
             ! Here the element of the background mesh is of type 303:

7027
             DO q=1,3

7028
               Basis(q) = TriangleNodalPBasis(q, u, v)

7029
               dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 

7030
             END DO

7031
           END IF

7032
         ELSE

7033
           DO q=1,n

7034
             Basis(q) = TriangleNodalPBasis(q, u, v)

7035
             dLBasisdx(q,1:2) = dTriangleNodalPBasis(q, u, v) 

7036
           END DO

7037
           IF (Create2ndKindBasis) THEN

7038
             DOFs = 6

7039
           ELSE

7040
             DOFs = 3

7041
           END IF

7042
         END IF

7043
       CASE(4)

7044
         IF (SecondOrder) THEN

7045
           ! The second-order quad from the Nedelec's first family: affine physical elements may be needed

7046
           DOFs = 12

7047
         ELSE

7048
           ! The lowest-order quad from the optimal family (ABF_0)

7049
           DOFs = 6

7050
         END IF

7051
         IF (n>4) THEN

7052
           ! Here the background mesh is supposed to be of type 408/409

7053
           CALL NodalBasisFunctions2D(Basis, Element, u, v)

7054
           CALL NodalFirstDerivatives(n, dLBasisdx, Element, u, v, w)

7055
         ELSE

7056
           ! Here the background mesh is of type 404           

7057
           DO q=1,4

7058
             Basis(q) = QuadNodalPBasis(q, u, v)

7059
             dLBasisdx(q,1:2) = dQuadNodalPBasis(q, u, v) 

7060
           END DO

7061
         END IF

7062
       CASE(5)

7063
         IF (SecondOrder) THEN

7064
           IF (Create2ndKindBasis) THEN

7065
             DOFs = 30

7066
           ELSE

7067
             DOFs = 20

7068
           END IF

7069
           IF (n == 10) THEN

7070
             ! Here the element of the background mesh is of type 510.

7071
             ! The Lagrange interpolation basis on the p-approximation reference element:

7072
             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 + &

7073
                 w**2 + 2.0d0*u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/12.0d0

7074
             dLBasisdx(1,1) = -0.5d0 + u + v/Sqrt(3.0d0) + w/Sqrt(6.0d0)

7075
             dLBasisdx(1,2) = (-Sqrt(3.0d0) + 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v + Sqrt(2.0d0)*w)/6.0d0

7076
             dLBasisdx(1,3) = (-Sqrt(6.0d0) + 2.0d0*Sqrt(6.0d0)*u + 2.0d0*Sqrt(2.0d0)*v + 2.0d0*w)/12.0d0

7077
             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 + &

7078
                 w**2 - 2.0d0*u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/12.0d0

7079
             dLBasisdx(2,1) = 0.5d0 + u - v/Sqrt(3.0d0) - w/Sqrt(6.0d0)

7080
             dLBasisdx(2,2) = (-Sqrt(3.0d0) - 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v + Sqrt(2.0d0)*w)/6.0d0

7081
             dLBasisdx(2,3) = (-Sqrt(6.0d0) - 2.0d0*Sqrt(6.0d0)*u + 2.0d0*Sqrt(2.0d0)*v + 2.0d0*w)/12.0d0

7082
             Basis(3) =  (8.0d0*v**2 + w*(Sqrt(6.0d0) + w) - 4.0d0*v*(Sqrt(3.0d0) + Sqrt(2.0d0)*w))/12.0d0

7083
             dLBasisdx(3,1) = 0.0d0

7084
             dLBasisdx(3,2) = (-Sqrt(3.0d0) + 4.0d0*v - Sqrt(2.0d0)*w)/3.0d0

7085
             dLBasisdx(3,3) = (Sqrt(6.0d0) - 4.0d0*Sqrt(2.0d0)*v + 2.0d0*w)/12.0d0

7086
             Basis(4) = (w*(-Sqrt(6.0d0) + 3.0d0*w))/4.0d0

7087
             dLBasisdx(4,1) = 0.0d0

7088
             dLBasisdx(4,2) = 0.0d0

7089
             dLBasisdx(4,3) = (-Sqrt(6.0d0) + 6.0d0*w)/4.0d0

7090
             Basis(5) =  (6.0d0 - 6.0d0*u**2 - 4.0d0*Sqrt(3.0d0)*v + 2.0d0*v**2 - 2.0d0*Sqrt(6.0d0)*w + &

7091
                 2.0d0*Sqrt(2.0d0)*v*w + w**2)/6.0d0

7092
             dLBasisdx(5,1) = -2.0d0*u

7093
             dLBasisdx(5,2) = (-2.0d0*Sqrt(3.0d0) + 2.0d0*v + Sqrt(2.0d0)*w)/3.0d0

7094
             dLBasisdx(5,3) = (-Sqrt(6.0d0) + Sqrt(2.0d0)*v + w)/3.0d0

7095
             Basis(6) =  (-4.0d0*v**2 + w*(-Sqrt(6.0d0) - Sqrt(6.0d0)*u + w) + v*(4.0d0*Sqrt(3.0d0) + &

7096
                 4.0d0*Sqrt(3.0d0)*u - Sqrt(2.0d0)*w))/6.0d0

7097
             dLBasisdx(6,1) = (2.0d0*v)/Sqrt(3.0d0) - w/Sqrt(6.0d0)

7098
             dLBasisdx(6,2) = (4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 8.0d0*v - Sqrt(2.0d0)*w)/6.0d0

7099
             dLBasisdx(6,3) = (-Sqrt(6.0d0) - Sqrt(6.0d0)*u - Sqrt(2.0d0)*v + 2.0d0*w)/6.0d0

7100
             Basis(7) =  (-4.0d0*v**2 + w*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + w) - &

7101
                 v*(-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + Sqrt(2.0d0)*w))/6.0d0

7102
             dLBasisdx(7,1) = (-2.0d0*v)/Sqrt(3.0d0) + w/Sqrt(6.0d0)

7103
             dLBasisdx(7,2) = (4.0d0*Sqrt(3.0d0) - 4.0d0*Sqrt(3.0d0)*u - 8.0d0*v - Sqrt(2.0d0)*w)/6.0d0

7104
             dLBasisdx(7,3) = (-Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v + 2.0d0*w)/6.0d0

7105
             Basis(8) = -(w*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + w))/2.0d0

7106
             dLBasisdx(8,1) = -(Sqrt(1.5d0)*w)

7107
             dLBasisdx(8,2) = -(w/Sqrt(2.0d0))

7108
             dLBasisdx(8,3) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 2.0d0*w)/2.0d0

7109
             Basis(9) = ((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - w)*w)/2.0d0

7110
             dLBasisdx(9,1) = Sqrt(1.5d0)*w

7111
             dLBasisdx(9,2) = -(w/Sqrt(2.0d0))

7112
             dLBasisdx(9,3) = (Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 2.0d0*w)/2.0d0

7113
             Basis(10) = Sqrt(2.0d0)*v*w - w**2/2.0d0

7114
             dLBasisdx(10,1) = 0.0d0

7115
             dLBasisdx(10,2) = Sqrt(2.0d0)*w

7116
             dLBasisdx(10,3) = Sqrt(2.0d0)*v - w

7117
           ELSE

7118
             ! Here the element of the background mesh is of type 504: 

7119
             DO q=1,4

7120
               Basis(q) = TetraNodalPBasis(q, u, v, w)

7121
               dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w)

7122
             END DO

7123
           END IF

7124
         ELSE

7125
           DO q=1,n

7126
             Basis(q) = TetraNodalPBasis(q, u, v, w)

7127
             dLBasisdx(q,1:3) = dTetraNodalPBasis(q, u, v, w)

7128
           END DO

7129
           IF (Create2ndKindBasis) THEN

7130
             DOFs = 12

7131
           ELSE

7132
             DOFs = 6

7133
           END IF

7134
         END IF

7135
       CASE(6)

7136
         IF (SecondOrder) THEN

7137
           ! The second-order pyramid from the Nedelec's first family

7138
           DOFs = 31

7139
         ELSE

7140
           ! The lowest-order pyramid from the optimal family

7141
           DOFs = 10

7142
         END IF

7143


7144
         IF (n==13) THEN

7145
           ! Here the background mesh is supposed to be of type 613. The difference between the standard

7146
           ! reference element and the p-reference element can be taken into account by a simple scaling:

7147
           CALL NodalBasisFunctions3D(Basis, Element, u, v, sqrt(2.0d0)*w)

7148
           CALL NodalFirstDerivatives(n, dLBasisdx, Element, u, v, sqrt(2.0d0)*w)

7149
           dLBasisdx(1:n,3) = sqrt(2.0d0) * dLBasisdx(1:n,3)

7150
         ELSE

7151
           ! Background mesh elements of the type 605:

7152
           DO q=1,n

7153
             Basis(q) = PyramidNodalPBasis(q, u, v, w)

7154
             dLBasisdx(q,1:3) = dPyramidNodalPBasis(q, u, v, w)

7155
           END DO

7156
         END IF

7157


7158
       CASE(7)

7159
         IF (SecondOrder) THEN

7160
           ! The second-order prism from the Nedelec's first family: affine physical elements may be needed

7161
           DOFs = 36

7162
         ELSE

7163
           ! The lowest-order prism from the optimal family

7164
           DOFs = 15

7165
         END IF

7166


7167
         IF (n==15) THEN

7168
           ! Here the background mesh is of type 715.

7169
           ! The Lagrange interpolation basis on the p-approximation reference element:

7170


7171
           h1 = -0.5d0*w + 0.5d0*w**2

7172
           h2 = 0.5d0*w + 0.5d0*w**2

7173
           h3 = 1.0d0 - w**2

7174
           dh1 = -0.5d0 + w

7175
           dh2 = 0.5d0 + w

7176
           dh3 = -2.0d0 * w

7177
           

7178
           WorkBasis(1,1) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(-3.0d0 + 2.0d0*Sqrt(3.0d0)*v))/6

7179
           grad(1) = -0.5d0 + u + v/Sqrt(3.0d0)

7180
           grad(2) = (-Sqrt(3.0d0) + 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0

7181
           Basis(1) = WorkBasis(1,1) * h1

7182
           dLBasisdx(1,1:2) = grad(1:2) * h1

7183
           dLBasisdx(1,3) = WorkBasis(1,1) * dh1

7184
           Basis(4) = WorkBasis(1,1) * h2

7185
           dLBasisdx(4,1:2) = grad(1:2) * h2

7186
           dLBasisdx(4,3) = WorkBasis(1,1) * dh2

7187
           Basis(13) = WorkBasis(1,1) * h3

7188
           dLBasisdx(13,1:2) = grad(1:2) * h3

7189
           dLBasisdx(13,3) = WorkBasis(1,1) * dh3

7190


7191
           WorkBasis(1,1) = (3.0d0*u**2 + v*(-Sqrt(3.0d0) + v) + u*(3.0d0 - 2.0d0*Sqrt(3.0d0)*v))/6.0d0

7192
           grad(1) = 0.5d0 + u - v/Sqrt(3.d0)

7193
           grad(2) = (-Sqrt(3.0d0) - 2.0d0*Sqrt(3.0d0)*u + 2.0d0*v)/6.0d0

7194
           Basis(2) = WorkBasis(1,1) * h1

7195
           dLBasisdx(2,1:2) = grad(1:2) * h1

7196
           dLBasisdx(2,3) = WorkBasis(1,1) * dh1

7197
           Basis(5) = WorkBasis(1,1) * h2

7198
           dLBasisdx(5,1:2) = grad(1:2) * h2

7199
           dLBasisdx(5,3) = WorkBasis(1,1) * dh2

7200
           Basis(14) = WorkBasis(1,1) * h3

7201
           dLBasisdx(14,1:2) = grad(1:2) * h3

7202
           dLBasisdx(14,3) = WorkBasis(1,1) * dh3

7203


7204
           WorkBasis(1,1) = (v*(-Sqrt(3.0d0) + 2.0d0*v))/3.0d0

7205
           grad(1) = 0.0d0

7206
           grad(2) = -(1.0d0/Sqrt(3.0d0)) + (4.0d0*v)/3.0d0

7207
           Basis(3) = WorkBasis(1,1) * h1

7208
           dLBasisdx(3,1:2) = grad(1:2) * h1

7209
           dLBasisdx(3,3) = WorkBasis(1,1) * dh1

7210
           Basis(6) = WorkBasis(1,1) * h2

7211
           dLBasisdx(6,1:2) = grad(1:2) * h2

7212
           dLBasisdx(6,3) = WorkBasis(1,1) * dh2

7213
           Basis(15) = WorkBasis(1,1) * h3

7214
           dLBasisdx(15,1:2) = grad(1:2) * h3

7215
           dLBasisdx(15,3) = WorkBasis(1,1) * dh3

7216


7217
           h1 = 0.5d0 * (1.0d0 - w)

7218
           dh1 = -0.5d0

7219
           h2 = 0.5d0 * (1.0d0 + w)

7220
           dh2 = 0.5d0

7221


7222
           WorkBasis(1,1) = (3.0d0 - 3.0d0*u**2 - 2.0d0*Sqrt(3.0d0)*v + v**2)/3.0d0

7223
           grad(1) = -2.0d0*u

7224
           grad(2) = (-2.0d0*(Sqrt(3.0d0) - v))/3.0d0

7225
           Basis(7) = WorkBasis(1,1) * h1

7226
           dLBasisdx(7,1:2) = grad(1:2) * h1

7227
           dLBasisdx(7,3) = WorkBasis(1,1) * dh1

7228
           Basis(10) = WorkBasis(1,1) * h2

7229
           dLBasisdx(10,1:2) = grad(1:2) * h2

7230
           dLBasisdx(10,3) = WorkBasis(1,1) * dh2

7231


7232
           WorkBasis(1,1) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - v)*v)/3.0d0

7233
           grad(1) = (2.0d0*v)/Sqrt(3.0d0)

7234
           grad(2) = (2.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 2.0d0*v))/3.0d0

7235
           Basis(8) = WorkBasis(1,1) * h1

7236
           dLBasisdx(8,1:2) = grad(1:2) * h1

7237
           dLBasisdx(8,3) = WorkBasis(1,1) * dh1

7238
           Basis(11) = WorkBasis(1,1) * h2

7239
           dLBasisdx(11,1:2) = grad(1:2) * h2

7240
           dLBasisdx(11,3) = WorkBasis(1,1) * dh2

7241


7242
           WorkBasis(1,1) = (-2.0d0*v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v))/3.0d0

7243
           grad(1) = (-2.0d0*v)/Sqrt(3.0d0)

7244
           grad(2) = (-2.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 2.0d0*v))/3.0d0

7245
           Basis(9) = WorkBasis(1,1) * h1

7246
           dLBasisdx(9,1:2) = grad(1:2) * h1

7247
           dLBasisdx(9,3) = WorkBasis(1,1) * dh1

7248
           Basis(12) = WorkBasis(1,1) * h2

7249
           dLBasisdx(12,1:2) = grad(1:2) * h2

7250
           dLBasisdx(12,3) = WorkBasis(1,1) * dh2

7251
         ELSE

7252
           ! Here the background mesh is of type 706

7253
           DO q=1,n

7254
             Basis(q) = WedgeNodalPBasis(q, u, v, w)

7255
             dLBasisdx(q,1:3) = dWedgeNodalPBasis(q, u, v, w)

7256
           END DO

7257
         END IF

7258
       CASE(8)

7259
         IF (SecondOrder) THEN

7260
           ! The second-order brick from the Nedelec's first family: affine physical elements may be needed

7261
           DOFs = 54

7262
         ELSE

7263
           ! The lowest-order brick from the optimal family

7264
           DOFs = 27

7265
         END IF

7266
         IF (n>8) THEN

7267
           ! Here the background mesh is supposed to be of type 820/827

7268
           CALL NodalBasisFunctions3D(Basis, Element, u, v, w)

7269
           CALL NodalFirstDerivatives(n, dLBasisdx, Element, u, v, w) 

7270
         ELSE

7271
           ! Here the background mesh is of type 808

7272
           DO q=1,n

7273
             Basis(q) = BrickNodalPBasis(q, u, v, w)

7274
             dLBasisdx(q,1:3) = dBrickNodalPBasis(q, u, v, w)

7275
           END DO

7276
         END IF

7277
       CASE DEFAULT

7278
         CALL Fatal('ElementDescription::EdgeElementInfo','Unsupported element type')

7279
       END SELECT

7280


7281
       !-----------------------------------------------------------------------

7282
       ! Get data for performing the Piola transformation...

7283
       !-----------------------------------------------------------------------

7284
       stat = PiolaTransformationData(n, Element, Nodes, LF, detF, dLBasisdx) 

7285
       !------------------------------------------------------------------------

7286
       ! ... in order to define the basis for the element space X(K) via 

7287
       ! applying a version of the Piola transformation as

7288
       !    X(K) = { B | B = F^{-T}(f^{-1}(x)) b(f^{-1}(x)) }

7289
       ! with b giving the edge basis function on the reference element k,

7290
       ! f mapping k to the actual element K, i.e. K = f(k) and F = Grad f. This 

7291
       ! function returns the local basis functions b and their Curl (with respect

7292
       ! to local coordinates) evaluated at the integration point. The effect of 

7293
       ! the Piola transformation need to be considered when integrating, so we 

7294
       ! shall return also the values of F, G=F^{-T} and det F.

7295
       !

7296
       ! It should be noted that the case of 2-D surface elements embedded in

7297
       ! the three-dimensional space is handled as a special case. Then F^{-T}

7298
       ! is replaced by the transpose of the pseudoinverse of F. The Piola 

7299
       ! transformation then maps a 2-component field to a 3-component vector

7300
       ! field which is tangential to the 2-D surface.

7301
       !

7302
       ! The construction of edge element bases could be done in an alternate way for 

7303
       ! triangles and tetrahedra, while the chosen approach has the benefit that

7304
       ! it generalizes to other cases. For example general quadrilaterals may now 

7305
       ! be handled in the same way.

7306
       !---------------------------------------------------------------------------

7307
       IF (cdim == dim) THEN

7308
          SELECT CASE(Element % TYPE % ElementCode / 100)

7309
          CASE(3,4)

7310
             LG(1,1) = 1.0d0/detF * LF(2,2)

7311
             LG(1,2) = -1.0d0/detF * LF(1,2)

7312
             LG(2,1) = -1.0d0/detF * LF(2,1)

7313
             LG(2,2) = 1.0d0/detF * LF(1,1)

7314
          CASE(5,6,7,8)

7315
             CALL InvertMatrix3x3(LF,LG,detF)       

7316
          CASE DEFAULT

7317
             CALL Fatal('ElementDescription::EdgeElementInfo','Unsupported element type')

7318
          END SELECT

7319
          LG(1:dim,1:dim) = TRANSPOSE( LG(1:dim,1:dim) )

7320
       END IF

7321


7322
       IF (UsePretabulatedBasis) THEN

7323
         DO i=1,DOFs

7324
           EdgeBasis(i,1:3) = ReadyEdgeBasis(i,1:3)

7325
           CurlBasis(i,1:3) = ReadyRotBasis(i,1:3)

7326
         END DO

7327
       ELSE

7328
         SELECT CASE(Element % TYPE % ElementCode / 100)

7329
         CASE(2)

7330
           !--------------------------------------------------------------

7331
           ! This is a special case to return the tangential components 

7332
           ! trace of 2D elements

7333
           !--------------------------------------------------------------

7334
           !

7335
           ! The sign reversion of basis must be checked via the parent element:

7336
           !

7337
           Parent => Element % BoundaryInfo % Left

7338
           IF (.NOT. ASSOCIATED(Parent)) THEN

7339
             Parent => Element % BoundaryInfo % Right

7340
           END IF

7341


7342
           IF (.NOT. ASSOCIATED(Parent)) THEN

7343
             CALL Warn('EdgeElementInfo', 'cannot create curl-conforming basis functions, zeros returned')

7344
             RETURN

7345
           END IF

7346
           !

7347
           ! Identify the edge representing the element among the edges of 

7348
           ! the parent element:

7349
           !

7350
           pElement => Element 

7351
           CALL PickActiveFace(Mesh, Parent, pElement, Face, ActiveFaceId)

7352
           IF (ActiveFaceId == 0) RETURN

7353
           !

7354
           ! Use the parent element to check whether sign reversions are needed:

7355
           !

7356
           CALL FaceElementOrientation(Parent, ReverseSign, ActiveFaceId)

7357
           

7358
           IF (ReverseSign(ActiveFaceId)) THEN

7359
             EdgeBasis(1,1) = -0.5d0

7360
           ELSE

7361
             EdgeBasis(1,1) = 0.5d0

7362
           END IF

7363
           IF (SecondOrder) THEN

7364
             EdgeBasis(2,1) = 1.5d0 * u

7365
           END IF

7366
           CurlBasis(1:DOFs,:) = 0.0d0

7367


7368
         CASE(3)

7369
           !--------------------------------------------------------------

7370
           ! This branch is for handling triangles. Note that

7371
           ! the global orientation of the edge tangent t is defined such that

7372
           ! t points towards the node that has a larger global index.

7373
           !--------------------------------------------------------------

7374
           EdgeMap => GetEdgeMap(3)

7375
           !EdgeMap => GetEdgeMap(GetElementFamily(Element))

7376


7377
           IF (Create2ndKindBasis) THEN

7378


7379
             ! This construction follows Sun, Lee, Cendes. SIAM J. Sci. Comput. 23(4):1053-1076.

7380
             ! The first basis function associated with an edge is the Whitney form, while 

7381
             ! the second basis function corresponds to a gradient field.

7382


7383
             IF (SecondOrder) THEN

7384
               EDOFs = 3

7385
               FDOFs = 3

7386
             ELSE

7387
               EDOFs = 2

7388
               FDOFs = 0

7389
             END IF

7390
             

7391
             DO k=1,3

7392
               

7393
               i = EdgeMap(k,1)

7394
               j = EdgeMap(k,2)

7395


7396
               svec(1:2) = Basis(j) * dLBasisdx(i,1:2)

7397
               tvec(1:2) = Basis(i) * dLBasisdx(j,1:2)

7398


7399
               grad_svec(1,2) = dLBasisdx(j,2) * dLBasisdx(i,1)

7400
               grad_svec(2,1) = dLBasisdx(j,1) * dLBasisdx(i,2)

7401


7402
               grad_tvec(1,2) = dLBasisdx(i,2) * dLBasisdx(j,1)

7403
               grad_tvec(2,1) = dLBasisdx(i,1) * dLBasisdx(j,2)

7404


7405
               WorkBasis(1,1:2) = svec(1:2)

7406
               WorkBasis(2,1:2) = tvec(1:2)

7407
               WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

7408
               WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

7409


7410
               IF (SecondOrder) THEN

7411
                 WorkWeight(1) = 2.0d0*Basis(i) - Basis(j)

7412
                 WorkWeight(2) = 2.0d0*Basis(j) - Basis(i)

7413


7414
                 grad_weight(1,1:2) = 2.0d0*dLBasisdx(i,1:2) - dLBasisdx(j,1:2)

7415
                 grad_weight(2,1:2) = 2.0d0*dLBasisdx(j,1:2) - dLBasisdx(i,1:2)

7416
               END IF

7417


7418
               IF (GIndexes(j) < GIndexes(i)) THEN

7419
                 I1 = 2

7420
                 I2 = 1

7421
               ELSE

7422
                 I1 = 1

7423
                 I2 = 2

7424
               END IF

7425


7426
               DO l=1,EDOFs

7427
                 SELECT CASE(l)

7428
                 CASE(1)

7429
                   sfun = -1.0d0

7430
                   tfun = 1.0d0

7431
                 CASE(2)

7432
                   sfun = 1.0d0

7433
                   tfun = 1.0d0

7434
                 CASE(3)

7435
                   sfun = -WorkWeight(I1)

7436
                   tfun = WorkWeight(I2)

7437
                   grad_sfun(1:2) = -grad_weight(I1,1:2)

7438
                   grad_tfun(1:2) = grad_weight(I2,1:2)

7439
                 CASE DEFAULT

7440
                   CALL Fatal('ElementDescription::EdgeElementInfo','sfun/tfun not defined')

7441
                 END SELECT

7442


7443
                 EdgeBasis(EDOFs*(k-1)+l,1:2) = sfun * WorkBasis(I1,1:2) + tfun * WorkBasis(I2,1:2)

7444
                 CurlBasis(EDOFs*(k-1)+l,3) = sfun * WorkCurlBasis(I1,3) + tfun * WorkCurlBasis(I2,3)

7445


7446
                 IF (l > 2) THEN

7447
                   CurlBasis(EDOFs*(k-1)+l,3) = CurlBasis(EDOFs*(k-1)+l,3) + &

7448
                       grad_sfun(1)*WorkBasis(I1,2) + grad_tfun(1)*WorkBasis(I2,2) - &

7449
                       grad_sfun(2)*WorkBasis(I1,1) - grad_tfun(2)*WorkBasis(I2,1)

7450
                 END IF

7451
               END DO

7452
             END DO

7453


7454
             ! The basis functions associated with the faces for the second-order case

7455
             IF (FDOFs > 0) THEN

7456
               TriangleFaceMap(:) = (/ 1,2,3 /)

7457
               I1 = 1

7458
               I2 = 2

7459
               I3 = 3

7460


7461
               WorkBasis(1,1:2) = Basis(I2) * Basis(I3) * dLBasisdx(I1,1:2)

7462
               WorkBasis(2,1:2) = Basis(I1) * Basis(I3) * dLBasisdx(I2,1:2)

7463
               WorkBasis(3,1:2) = Basis(I1) * Basis(I2) * dLBasisdx(I3,1:2)

7464


7465
               grad_svec(1,2) = (dLBasisdx(I2,2) * Basis(I3) + &

7466
                   Basis(I2) * dLBasisdx(I3,2)) * dLBasisdx(I1,1)

7467
               grad_svec(2,1) = (dLBasisdx(I2,1) * Basis(I3) + &

7468
                   Basis(I2) * dLBasisdx(I3,1)) * dLBasisdx(I1,2)

7469


7470
               grad_tvec(1,2) = (dLBasisdx(I1,2) * Basis(I3)  + &

7471
                   Basis(I1) * dLBasisdx(I3,2)) * dLBasisdx(I2,1)

7472
               grad_tvec(2,1) = (dLBasisdx(I1,1) * Basis(I3)  + &

7473
                   Basis(I1) * dLBasisdx(I3,1)) * dLBasisdx(I2,2)

7474


7475
               grad_hvec(1,2) = (dLBasisdx(I1,2) * Basis(I2)  + &

7476
                   Basis(I1) * dLBasisdx(I2,2)) * dLBasisdx(I3,1)

7477
               grad_hvec(2,1) = (dLBasisdx(I1,1) * Basis(I2)  + &

7478
                   Basis(I1) * dLBasisdx(I2,1)) * dLBasisdx(I3,2)

7479


7480
               WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

7481
               WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

7482
               WorkCurlBasis(3,3) = grad_hvec(2,1) - grad_hvec(1,2)

7483


7484
               ! Create permutation:

7485
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

7486
               CALL TriangleFaceDofsOrdering2nd(I1,I2,I3,FaceIndices(1:3))

7487


7488
               ! Create the basis:

7489
               DO l=1,FDOFs

7490


7491
                 SELECT CASE(l)

7492
                 CASE(1)

7493
                   sfun = 1.0d0

7494
                   tfun = 1.0d0

7495
                   hfun = 1.0d0

7496
                 CASE(2)

7497
                   sfun = 1.0d0

7498
                   tfun = 1.0d0

7499
                   hfun = -2.0d0

7500
                 CASE(3)

7501
                   sfun = 1.0d0

7502
                   tfun = -1.0d0

7503
                   hfun = 0.0d0

7504
                 END SELECT

7505


7506
                 EdgeBasis(3*EDOFs + l,1:2) = sfun * WorkBasis(I1,1:2) + tfun * WorkBasis(I2,1:2) + &

7507
                     hfun * WorkBasis(I3,1:2)

7508
                 CurlBasis(3*EDOFs + l,3) = sfun * WorkCurlBasis(I1,3) + tfun * WorkCurlBasis(I2,3) + &

7509
                     hfun * WorkCurlBasis(I3,3)

7510
               END DO

7511
             END IF

7512


7513
!           ELSE IF (SecondOrder) THEN

7514
           ELSE IF (SecondOrder .AND. Simplicial .OR. ThirdOrder .AND. Simplicial) THEN

7515
             !

7516
             ! An alternate Nd_1(k=2) basis for faster solution with iterative methods. Currently

7517
             ! this is available only for simplicial elements. 

7518
             !

7519
             IF (SecondOrder) THEN

7520
               EDOFs = 2

7521
               FDOFs = 2

7522
             ELSE

7523
               ! The case of third-order basis 

7524
               EDOFs = 3

7525
               FDOFs = 6

7526
             END IF

7527


7528
             ! The following loop over the edges is essentially the same as for the second-order basis of

7529
             ! the second family. TO DO: restructure to avoid the repetition

7530
             DO k=1,3

7531
               

7532
               i = EdgeMap(k,1)

7533
               j = EdgeMap(k,2)

7534


7535
               svec(1:2) = Basis(j) * dLBasisdx(i,1:2)

7536
               tvec(1:2) = Basis(i) * dLBasisdx(j,1:2)

7537


7538
               grad_svec(1,2) = dLBasisdx(j,2) * dLBasisdx(i,1)

7539
               grad_svec(2,1) = dLBasisdx(j,1) * dLBasisdx(i,2)

7540


7541
               grad_tvec(1,2) = dLBasisdx(i,2) * dLBasisdx(j,1)

7542
               grad_tvec(2,1) = dLBasisdx(i,1) * dLBasisdx(j,2)

7543


7544
               WorkBasis(1,1:2) = svec(1:2)

7545
               WorkBasis(2,1:2) = tvec(1:2)

7546
               WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

7547
               WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

7548


7549
               IF (ThirdOrder) THEN

7550
                 WorkWeight(1) = 2.0d0*Basis(i) - Basis(j)

7551
                 WorkWeight(2) = 2.0d0*Basis(j) - Basis(i)

7552


7553
                 grad_weight(1,1:2) = 2.0d0*dLBasisdx(i,1:2) - dLBasisdx(j,1:2)

7554
                 grad_weight(2,1:2) = 2.0d0*dLBasisdx(j,1:2) - dLBasisdx(i,1:2)

7555
               END IF

7556
               

7557
               IF (GIndexes(j) < GIndexes(i)) THEN

7558
                 I1 = 2

7559
                 I2 = 1

7560
               ELSE

7561
                 I1 = 1

7562
                 I2 = 2

7563
               END IF

7564


7565
               DO l=1,EDOFs

7566
                 SELECT CASE(l)

7567
                 CASE(1)

7568
                   sfun = -1.0d0

7569
                   tfun = 1.0d0

7570
                 CASE(2)

7571
                   sfun = 1.0d0

7572
                   tfun = 1.0d0

7573
                 CASE(3)

7574
                   sfun = -WorkWeight(I1)

7575
                   tfun = WorkWeight(I2)

7576
                   grad_sfun(1:2) = -grad_weight(I1,1:2)

7577
                   grad_tfun(1:2) = grad_weight(I2,1:2)                   

7578
                 CASE DEFAULT

7579
                   CALL Fatal('ElementDescription::EdgeElementInfo','sfun/tfun not defined')

7580
                 END SELECT

7581


7582
                 EdgeBasis(EDOFs*(k-1)+l,1:2) = sfun * WorkBasis(I1,1:2) + tfun * WorkBasis(I2,1:2)

7583
                 CurlBasis(EDOFs*(k-1)+l,3) = sfun * WorkCurlBasis(I1,3) + tfun * WorkCurlBasis(I2,3)

7584
                 

7585
                 IF (l > 2) THEN

7586
                   CurlBasis(EDOFs*(k-1)+l,3) = CurlBasis(EDOFs*(k-1)+l,3) + &

7587
                       grad_sfun(1)*WorkBasis(I1,2) + grad_tfun(1)*WorkBasis(I2,2) - &

7588
                       grad_sfun(2)*WorkBasis(I1,1) - grad_tfun(2)*WorkBasis(I2,1)

7589
                 END IF

7590
               END DO

7591
             END DO

7592


7593
             ! The basis functions associated with the faces for the second-order case

7594
             TriangleFaceMap(:) = (/ 1,2,3 /)

7595
             I1 = 1

7596
             I2 = 2

7597
             I3 = 3

7598


7599
             WorkBasis(1,1:2) = Basis(I2) * Basis(I3) * dLBasisdx(I1,1:2)

7600
             WorkBasis(2,1:2) = Basis(I1) * Basis(I3) * dLBasisdx(I2,1:2)

7601
             WorkBasis(3,1:2) = Basis(I1) * Basis(I2) * dLBasisdx(I3,1:2)

7602


7603
             grad_svec(1,2) = (dLBasisdx(I2,2) * Basis(I3) + &

7604
                 Basis(I2) * dLBasisdx(I3,2)) * dLBasisdx(I1,1)

7605
             grad_svec(2,1) = (dLBasisdx(I2,1) * Basis(I3) + &

7606
                 Basis(I2) * dLBasisdx(I3,1)) * dLBasisdx(I1,2)

7607


7608
             grad_tvec(1,2) = (dLBasisdx(I1,2) * Basis(I3)  + &

7609
                 Basis(I1) * dLBasisdx(I3,2)) * dLBasisdx(I2,1)

7610
             grad_tvec(2,1) = (dLBasisdx(I1,1) * Basis(I3)  + &

7611
                 Basis(I1) * dLBasisdx(I3,1)) * dLBasisdx(I2,2)

7612


7613
             grad_hvec(1,2) = (dLBasisdx(I1,2) * Basis(I2)  + &

7614
                 Basis(I1) * dLBasisdx(I2,2)) * dLBasisdx(I3,1)

7615
             grad_hvec(2,1) = (dLBasisdx(I1,1) * Basis(I2)  + &

7616
                 Basis(I1) * dLBasisdx(I2,1)) * dLBasisdx(I3,2)

7617


7618
             WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

7619
             WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

7620
             WorkCurlBasis(3,3) = grad_hvec(2,1) - grad_hvec(1,2)

7621


7622
             ! Create permutation:

7623
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

7624
             CALL TriangleFaceDofsOrdering2nd(I1,I2,I3,FaceIndices(1:3))

7625


7626
             ! Create the basis:

7627
             DO l=1,FDOFs

7628


7629
               SELECT CASE(l)

7630
               CASE(1)

7631
                 sfun = 1.0d0

7632
                 tfun = 1.0d0

7633
                 hfun = -2.0d0

7634
               CASE(2)

7635
                 sfun = 1.0d0

7636
                 tfun = -1.0d0

7637
                 hfun = 0.0d0

7638
               CASE(3)

7639
                 sfun = 1.0d0

7640
                 tfun = 1.0d0

7641
                 hfun = 1.0d0                                  

7642
               CASE(4)

7643
                 sfun = Basis(I2) - Basis(I3)

7644
                 tfun = Basis(I3) - Basis(I1)

7645
                 hfun = Basis(I1) - Basis(I2)

7646


7647
                 grad_sfun(1:2) = dLBasisdx(I2,1:2) - dLBasisdx(I3,1:2)

7648
                 grad_tfun(1:2) = dLBasisdx(I3,1:2) - dLBasisdx(I1,1:2)

7649
                 grad_hfun(1:2) = dLBasisdx(I1,1:2) - dLBasisdx(I2,1:2)

7650
               CASE(5)

7651
                 sfun = 393.0d0 * Basis(I1) + 80.0d0 * Basis(I2) - 212.0d0 * Basis(I3)

7652
                 tfun = -393.0d0 * Basis(I2) - 80.0d0 * Basis(I1) + 212.0d0 * Basis(I3)

7653
                 hfun = -313.0d0 * Basis(I1) + 313.0d0 * Basis(I2)

7654


7655
                 grad_sfun(1:2) = 393.0d0 * dLBasisdx(I1,1:2) + 80.0d0 * dLBasisdx(I2,1:2) - 212.0d0 * dLBasisdx(I3,1:2)

7656
                 grad_tfun(1:2) = -393.0d0 * dLBasisdx(I2,1:2) - 80.0d0 * dLBasisdx(I1,1:2) + 212.0d0 * dLBasisdx(I3,1:2)

7657
                 grad_hfun(1:2) = -313.0d0 * dLBasisdx(I1,1:2) + 313.0d0 * dLBasisdx(I2,1:2)

7658
               CASE(6)

7659
                 sfun = -131.0d0 * Basis(I1) + 168.0d0 * Basis(I2) - 124.0d0 * Basis(I3)

7660
                 tfun = -131.0d0 * Basis(I2) + 168.0d0 * Basis(I1) - 124.0d0 * Basis(I3)

7661
                 hfun = -37.0d0 * Basis(I1) - 37.0d0 * Basis(I2) + 248.0d0 * Basis(I3)

7662


7663
                 grad_sfun(1:2) = -131.0d0 * dLBasisdx(I1,1:2) + 168.0d0 * dLBasisdx(I2,1:2) - 124.0d0 * dLBasisdx(I3,1:2)

7664
                 grad_tfun(1:2) = -131.0d0 * dLBasisdx(I2,1:2) + 168.0d0 * dLBasisdx(I1,1:2) - 124.0d0 * dLBasisdx(I3,1:2)

7665
                 grad_hfun(1:2) = -37.0d0 * dLBasisdx(I1,1:2) - 37.0d0 * dLBasisdx(I2,1:2) + 248.0d0 * dLBasisdx(I3,1:2)                 

7666
               END SELECT

7667


7668
               EdgeBasis(3*EDOFs + l,1:2) = sfun * WorkBasis(I1,1:2) + tfun * WorkBasis(I2,1:2) + &

7669
                   hfun * WorkBasis(I3,1:2)

7670
               CurlBasis(3*EDOFs + l,3) = sfun * WorkCurlBasis(I1,3) + tfun * WorkCurlBasis(I2,3) + &

7671
                   hfun * WorkCurlBasis(I3,3)

7672


7673
               IF (l > 3) THEN

7674
                 CurlBasis(3*EDOFs+l,3) = CurlBasis(3*EDOFs+l,3) + &

7675
                     grad_sfun(1)*WorkBasis(I1,2) + grad_tfun(1)*WorkBasis(I2,2) + grad_hfun(1)*WorkBasis(I3,2) - &

7676
                     grad_sfun(2)*WorkBasis(I1,1) - grad_tfun(2)*WorkBasis(I2,1) - grad_hfun(2)*WorkBasis(I3,1)

7677
               END IF

7678
               

7679
             END DO

7680
             

7681
           ELSE

7682
             

7683
             !------------------------------------------------------------

7684
             ! The optimal/Nedelec basis functions of the first kind. We employ

7685
             ! a hierarchic basis, so the lowest-order basis functions are

7686
             ! also utilized in the construction of the second-order basis. 

7687
             ! First the edge 12 ...

7688
             !------------------------------------------------------------

7689
             i = EdgeMap(1,1)

7690
             j = EdgeMap(1,2)

7691
             EdgeBasis(1,1) = (3.0d0 - Sqrt(3.0d0)*v)/6.0d0

7692
             EdgeBasis(1,2) = u/(2.0d0*Sqrt(3.0d0))

7693
             CurlBasis(1,3) = 1.0d0/Sqrt(3.0d0)

7694
             IF(GIndexes(j)<GIndexes(i)) THEN

7695
               EdgeBasis(1,:) = -EdgeBasis(1,:)

7696
               CurlBasis(1,3) = -CurlBasis(1,3)

7697
             END IF

7698
             IF (SecondOrder) THEN

7699
               EdgeBasis(2,1) = -(u*(-3.0d0 + Sqrt(3.0d0)*v))/2.0d0

7700
               EdgeBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0

7701
               CurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0                     

7702
             END IF

7703


7704
             !-------------------------------------------------

7705
             ! Basis functions associated with the edge 23:

7706
             !-------------------------------------------------

7707
             IF (SecondOrder) THEN

7708
               k = 3

7709
               EdgeBasis(4,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*v)/4.0d0

7710
               EdgeBasis(4,2) = (Sqrt(3.0d0)*(1.0d0 + u)*(-1.0d0 - u + Sqrt(3.0d0)*v))/4.0d0

7711
               CurlBasis(4,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0

7712
             ELSE

7713
               k = 2

7714
             END IF

7715
             i = EdgeMap(2,1)

7716
             j = EdgeMap(2,2)

7717
             EdgeBasis(k,1) = -v/(2.0d0*Sqrt(3.0d0))

7718
             EdgeBasis(k,2) = (1 + u)/(2.0d0*Sqrt(3.0d0))

7719
             CurlBasis(k,3) =  1.0d0/Sqrt(3.0d0)

7720
             IF(GIndexes(j)<GIndexes(i)) THEN

7721
               EdgeBasis(k,:) = -EdgeBasis(k,:)

7722
               CurlBasis(k,3) = -CurlBasis(k,3)

7723
             END IF

7724


7725
             !-------------------------------------------------

7726
             ! Basis functions associated with the edge 31:

7727
             !-------------------------------------------------

7728
             IF (SecondOrder) THEN

7729
               k = 5

7730
               EdgeBasis(6,1) = (v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0

7731
               EdgeBasis(6,2) = -(Sqrt(3.0d0)*(-1.0d0 + u)*(-1.0d0 + u + Sqrt(3.0d0)*v))/4.0d0

7732
               CurlBasis(6,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0                     

7733
             ELSE

7734
               k = 3

7735
             END IF

7736
             i = EdgeMap(3,1)

7737
             j = EdgeMap(3,2)

7738
             EdgeBasis(k,1) = -v/(2.0d0*Sqrt(3.0d0))

7739
             EdgeBasis(k,2) = (-1 + u)/(2.0d0*Sqrt(3.0d0))

7740
             CurlBasis(k,3) = 1.0d0/Sqrt(3.0d0)

7741
             IF(GIndexes(j)<GIndexes(i)) THEN

7742
               EdgeBasis(k,:) = -EdgeBasis(k,:)

7743
               CurlBasis(k,3) = -CurlBasis(k,3)

7744
             END IF

7745


7746
             IF (SecondOrder) THEN

7747
               !-------------------------------------------------

7748
               ! Two basis functions defined on the face 123:

7749
               !-------------------------------------------------

7750
               TriangleFaceMap(:) = (/ 1,2,3 /)          

7751
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

7752
               CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

7753


7754
               WorkBasis(1,1) = ((Sqrt(3.0d0) - v)*v)/6.0d0

7755
               WorkBasis(1,2) = (u*v)/6.0d0

7756
               WorkCurlBasis(1,3) = (-Sqrt(3.0d0) + 3.0d0*v)/6.0d0

7757
               WorkBasis(2,1) = (v*(1.0d0 + u - v/Sqrt(3.0d0)))/(4.0d0*Sqrt(3.0d0))

7758
               WorkBasis(2,2) = ((-1.0d0 + u)*(-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0))

7759
               WorkCurlBasis(2,3) =(-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0

7760
               WorkBasis(3,1) = (v*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0))

7761
               WorkBasis(3,2) = -((1.0d0 + u)*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0))

7762
               WorkCurlBasis(3,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0

7763


7764
               IF (RedefineFaceBasis) THEN

7765
                 EdgeBasis(7,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

7766
                 CurlBasis(7,3) = 0.5d0 * D1 * WorkCurlBasis(I1,3) + 0.5d0 * D2 * WorkCurlBasis(I2,3)

7767
                 EdgeBasis(8,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

7768
                 CurlBasis(8,3) = 0.5d0 * D2 * WorkCurlBasis(I2,3) - 0.5d0 * D1 * WorkCurlBasis(I1,3)

7769
               ELSE

7770
                 EdgeBasis(7,:) = D1 * WorkBasis(I1,:)

7771
                 CurlBasis(7,3) = D1 * WorkCurlBasis(I1,3)

7772
                 EdgeBasis(8,:) = D2 * WorkBasis(I2,:)

7773
                 CurlBasis(8,3) = D2 * WorkCurlBasis(I2,3)  

7774
               END IF

7775
               

7776
               ! Finally, scale to reduce ill-conditioning:

7777
               IF (ScaleFaceBasis) THEN

7778
                 EdgeBasis(7,:) = sqrt(fs1) * EdgeBasis(7,:)

7779
                 EdgeBasis(8,:) = sqrt(fs2) * EdgeBasis(8,:)

7780
                 CurlBasis(7,3) = sqrt(fs1) * CurlBasis(7,3)

7781
                 CurlBasis(8,3) = sqrt(fs2) * CurlBasis(8,3)

7782
               END IF

7783
             END IF

7784
           END IF

7785


7786
         CASE(4)

7787
           !--------------------------------------------------------------

7788
           ! This branch is for handling quadrilaterals

7789
           !--------------------------------------------------------------

7790
           EdgeMap => GetEdgeMap(4)

7791
           IF (SecondOrder) THEN

7792
             !---------------------------------------------------------------

7793
             ! The second-order element from the Nedelec's first family with

7794
             ! a hierarchic basis. This element may not be optimally accurate

7795
             ! if the physical element is not affine.

7796
             ! First, the eight basis functions associated with the edges:

7797
             !--------------------------------------------------------------

7798
             i = EdgeMap(1,1)

7799
             j = EdgeMap(1,2)

7800
             EdgeBasis(1,1) = 0.1D1 / 0.4D1 - v / 0.4D1

7801
             CurlBasis(1,3) = 0.1D1 / 0.4D1

7802
             IF(GIndexes(j)<GIndexes(i)) THEN

7803
               EdgeBasis(1,:) = -EdgeBasis(1,:)

7804
               CurlBasis(1,3) = -CurlBasis(1,3)

7805
             END IF

7806
             EdgeBasis(2,1) = 0.3D1 * u * (0.1D1 / 0.4D1 - v / 0.4D1)

7807
             CurlBasis(2,3) = 0.3D1 / 0.4D1 * u

7808


7809
             i = EdgeMap(2,1)

7810
             j = EdgeMap(2,2)

7811
             EdgeBasis(3,2) = 0.1D1 / 0.4D1 + u / 0.4D1 

7812
             CurlBasis(3,3) = 0.1D1 / 0.4D1

7813
             IF(GIndexes(j)<GIndexes(i)) THEN

7814
               EdgeBasis(3,:) = -EdgeBasis(3,:)

7815
               CurlBasis(3,3) = -CurlBasis(3,3)

7816
             END IF

7817
             EdgeBasis(4,2) = 0.3D1 * v * (0.1D1 / 0.4D1 + u / 0.4D1)

7818
             CurlBasis(4,3) = 0.3D1 / 0.4D1 * v

7819


7820
             i = EdgeMap(3,1)

7821
             j = EdgeMap(3,2)

7822
             EdgeBasis(5,1) = -0.1D1 / 0.4D1 - v / 0.4D1

7823
             CurlBasis(5,3) = 0.1D1 / 0.4D1

7824
             IF(GIndexes(j)<GIndexes(i)) THEN

7825
               EdgeBasis(5,:) = -EdgeBasis(5,:)

7826
               CurlBasis(5,3) = -CurlBasis(5,3)

7827
             END IF

7828
             EdgeBasis(6,1) = -0.3D1 * u * (-0.1D1 / 0.4D1 - v / 0.4D1)

7829
             CurlBasis(6,3) = -0.3D1 / 0.4D1 * u

7830


7831
             i = EdgeMap(4,1)

7832
             j = EdgeMap(4,2)

7833
             EdgeBasis(7,2) = -0.1D1 / 0.4D1 + u / 0.4D1

7834
             CurlBasis(7,3) = 0.1D1 / 0.4D1

7835
             IF(GIndexes(j)<GIndexes(i)) THEN

7836
               EdgeBasis(7,:) = -EdgeBasis(7,:)

7837
               CurlBasis(7,3) = -CurlBasis(7,3)

7838
             END IF

7839
             EdgeBasis(8,2) = -0.3D1 * v * (-0.1D1 / 0.4D1 + u / 0.4D1)

7840
             CurlBasis(8,3) = -0.3D1 / 0.4D1 * v

7841


7842
             !--------------------------------------------------------------------

7843
             ! Additional four basis functions associated with the element interior

7844
             !-------------------------------------------------------------------

7845
             SquareFaceMap(:) = (/ 1,2,3,4 /)          

7846
             WorkBasis = 0.0d0

7847
             WorkCurlBasis = 0.0d0

7848


7849
             WorkBasis(1,1) = 0.2D1 * (0.1D1 / 0.2D1 - v / 0.2D1) * (0.1D1 / 0.2D1 + v / 0.2D1)

7850
             WorkCurlBasis(1,3) = v

7851
             WorkBasis(2,1) = 0.12D2 * u * (0.1D1 / 0.2D1 - v / 0.2D1) * (0.1D1 / 0.2D1 + v / 0.2D1)

7852
             WorkCurlBasis(2,3) = 0.6D1 * u * (0.1D1 / 0.2D1 + v / 0.2D1) - &

7853
                 0.6D1 * u * (0.1D1 / 0.2D1 - v / 0.2D1)

7854


7855
             WorkBasis(3,2) = 0.2D1 * (0.1D1 / 0.2D1 - u / 0.2D1) * (0.1D1 / 0.2D1 + u / 0.2D1)

7856
             WorkCurlBasis(3,3) = -u

7857
             WorkBasis(4,2) = 0.12D2 * v * (0.1D1 / 0.2D1 - u / 0.2D1) * (0.1D1 / 0.2D1 + u / 0.2D1)

7858
             WorkCurlBasis(4,3) = -0.6D1 * v * (0.1D1 / 0.2D1 + u / 0.2D1) + &

7859
                 0.6D1 * v * (0.1D1 / 0.2D1 - u / 0.2D1)

7860


7861
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

7862
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

7863


7864
             EdgeBasis(9,:) = D1 * WorkBasis(2*(I1-1)+1,:)

7865
             CurlBasis(9,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

7866
             EdgeBasis(10,:) = WorkBasis(2*(I1-1)+2,:)

7867
             CurlBasis(10,:) = WorkCurlBasis(2*(I1-1)+2,:)

7868
             EdgeBasis(11,:) = D2 * WorkBasis(2*(I2-1)+1,:)

7869
             CurlBasis(11,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

7870
             EdgeBasis(12,:) = WorkBasis(2*(I2-1)+2,:)

7871
             CurlBasis(12,:) = WorkCurlBasis(2*(I2-1)+2,:)

7872


7873
           ELSE

7874
             !------------------------------------------------------

7875
             ! The Arnold-Boffi-Falk element of degree k=0 which is

7876
             ! a member of the optimal edge element family. 

7877
             ! First, four basis functions defined on the edges

7878
             !-------------------------------------------------

7879
             i = EdgeMap(1,1)

7880
             j = EdgeMap(1,2)

7881
             EdgeBasis(1,1) = ((-1.0d0 + v)*v)/4.0d0

7882
             EdgeBasis(1,2) = 0.0d0

7883
             CurlBasis(1,3) = (1.0d0 - 2*v)/4.0d0

7884
             IF(GIndexes(j)<GIndexes(i)) THEN

7885
               EdgeBasis(1,:) = -EdgeBasis(1,:)

7886
               CurlBasis(1,3) = -CurlBasis(1,3)

7887
             END IF

7888


7889
             i = EdgeMap(2,1)

7890
             j = EdgeMap(2,2)

7891
             EdgeBasis(2,1) = 0.0d0

7892
             EdgeBasis(2,2) = (u*(1.0d0 + u))/4.0d0

7893
             CurlBasis(2,3) = (1.0d0 + 2*u)/4.0d0

7894
             IF(GIndexes(j)<GIndexes(i)) THEN

7895
               EdgeBasis(2,:) = -EdgeBasis(2,:)

7896
               CurlBasis(2,3) = -CurlBasis(2,3)

7897
             END IF

7898


7899
             i = EdgeMap(3,1)

7900
             j = EdgeMap(3,2)

7901
             EdgeBasis(3,1) = -(v*(1.0d0 + v))/4.0d0

7902
             EdgeBasis(3,2) = 0.0d0

7903
             CurlBasis(3,3) = (1.0d0 + 2*v)/4.0d0

7904
             IF(GIndexes(j)<GIndexes(i)) THEN

7905
               EdgeBasis(3,:) = -EdgeBasis(3,:)

7906
               CurlBasis(3,3) = -CurlBasis(3,3)

7907
             END IF

7908


7909
             i = EdgeMap(4,1)

7910
             j = EdgeMap(4,2)

7911
             EdgeBasis(4,1) = 0.0d0

7912
             EdgeBasis(4,2) = -((-1 + u)*u)/4.0d0

7913
             CurlBasis(4,3) = (1.0d0 - 2*u)/4.0d0

7914
             IF(GIndexes(j)<GIndexes(i)) THEN

7915
               EdgeBasis(4,:) = -EdgeBasis(4,:)

7916
               CurlBasis(4,3) = -CurlBasis(4,3)

7917
             END IF

7918


7919
             !--------------------------------------------------------------------

7920
             ! Additional two basis functions associated with the element interior

7921
             !-------------------------------------------------------------------

7922
             SquareFaceMap(:) = (/ 1,2,3,4 /)          

7923


7924
             WorkBasis(1,:) = 0.0d0

7925
             WorkBasis(2,:) = 0.0d0

7926
             WorkCurlBasis(1,:) = 0.0d0

7927
             WorkCurlBasis(2,:) = 0.0d0         

7928


7929
             WorkBasis(1,1) = (1.0d0 - v**2)/2.0d0

7930
             WorkBasis(1,2) = 0.0d0

7931
             WorkCurlBasis(1,3) = v

7932


7933
             WorkBasis(2,1) = 0.0d0

7934
             WorkBasis(2,2) = (1.0d0 - u**2)/2.0d0

7935
             WorkCurlBasis(2,3) = -u

7936


7937
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

7938
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

7939


7940
             EdgeBasis(5,:) = D1 * WorkBasis(I1,:)

7941
             CurlBasis(5,:) = D1 * WorkCurlBasis(I1,:)

7942
             EdgeBasis(6,:) = D2 * WorkBasis(I2,:)

7943
             CurlBasis(6,:) = D2 * WorkCurlBasis(I2,:)         

7944
           END IF

7945


7946
         CASE(5)

7947
           !--------------------------------------------------------------

7948
           ! This branch is for handling tetrahedra

7949
           !--------------------------------------------------------------

7950
           EdgeMap => GetEdgeMap(5)

7951


7952
           IF (Create2ndKindBasis) THEN

7953


7954
             ! This construction follows Sun, Lee, Cendes. SIAM J. Sci. Comput. 23(4):1053-1076.

7955
             ! The first basis function associated with an edge is always the Whitney form, while 

7956
             ! the second basis function corresponds to a gradient field.

7957
             

7958
             IF (SecondOrder) THEN

7959
               EDOFs = 3

7960
               FDOFs = 3

7961
             ELSE

7962
               EDOFs = 2

7963
               FDOFs = 0

7964
             END IF

7965
             

7966
             DO k=1,6

7967
               

7968
               i = EdgeMap(k,1)

7969
               j = EdgeMap(k,2)

7970


7971
               tvec(1:3) = Basis(i) * dLBasisdx(j,1:3)

7972
               svec(1:3) = Basis(j) * dLBasisdx(i,1:3)

7973


7974
               grad_svec(1,2) = dLBasisdx(j,2) * dLBasisdx(i,1)

7975
               grad_svec(1,3) = dLBasisdx(j,3) * dLBasisdx(i,1)

7976
               grad_svec(2,1) = dLBasisdx(j,1) * dLBasisdx(i,2)

7977
               grad_svec(2,3) = dLBasisdx(j,3) * dLBasisdx(i,2)

7978
               grad_svec(3,1) = dLBasisdx(j,1) * dLBasisdx(i,3)

7979
               grad_svec(3,2) = dLBasisdx(j,2) * dLBasisdx(i,3)

7980


7981
               grad_tvec(1,2) = dLBasisdx(i,2) * dLBasisdx(j,1)

7982
               grad_tvec(1,3) = dLBasisdx(i,3) * dLBasisdx(j,1)

7983
               grad_tvec(2,1) = dLBasisdx(i,1) * dLBasisdx(j,2)

7984
               grad_tvec(2,3) = dLBasisdx(i,3) * dLBasisdx(j,2)

7985
               grad_tvec(3,1) = dLBasisdx(i,1) * dLBasisdx(j,3)

7986
               grad_tvec(3,2) = dLBasisdx(i,2) * dLBasisdx(j,3)

7987


7988
               WorkBasis(1,1:3) = svec(1:3)

7989
               WorkBasis(2,1:3) = tvec(1:3)

7990


7991
               WorkCurlBasis(1,1) = grad_svec(3,2) - grad_svec(2,3)

7992
               WorkCurlBasis(1,2) = grad_svec(1,3) - grad_svec(3,1)

7993
               WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

7994


7995
               WorkCurlBasis(2,1) = grad_tvec(3,2) - grad_tvec(2,3)

7996
               WorkCurlBasis(2,2) = grad_tvec(1,3) - grad_tvec(3,1)

7997
               WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

7998


7999
               IF (SecondOrder) THEN

8000
                 WorkWeight(1) = 2.0d0*Basis(i) - Basis(j)

8001
                 WorkWeight(2) = 2.0d0*Basis(j) - Basis(i)

8002


8003
                 grad_weight(1,1:3) = 2.0d0*dLBasisdx(i,1:3) - dLBasisdx(j,1:3)

8004
                 grad_weight(2,1:3) = 2.0d0*dLBasisdx(j,1:3) - dLBasisdx(i,1:3)

8005
               END IF

8006


8007
               IF (GIndexes(j) < GIndexes(i)) THEN

8008
                 I1 = 2

8009
                 I2 = 1

8010
               ELSE

8011
                 I1 = 1

8012
                 I2 = 2

8013
               END IF

8014


8015
               DO l=1,EDOFs

8016
                 SELECT CASE(l)

8017
                 CASE(1)

8018
                   sfun = -1.0d0

8019
                   tfun = 1.0d0

8020
                 CASE(2)

8021
                   sfun = 1.0d0

8022
                   tfun = 1.0d0

8023
                 CASE(3)

8024
                   sfun = -WorkWeight(I1)

8025
                   tfun = WorkWeight(I2)

8026
                   grad_sfun(1:3) = -grad_weight(I1,1:3)

8027
                   grad_tfun(1:3) = grad_weight(I2,1:3)

8028
                 CASE DEFAULT

8029
                   CALL Fatal('ElementDescription::EdgeElementInfo','sfun/tfun not defined')

8030
                 END SELECT

8031


8032
                 EdgeBasis(EDOFs*(k-1)+l,1:3) = sfun * WorkBasis(I1,1:3) + tfun * WorkBasis(I2,1:3)

8033
                 CurlBasis(EDOFs*(k-1)+l,1:3) = sfun * WorkCurlBasis(I1,1:3) + tfun * WorkCurlBasis(I2,1:3)

8034


8035
                 IF (l > 2) THEN

8036
                   CurlBasis(EDOFs*(k-1)+l,1) = CurlBasis(EDOFs*(k-1)+l,1) + &

8037
                       grad_sfun(2)*WorkBasis(I1,3) + grad_tfun(2)*WorkBasis(I2,3) - &

8038
                       grad_sfun(3)*WorkBasis(I1,2) - grad_tfun(3)*WorkBasis(I2,2)

8039


8040
                   CurlBasis(EDOFs*(k-1)+l,2) = CurlBasis(EDOFs*(k-1)+l,2) + &

8041
                       grad_sfun(3)*WorkBasis(I1,1) + grad_tfun(3)*WorkBasis(I2,1) - &

8042
                       grad_sfun(1)*WorkBasis(I1,3) - grad_tfun(1)*WorkBasis(I2,3)

8043


8044
                   CurlBasis(EDOFs*(k-1)+l,3) = CurlBasis(EDOFs*(k-1)+l,3) + &

8045
                       grad_sfun(1)*WorkBasis(I1,2) + grad_tfun(1)*WorkBasis(I2,2) - &

8046
                       grad_sfun(2)*WorkBasis(I1,1) - grad_tfun(2)*WorkBasis(I2,1)

8047
                 END IF

8048
               END DO

8049
             END DO

8050


8051
             ! The basis functions associated with the faces for the second-order case

8052
             IF (FDOFs > 0) THEN

8053
               DO k=1,4

8054
                 SELECT CASE(k)

8055
                 CASE(1)

8056
                   TriangleFaceMap(:) = (/ 2,1,3 /)

8057
                 CASE(2)

8058
                   TriangleFaceMap(:) = (/ 1,2,4 /)

8059
                 CASE(3)

8060
                   TriangleFaceMap(:) = (/ 2,3,4 /)

8061
                 CASE(4)

8062
                   TriangleFaceMap(:) = (/ 3,1,4 /)

8063
                 END SELECT

8064


8065
                 I1 = TriangleFaceMap(1)

8066
                 I2 = TriangleFaceMap(2)

8067
                 I3 = TriangleFaceMap(3)

8068


8069
                 WorkBasis(1,1:3) = Basis(I2) * Basis(I3) * dLBasisdx(I1,1:3)

8070
                 WorkBasis(2,1:3) = Basis(I1) * Basis(I3) * dLBasisdx(I2,1:3)

8071
                 WorkBasis(3,1:3) = Basis(I1) * Basis(I2) * dLBasisdx(I3,1:3)

8072


8073
                 ! The gradient of each row of WorkBasis:

8074


8075
                 grad_svec(1,2) = (dLBasisdx(I2,2) * Basis(I3) + &

8076
                     Basis(I2) * dLBasisdx(I3,2)) * dLBasisdx(I1,1)

8077
                 grad_svec(1,3) = (dLBasisdx(I2,3) * Basis(I3) + &

8078
                     Basis(I2) * dLBasisdx(I3,3)) * dLBasisdx(I1,1)

8079
                 grad_svec(2,1) = (dLBasisdx(I2,1) * Basis(I3) + &

8080
                     Basis(I2) * dLBasisdx(I3,1)) * dLBasisdx(I1,2)

8081
                 grad_svec(2,3) = (dLBasisdx(I2,3) * Basis(I3) + &

8082
                     Basis(I2) * dLBasisdx(I3,3)) * dLBasisdx(I1,2)

8083
                 grad_svec(3,1) = (dLBasisdx(I2,1) * Basis(I3) + &

8084
                     Basis(I2) * dLBasisdx(I3,1)) * dLBasisdx(I1,3)

8085
                 grad_svec(3,2) = (dLBasisdx(I2,2) * Basis(I3) + &

8086
                     Basis(I2) * dLBasisdx(I3,2)) * dLBasisdx(I1,3)

8087


8088
                 grad_tvec(1,2) = (dLBasisdx(I1,2) * Basis(I3)  + &

8089
                     Basis(I1) * dLBasisdx(I3,2)) * dLBasisdx(I2,1)

8090
                 grad_tvec(1,3) = (dLBasisdx(I1,3) * Basis(I3)  + &

8091
                     Basis(I1) * dLBasisdx(I3,3)) * dLBasisdx(I2,1)

8092
                 grad_tvec(2,1) = (dLBasisdx(I1,1) * Basis(I3)  + &

8093
                     Basis(I1) * dLBasisdx(I3,1)) * dLBasisdx(I2,2)

8094
                 grad_tvec(2,3) = (dLBasisdx(I1,3) * Basis(I3)  + &

8095
                     Basis(I1) * dLBasisdx(I3,3)) * dLBasisdx(I2,2)

8096
                 grad_tvec(3,1) = (dLBasisdx(I1,1) * Basis(I3)  + &

8097
                     Basis(I1) * dLBasisdx(I3,1)) * dLBasisdx(I2,3)

8098
                 grad_tvec(3,2) = (dLBasisdx(I1,2) * Basis(I3)  + &

8099
                     Basis(I1) * dLBasisdx(I3,2)) * dLBasisdx(I2,3)

8100


8101
                 grad_hvec(1,2) = (dLBasisdx(I1,2) * Basis(I2)  + &

8102
                     Basis(I1) * dLBasisdx(I2,2)) * dLBasisdx(I3,1)

8103
                 grad_hvec(1,3) = (dLBasisdx(I1,3) * Basis(I2)  + &

8104
                     Basis(I1) * dLBasisdx(I2,3)) * dLBasisdx(I3,1)

8105
                 grad_hvec(2,1) = (dLBasisdx(I1,1) * Basis(I2)  + &

8106
                     Basis(I1) * dLBasisdx(I2,1)) * dLBasisdx(I3,2)

8107
                 grad_hvec(2,3) = (dLBasisdx(I1,3) * Basis(I2)  + &

8108
                     Basis(I1) * dLBasisdx(I2,3)) * dLBasisdx(I3,2)

8109
                 grad_hvec(3,1) = (dLBasisdx(I1,1) * Basis(I2)  + &

8110
                     Basis(I1) * dLBasisdx(I2,1)) * dLBasisdx(I3,3)

8111
                 grad_hvec(3,2) = (dLBasisdx(I1,2) * Basis(I2)  + &

8112
                     Basis(I1) * dLBasisdx(I2,2)) * dLBasisdx(I3,3)

8113


8114
                 WorkCurlBasis(1,1) = grad_svec(3,2) - grad_svec(2,3)

8115
                 WorkCurlBasis(1,2) = grad_svec(1,3) - grad_svec(3,1)

8116
                 WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

8117


8118
                 WorkCurlBasis(2,1) = grad_tvec(3,2) - grad_tvec(2,3)

8119
                 WorkCurlBasis(2,2) = grad_tvec(1,3) - grad_tvec(3,1)

8120
                 WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

8121


8122
                 WorkCurlBasis(3,1) = grad_hvec(3,2) - grad_hvec(2,3)

8123
                 WorkCurlBasis(3,2) = grad_hvec(1,3) - grad_hvec(3,1)

8124
                 WorkCurlBasis(3,3) = grad_hvec(2,1) - grad_hvec(1,2)

8125


8126
                 ! Create permutation:

8127
                 FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

8128
                 CALL TriangleFaceDofsOrdering2nd(I1,I2,I3,FaceIndices(1:3))

8129


8130
                 ! Create the basis:

8131
                 DO l=1,FDOFs

8132


8133
                   SELECT CASE(l)

8134
                   CASE(1)

8135
                     sfun = 1.0d0

8136
                     tfun = 1.0d0

8137
                     hfun = 1.0d0

8138
                   CASE(2)

8139
                     sfun = 1.0d0

8140
                     tfun = 1.0d0

8141
                     hfun = -2.0d0

8142
                   CASE(3)

8143
                     sfun = 1.0d0

8144
                     tfun = -1.0d0

8145
                     hfun = 0.0d0

8146
                   END SELECT

8147


8148
                   EdgeBasis(6*EDOFs + FDOFs*(k-1)+l,1:3) = sfun * WorkBasis(I1,1:3) + tfun * WorkBasis(I2,1:3) + &

8149
                       hfun * WorkBasis(I3,1:3)

8150
                   CurlBasis(6*EDOFs + FDOFs*(k-1)+l,1:3) = sfun * WorkCurlBasis(I1,1:3) + tfun * WorkCurlBasis(I2,1:3) + &

8151
                       hfun * WorkCurlBasis(I3,1:3)

8152


8153
                 END DO

8154
               END DO

8155
             END IF

8156


8157
!           ELSE IF (SecondOrder) THEN

8158
           ELSE IF (SecondOrder .AND. Simplicial) THEN

8159
             !

8160
             ! An alternate Nd_1(k=2) basis for faster solution with iterative methods. Currently

8161
             ! this is available only for simplicial elements. 

8162
             !

8163
             EDOFs = 2

8164
             FDOFs = 2

8165
             

8166
             DO k=1,6

8167
               

8168
               i = EdgeMap(k,1)

8169
               j = EdgeMap(k,2)

8170


8171
               tvec(1:3) = Basis(i) * dLBasisdx(j,1:3)

8172
               svec(1:3) = Basis(j) * dLBasisdx(i,1:3)

8173


8174
               grad_svec(1,2) = dLBasisdx(j,2) * dLBasisdx(i,1)

8175
               grad_svec(1,3) = dLBasisdx(j,3) * dLBasisdx(i,1)

8176
               grad_svec(2,1) = dLBasisdx(j,1) * dLBasisdx(i,2)

8177
               grad_svec(2,3) = dLBasisdx(j,3) * dLBasisdx(i,2)

8178
               grad_svec(3,1) = dLBasisdx(j,1) * dLBasisdx(i,3)

8179
               grad_svec(3,2) = dLBasisdx(j,2) * dLBasisdx(i,3)

8180


8181
               grad_tvec(1,2) = dLBasisdx(i,2) * dLBasisdx(j,1)

8182
               grad_tvec(1,3) = dLBasisdx(i,3) * dLBasisdx(j,1)

8183
               grad_tvec(2,1) = dLBasisdx(i,1) * dLBasisdx(j,2)

8184
               grad_tvec(2,3) = dLBasisdx(i,3) * dLBasisdx(j,2)

8185
               grad_tvec(3,1) = dLBasisdx(i,1) * dLBasisdx(j,3)

8186
               grad_tvec(3,2) = dLBasisdx(i,2) * dLBasisdx(j,3)

8187


8188
               WorkBasis(1,1:3) = svec(1:3)

8189
               WorkBasis(2,1:3) = tvec(1:3)

8190


8191
               WorkCurlBasis(1,1) = grad_svec(3,2) - grad_svec(2,3)

8192
               WorkCurlBasis(1,2) = grad_svec(1,3) - grad_svec(3,1)

8193
               WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

8194


8195
               WorkCurlBasis(2,1) = grad_tvec(3,2) - grad_tvec(2,3)

8196
               WorkCurlBasis(2,2) = grad_tvec(1,3) - grad_tvec(3,1)

8197
               WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

8198


8199
               IF (GIndexes(j) < GIndexes(i)) THEN

8200
                 I1 = 2

8201
                 I2 = 1

8202
               ELSE

8203
                 I1 = 1

8204
                 I2 = 2

8205
               END IF

8206


8207
               DO l=1,EDOFs

8208
                 SELECT CASE(l)

8209
                 CASE(1)

8210
                   sfun = -1.0d0

8211
                   tfun = 1.0d0

8212
                 CASE(2)

8213
                   sfun = 1.0d0

8214
                   tfun = 1.0d0

8215
                 CASE DEFAULT

8216
                   CALL Fatal('ElementDescription::EdgeElementInfo','sfun/tfun not defined')

8217
                 END SELECT

8218


8219
                 EdgeBasis(EDOFs*(k-1)+l,1:3) = sfun * WorkBasis(I1,1:3) + tfun * WorkBasis(I2,1:3)

8220
                 CurlBasis(EDOFs*(k-1)+l,1:3) = sfun * WorkCurlBasis(I1,1:3) + tfun * WorkCurlBasis(I2,1:3)

8221
               END DO

8222
             END DO

8223


8224
             ! The basis functions associated with the faces for the second-order case

8225
             DO k=1,4

8226
               SELECT CASE(k)

8227
               CASE(1)

8228
                 TriangleFaceMap(:) = (/ 2,1,3 /)

8229
               CASE(2)

8230
                 TriangleFaceMap(:) = (/ 1,2,4 /)

8231
               CASE(3)

8232
                 TriangleFaceMap(:) = (/ 2,3,4 /)

8233
               CASE(4)

8234
                 TriangleFaceMap(:) = (/ 3,1,4 /)

8235
               END SELECT

8236


8237
               I1 = TriangleFaceMap(1)

8238
               I2 = TriangleFaceMap(2)

8239
               I3 = TriangleFaceMap(3)

8240


8241
               WorkBasis(1,1:3) = Basis(I2) * Basis(I3) * dLBasisdx(I1,1:3)

8242
               WorkBasis(2,1:3) = Basis(I1) * Basis(I3) * dLBasisdx(I2,1:3)

8243
               WorkBasis(3,1:3) = Basis(I1) * Basis(I2) * dLBasisdx(I3,1:3)

8244


8245
               ! The gradient of each row of WorkBasis:

8246


8247
               grad_svec(1,2) = (dLBasisdx(I2,2) * Basis(I3) + &

8248
                   Basis(I2) * dLBasisdx(I3,2)) * dLBasisdx(I1,1)

8249
               grad_svec(1,3) = (dLBasisdx(I2,3) * Basis(I3) + &

8250
                   Basis(I2) * dLBasisdx(I3,3)) * dLBasisdx(I1,1)

8251
               grad_svec(2,1) = (dLBasisdx(I2,1) * Basis(I3) + &

8252
                   Basis(I2) * dLBasisdx(I3,1)) * dLBasisdx(I1,2)

8253
               grad_svec(2,3) = (dLBasisdx(I2,3) * Basis(I3) + &

8254
                   Basis(I2) * dLBasisdx(I3,3)) * dLBasisdx(I1,2)

8255
               grad_svec(3,1) = (dLBasisdx(I2,1) * Basis(I3) + &

8256
                   Basis(I2) * dLBasisdx(I3,1)) * dLBasisdx(I1,3)

8257
               grad_svec(3,2) = (dLBasisdx(I2,2) * Basis(I3) + &

8258
                   Basis(I2) * dLBasisdx(I3,2)) * dLBasisdx(I1,3)

8259


8260
               grad_tvec(1,2) = (dLBasisdx(I1,2) * Basis(I3)  + &

8261
                   Basis(I1) * dLBasisdx(I3,2)) * dLBasisdx(I2,1)

8262
               grad_tvec(1,3) = (dLBasisdx(I1,3) * Basis(I3)  + &

8263
                   Basis(I1) * dLBasisdx(I3,3)) * dLBasisdx(I2,1)

8264
               grad_tvec(2,1) = (dLBasisdx(I1,1) * Basis(I3)  + &

8265
                   Basis(I1) * dLBasisdx(I3,1)) * dLBasisdx(I2,2)

8266
               grad_tvec(2,3) = (dLBasisdx(I1,3) * Basis(I3)  + &

8267
                   Basis(I1) * dLBasisdx(I3,3)) * dLBasisdx(I2,2)

8268
               grad_tvec(3,1) = (dLBasisdx(I1,1) * Basis(I3)  + &

8269
                   Basis(I1) * dLBasisdx(I3,1)) * dLBasisdx(I2,3)

8270
               grad_tvec(3,2) = (dLBasisdx(I1,2) * Basis(I3)  + &

8271
                   Basis(I1) * dLBasisdx(I3,2)) * dLBasisdx(I2,3)

8272


8273
               grad_hvec(1,2) = (dLBasisdx(I1,2) * Basis(I2)  + &

8274
                   Basis(I1) * dLBasisdx(I2,2)) * dLBasisdx(I3,1)

8275
               grad_hvec(1,3) = (dLBasisdx(I1,3) * Basis(I2)  + &

8276
                   Basis(I1) * dLBasisdx(I2,3)) * dLBasisdx(I3,1)

8277
               grad_hvec(2,1) = (dLBasisdx(I1,1) * Basis(I2)  + &

8278
                   Basis(I1) * dLBasisdx(I2,1)) * dLBasisdx(I3,2)

8279
               grad_hvec(2,3) = (dLBasisdx(I1,3) * Basis(I2)  + &

8280
                   Basis(I1) * dLBasisdx(I2,3)) * dLBasisdx(I3,2)

8281
               grad_hvec(3,1) = (dLBasisdx(I1,1) * Basis(I2)  + &

8282
                   Basis(I1) * dLBasisdx(I2,1)) * dLBasisdx(I3,3)

8283
               grad_hvec(3,2) = (dLBasisdx(I1,2) * Basis(I2)  + &

8284
                   Basis(I1) * dLBasisdx(I2,2)) * dLBasisdx(I3,3)

8285


8286
               WorkCurlBasis(1,1) = grad_svec(3,2) - grad_svec(2,3)

8287
               WorkCurlBasis(1,2) = grad_svec(1,3) - grad_svec(3,1)

8288
               WorkCurlBasis(1,3) = grad_svec(2,1) - grad_svec(1,2)

8289


8290
               WorkCurlBasis(2,1) = grad_tvec(3,2) - grad_tvec(2,3)

8291
               WorkCurlBasis(2,2) = grad_tvec(1,3) - grad_tvec(3,1)

8292
               WorkCurlBasis(2,3) = grad_tvec(2,1) - grad_tvec(1,2)

8293


8294
               WorkCurlBasis(3,1) = grad_hvec(3,2) - grad_hvec(2,3)

8295
               WorkCurlBasis(3,2) = grad_hvec(1,3) - grad_hvec(3,1)

8296
               WorkCurlBasis(3,3) = grad_hvec(2,1) - grad_hvec(1,2)

8297


8298
               ! Create permutation:

8299
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

8300
               CALL TriangleFaceDofsOrdering2nd(I1,I2,I3,FaceIndices(1:3))

8301


8302
               ! Create the basis:

8303
               DO l=1,FDOFs

8304


8305
                 SELECT CASE(l)

8306
                 CASE(1)

8307
                   sfun = 1.0d0

8308
                   tfun = 1.0d0

8309
                   hfun = -2.0d0

8310
                 CASE(2)

8311
                   sfun = 1.0d0

8312
                   tfun = -1.0d0

8313
                   hfun = 0.0d0

8314
                 END SELECT

8315


8316
                 EdgeBasis(6*EDOFs + FDOFs*(k-1)+l,1:3) = sfun * WorkBasis(I1,1:3) + tfun * WorkBasis(I2,1:3) + &

8317
                     hfun * WorkBasis(I3,1:3)

8318
                 CurlBasis(6*EDOFs + FDOFs*(k-1)+l,1:3) = sfun * WorkCurlBasis(I1,1:3) + tfun * WorkCurlBasis(I2,1:3) + &

8319
                     hfun * WorkCurlBasis(I3,1:3)

8320
               END DO

8321
             END DO

8322
             

8323
           ELSE

8324
             !-------------------------------------------------------------

8325
             ! The optimal/Nedelec basis functions of the first kind. We employ

8326
             ! a hierarchic basis, so the lowest-order basis functions are

8327
             ! also utilized in the construction of the second-order basis. 

8328
             ! The first the edge ...

8329
             !-------------------------------------------------------------

8330
             i = EdgeMap(1,1)

8331
             j = EdgeMap(1,2)

8332
             EdgeBasis(1,1) = (6.0d0 - 2.0d0*Sqrt(3.0d0)*v - Sqrt(6.0d0)*w)/24.0d0

8333
             EdgeBasis(1,2) = u/(4.0d0*Sqrt(3.0d0))

8334
             EdgeBasis(1,3) = u/(4.0d0*Sqrt(6.0d0))            

8335
             CurlBasis(1,1) = 0.0d0

8336
             CurlBasis(1,2) = -1.0d0/(2.0d0*Sqrt(6.0d0))

8337
             CurlBasis(1,3) = 1.0d0/(2.0d0*Sqrt(3.0d0))

8338
             IF(GIndexes(j)<GIndexes(i)) THEN

8339
               EdgeBasis(1,:) = -EdgeBasis(1,:)

8340
               CurlBasis(1,:) = -CurlBasis(1,:)

8341
             END IF

8342
             IF (SecondOrder) THEN

8343
               EdgeBasis(2,1) = -(u*(-6.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/4.0d0

8344
               EdgeBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0

8345
               EdgeBasis(2,3) = (Sqrt(1.5d0)*u**2)/2.0d0

8346
               CurlBasis(2,1) = 0.0d0

8347
               CurlBasis(2,2) = (-3.0d0*Sqrt(1.5d0)*u)/2.0d0

8348
               CurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0                   

8349
             END IF

8350


8351
             !-------------------------------------------------

8352
             ! Basis functions associated with the second edge:

8353
             !-------------------------------------------------

8354
             IF (SecondOrder) THEN

8355
               k = 3

8356
               EdgeBasis(4,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*(4.0d0*v - Sqrt(2.0d0)*w))/16.0d0

8357
               EdgeBasis(4,2) = -((1.0d0 + u - Sqrt(3.0d0)*v)*&

8358
                   (4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 3.0d0*Sqrt(2.0d0)*w))/16.0d0

8359
               EdgeBasis(4,3) = -((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*&

8360
                   (-1.0d0 - u + Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0))

8361
               CurlBasis(4,1) = (-9.0d0*(1.0d0 + u - Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0))

8362
               CurlBasis(4,2) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/(8.0d0*Sqrt(2.0d0))

8363
               CurlBasis(4,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0

8364
             ELSE

8365
               k = 2

8366
             END IF

8367


8368
             i = EdgeMap(2,1)

8369
             j = EdgeMap(2,2)

8370
             EdgeBasis(k,1) = (-4.0d0*v + Sqrt(2.0d0)*w)/(16.0d0*Sqrt(3.0d0))

8371
             EdgeBasis(k,2) = (4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 3.0d0*Sqrt(2.0d0)*w)/48.0d0

8372
             EdgeBasis(k,3) = -(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)/(24.0d0*Sqrt(2.0d0))

8373
             CurlBasis(k,1) = 1.0d0/(4.0d0*Sqrt(2.0d0))

8374
             CurlBasis(k,2) = 1.0d0/(4.0d0*Sqrt(6.0d0))

8375
             CurlBasis(k,3) = 1.0d0/(2.0d0*Sqrt(3.0d0))

8376
             IF(GIndexes(j)<GIndexes(i)) THEN

8377
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8378
               CurlBasis(k,:) = -CurlBasis(k,:)

8379
             END IF

8380


8381
             !-------------------------------------------------

8382
             ! Basis functions associated with the third edge:

8383
             !-------------------------------------------------

8384
             IF (SecondOrder) THEN

8385
               k = 5

8386
               EdgeBasis(6,1) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v)*&

8387
                   (4.0d0*v - Sqrt(2.0d0)*w))/16.0d0

8388
               EdgeBasis(6,2) = -((-1.0d0 + u + Sqrt(3.0d0)*v)*&

8389
                   (-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + 3.0d0*Sqrt(2.0d0)*w))/16.0d0

8390
               EdgeBasis(6,3) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v)*&

8391
                   (-1.0d0 + u + Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0))

8392
               CurlBasis(6,1) = (9.0d0*(-1.0d0 + u + Sqrt(3.0d0)*v))/(8.0d0*Sqrt(2.0d0))

8393
               CurlBasis(6,2) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/(8.0d0*Sqrt(2.0d0))

8394
               CurlBasis(6,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0

8395
             ELSE

8396
               k = 3

8397
             END IF

8398


8399
             i = EdgeMap(3,1)

8400
             j = EdgeMap(3,2)

8401
             EdgeBasis(k,1) = (-4.0d0*v + Sqrt(2.0d0)*w)/(16.0d0*Sqrt(3.0d0))

8402
             EdgeBasis(k,2) = (-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + 3.0d0*Sqrt(2.0d0)*w)/48.0d0

8403
             EdgeBasis(k,3) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - 3.0d0*Sqrt(2.0d0)*v)/48.0d0

8404
             CurlBasis(k,1) = -1.0d0/(4.0d0*Sqrt(2.0d0))

8405
             CurlBasis(k,2) = 1.0d0/(4.0d0*Sqrt(6.0d0))

8406
             CurlBasis(k,3) = 1.0d0/(2.0d0*Sqrt(3.0d0))

8407
             IF(GIndexes(j)<GIndexes(i)) THEN

8408
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8409
               CurlBasis(k,:) = -CurlBasis(k,:)

8410
             END IF

8411


8412
             !-------------------------------------------------

8413
             ! Basis functions associated with the fourth edge:

8414
             !-------------------------------------------------

8415
             IF (SecondOrder) THEN

8416
               k = 7

8417
               EdgeBasis(8,1) = (3.0d0*w*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + 4.0d0*w))/16.0d0

8418
               EdgeBasis(8,2) = (w*(-3.0d0*Sqrt(2.0d0) + 3.0d0*Sqrt(2.0d0)*u + Sqrt(6.0d0)*v + &

8419
                   4.0d0*Sqrt(3.0d0)*w))/16.0d0

8420
               EdgeBasis(8,3) = -((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v)*&

8421
                   (-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v + 2.0d0*Sqrt(6.0d0)*w))/(8.0d0*Sqrt(2.0d0))

8422
               CurlBasis(8,1) = (-3.0d0*(-3.0d0*Sqrt(2.0d0) + 3.0d0*Sqrt(2.0d0)*u + &

8423
                   Sqrt(6.0d0)*v + 4.0d0*Sqrt(3.0d0)*w))/16.0d0

8424
               CurlBasis(8,2) = (9.0d0*(-Sqrt(6.0d0) + Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + 4.0d0*w))/16.0d0

8425
               CurlBasis(8,3) = 0.0d0

8426
             ELSE

8427
               k = 4

8428
             END IF

8429


8430
             i = EdgeMap(4,1)

8431
             j = EdgeMap(4,2)

8432
             EdgeBasis(k,1) = (Sqrt(1.5d0)*w)/8.0d0

8433
             EdgeBasis(k,2) = w/(8.0d0*Sqrt(2.0d0))

8434
             EdgeBasis(k,3) = (Sqrt(6.0d0) - Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)/16.0d0

8435
             CurlBasis(k,1) = -1.0d0/(4.0d0*Sqrt(2.0d0))

8436
             CurlBasis(k,2) = Sqrt(1.5d0)/4.0d0

8437
             CurlBasis(k,3) = 0.0d0

8438
             IF(GIndexes(j)<GIndexes(i)) THEN

8439
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8440
               CurlBasis(k,:) = -CurlBasis(k,:)

8441
             END IF

8442


8443
             !-------------------------------------------------

8444
             ! Basis functions associated with the fifth edge:

8445
             !-------------------------------------------------

8446
             IF (SecondOrder) THEN

8447
               k = 9

8448
               EdgeBasis(10,1) = (3.0d0*(Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 4.0d0*w)*w)/16.0d0

8449
               EdgeBasis(10,2) = (w*(-3.0d0*Sqrt(2.0d0) - 3.0d0*Sqrt(2.0d0)*u + &

8450
                   Sqrt(6.0d0)*v + 4.0d0*Sqrt(3.0d0)*w))/16.0d0

8451
               EdgeBasis(10,3) = ((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)*&

8452
                   (-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v + 2.0d0*Sqrt(6.0d0)*w))/16.0d0

8453
               CurlBasis(10,1) = (3.0d0*(3.0d0*Sqrt(2.0d0) + 3.0d0*Sqrt(2.0d0)*u - &

8454
                   Sqrt(6.0d0)*v - 4.0d0*Sqrt(3.0d0)*w))/16.0d0

8455
               CurlBasis(10,2) = (9.0d0*(Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 4.0d0*w))/16.0d0

8456
               CurlBasis(10,3) = 0.0d0

8457
             ELSE

8458
               k = 5

8459
             END IF

8460


8461
             i = EdgeMap(5,1)

8462
             j = EdgeMap(5,2)

8463
             EdgeBasis(k,1) = -(Sqrt(1.5d0)*w)/8.0d0

8464
             EdgeBasis(k,2) = w/(8.0d0*Sqrt(2.0d0))

8465
             EdgeBasis(k,3) = (Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)/16.0d0

8466
             CurlBasis(k,1) = -1.0d0/(4.0d0*Sqrt(2.0d0))

8467
             CurlBasis(k,2) = -Sqrt(1.5d0)/4.0d0

8468
             CurlBasis(k,3) = 0.0d0

8469
             IF(GIndexes(j)<GIndexes(i)) THEN

8470
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8471
               CurlBasis(k,:) = -CurlBasis(k,:)

8472
             END IF

8473


8474
             !-------------------------------------------------

8475
             ! Basis functions associated with the sixth edge:

8476
             !-------------------------------------------------

8477
             IF (SecondOrder) THEN

8478
               k = 11

8479
               EdgeBasis(12,1) = 0.0d0

8480
               EdgeBasis(12,2) = (Sqrt(3.0d0)*(Sqrt(2.0d0)*v - 2.0d0*w)*w)/4.0d0

8481
               EdgeBasis(12,3) = (Sqrt(1.5d0)*v*(-v + Sqrt(2.0d0)*w))/2.0d0

8482
               CurlBasis(12,1) = (-3.0d0*(Sqrt(6.0d0)*v - 2.0d0*Sqrt(3.0d0)*w))/4.0d0

8483
               CurlBasis(12,2) = 0.0d0

8484
               CurlBasis(12,3) = 0.0d0

8485
             ELSE

8486
               k = 6

8487
             END IF

8488


8489
             i = EdgeMap(6,1)

8490
             j = EdgeMap(6,2)

8491
             EdgeBasis(k,1) = 0.0d0

8492
             EdgeBasis(k,2) = -w/(4.0d0*Sqrt(2.0d0))

8493
             EdgeBasis(k,3) = v/(4.0d0*Sqrt(2.0d0))

8494
             CurlBasis(k,1) = 1.0d0/(2.0d0*Sqrt(2.0d0))

8495
             CurlBasis(k,2) = 0.0d0

8496
             CurlBasis(k,3) = 0.0d0

8497
             IF(GIndexes(j)<GIndexes(i)) THEN

8498
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8499
               CurlBasis(k,:) = -CurlBasis(k,:)

8500
             END IF

8501


8502
             ! -------------------------------------------------------------

8503
             ! Finally scale the lowest-order basis functions so that 

8504
             ! (b,t) = 1 when the integration is done over the element edge.

8505
             ! -------------------------------------------------------------

8506
             IF (SecondOrder) THEN

8507
               DO k=1,6

8508
                 EdgeBasis(2*(k-1)+1,:) = 2.0d0 * EdgeBasis(2*(k-1)+1,:)

8509
                 CurlBasis(2*(k-1)+1,:) = 2.0d0 * CurlBasis(2*(k-1)+1,:)

8510
               END DO

8511
             ELSE

8512
               DO k=1,6

8513
                 EdgeBasis(k,:) = 2.0d0 * EdgeBasis(k,:)

8514
                 CurlBasis(k,:) = 2.0d0 * CurlBasis(k,:)

8515
               END DO

8516
             END IF

8517


8518
             IF (SecondOrder) THEN

8519
               !-------------------------------------------------

8520
               ! Two basis functions defined on the face 213:

8521
               !-------------------------------------------------

8522
               TriangleFaceMap(:) = (/ 2,1,3 /)          

8523
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

8524
               CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

8525


8526
               WorkBasis(1,1) = ((4.0d0*v - Sqrt(2.0d0)*w)*&

8527
                   (-6.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(48.0d0*Sqrt(3.0d0))

8528
               WorkBasis(1,2) = -(u*(4.0d0*v - Sqrt(2.0d0)*w))/24.0d0

8529
               WorkBasis(1,3) = (u*(-2.0d0*Sqrt(2.0d0)*v + w))/24.0d0

8530
               WorkCurlBasis(1,1) = -u/(4.0d0*Sqrt(2.0d0))

8531
               WorkCurlBasis(1,2) = (Sqrt(6.0d0) + 3.0d0*Sqrt(2.0d0)*v - 3.0d0*w)/24.0d0

8532
               WorkCurlBasis(1,3) = (Sqrt(3.0d0) - 3.0d0*v)/6.0d0

8533


8534
               WorkBasis(2,1) = ((4.0d0*v - Sqrt(2.0d0)*w)*(-6.0d0 + 6.0d0*u + &

8535
                   2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(96.0d0*Sqrt(3.0d0))

8536
               WorkBasis(2,2) = -((4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - 3.0d0*Sqrt(2.0d0)*w)*&

8537
                   (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/288.0d0

8538
               WorkBasis(2,3) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*&

8539
                   (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(144.0d0*Sqrt(2.0d0))

8540
               WorkCurlBasis(2,1) = -(-6.0d0 + 2.0d0*u + 2.0d0*Sqrt(3.0d0)*v + &

8541
                   Sqrt(6.0d0)*w)/(16.0d0*Sqrt(2.0d0))

8542
               WorkCurlBasis(2,2) = (2.0d0*Sqrt(3.0d0) - 6.0d0*Sqrt(3.0d0)*u + &

8543
                   6.0d0*v - 3.0d0*Sqrt(2.0d0)*w)/(48.0d0*Sqrt(2.0d0))

8544
               WorkCurlBasis(2,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0

8545


8546
               WorkBasis(3,1) = -((4.0d0*v - Sqrt(2.0d0)*w)*(-6.0d0 - 6.0d0*u + &

8547
                   2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(96.0d0*Sqrt(3.0d0))

8548
               WorkBasis(3,2) = ((-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + 3.0d0*Sqrt(2.0d0)*w)* &

8549
                   (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/288.0d0

8550
               WorkBasis(3,3) = -((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v)* &

8551
                   (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(144.0d0*Sqrt(2.0d0))

8552
               WorkCurlBasis(3,1) = -(-6.0d0 - 2.0d0*u + 2.0d0*Sqrt(3.0d0)*v + &

8553
                   Sqrt(6.0d0)*w)/(16.0d0*Sqrt(2.0d0))

8554
               WorkCurlBasis(3,2) = (-2.0d0*Sqrt(3.0d0) - 6.0d0*Sqrt(3.0d0)*u - 6.0d0*v + &

8555
                   3.0d0*Sqrt(2.0d0)*w)/(48.0d0*Sqrt(2.0d0))

8556
               WorkCurlBasis(3,3) = (-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0

8557


8558
               IF (RedefineFaceBasis) THEN

8559
                 EdgeBasis(13,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

8560
                 CurlBasis(13,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

8561
                 EdgeBasis(14,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

8562
                 CurlBasis(14,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

8563
               ELSE

8564
                 EdgeBasis(13,:) = D1 * WorkBasis(I1,:)

8565
                 CurlBasis(13,:) = D1 * WorkCurlBasis(I1,:)

8566
                 EdgeBasis(14,:) = D2 * WorkBasis(I2,:)

8567
                 CurlBasis(14,:) = D2 * WorkCurlBasis(I2,:)  

8568
               END IF

8569
                 

8570
               !-------------------------------------------------

8571
               ! Two basis functions defined on the face 124:

8572
               !-------------------------------------------------

8573
               TriangleFaceMap(:) = (/ 1,2,4 /)          

8574
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

8575
               CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

8576


8577
               WorkBasis(1,1) = -(w*(-6.0d0 + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(8.0d0*Sqrt(6.0d0))

8578
               WorkBasis(1,2) = (u*w)/(4.0d0*Sqrt(2.0d0))

8579
               WorkBasis(1,3) = (u*w)/8.0d0

8580
               WorkCurlBasis(1,1) = -u/(4.0d0*Sqrt(2.0d0))

8581
               WorkCurlBasis(1,2) = (Sqrt(6.0d0) - Sqrt(2.0d0)*v - 3.0d0*w)/8.0d0

8582
               WorkCurlBasis(1,3) = w/(2.0d0*Sqrt(2.0d0))

8583


8584
               WorkBasis(2,1) = -(w*(-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + &

8585
                   Sqrt(6.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8586
               WorkBasis(2,2) = (w*(1.0d0 + u - v/Sqrt(3.0d0) - w/Sqrt(6.0d0)))/(8.0d0*Sqrt(2.0d0))

8587
               WorkBasis(2,3) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v)* &

8588
                   (-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(48.0d0*Sqrt(2.0d0))

8589
               WorkCurlBasis(2,1) = (-3.0d0*Sqrt(2.0d0) - Sqrt(2.0d0)*u + Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0

8590
               WorkCurlBasis(2,2) = (Sqrt(6.0d0) + 3.0d0*Sqrt(6.0d0)*u - Sqrt(2.0d0)*v - 3.0d0*w)/16.0d0

8591
               WorkCurlBasis(2,3) =  w/(4.0d0*Sqrt(2.0d0))

8592


8593
               WorkBasis(3,1) = (w*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8594
               WorkBasis(3,2) = -(w*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(48.0d0*Sqrt(2.0d0))

8595
               WorkBasis(3,3) = -((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)*&

8596
                   (-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/96.0d0

8597
               WorkCurlBasis(3,1) = (-3.0d0*Sqrt(2.0d0) + Sqrt(2.0d0)*u + Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0

8598
               WorkCurlBasis(3,2) = (-Sqrt(6.0d0) + 3.0d0*Sqrt(6.0d0)*u + Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0

8599
               WorkCurlBasis(3,3) = -w/(4.0d0*Sqrt(2.0d0))

8600
               

8601
               IF (RedefineFaceBasis) THEN

8602
                 EdgeBasis(15,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

8603
                 CurlBasis(15,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

8604
                 EdgeBasis(16,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

8605
                 CurlBasis(16,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

8606
               ELSE

8607
                 EdgeBasis(15,:) = D1 * WorkBasis(I1,:)

8608
                 CurlBasis(15,:) = D1 * WorkCurlBasis(I1,:)

8609
                 EdgeBasis(16,:) = D2 * WorkBasis(I2,:)

8610
                 CurlBasis(16,:) = D2 * WorkCurlBasis(I2,:)  

8611
               END IF

8612
                 

8613
               !-------------------------------------------------

8614
               ! Two basis functions defined on the face 234:

8615
               !-------------------------------------------------

8616
               TriangleFaceMap(:) = (/ 2,3,4 /)          

8617
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

8618
               CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

8619


8620
               WorkBasis(1,1) = (w*(-2.0d0*Sqrt(2.0d0)*v + w))/16.0d0

8621
               WorkBasis(1,2) = (w*(4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u - &

8622
                   3.0d0*Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8623
               WorkBasis(1,3) = -((1.0d0 + u - Sqrt(3.0d0)*v)*w)/16.0d0

8624
               WorkCurlBasis(1,1) = (-2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u + 3.0d0*Sqrt(3.0d0)*w)/16.0d0

8625
               WorkCurlBasis(1,2) = (-2.0d0*Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0

8626
               WorkCurlBasis(1,3) = w/(2.0d0*Sqrt(2.0d0))

8627


8628
               WorkBasis(2,1) = (w*(-2.0d0*Sqrt(2.0d0)*v + w))/16.0d0

8629
               WorkBasis(2,2) = -(w*(-4.0d0*v + Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8630
               WorkBasis(2,3) = -((Sqrt(6.0d0) + Sqrt(6.0d0)*u - Sqrt(2.0d0)*v)*&

8631
                   (-4.0d0*v + Sqrt(2.0d0)*w))/(32.0d0*Sqrt(3.0d0))

8632
               WorkCurlBasis(2,1) = (2.0d0*Sqrt(2.0d0) + 2.0d0*Sqrt(2.0d0)*u - &

8633
                   2.0d0*Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0

8634
               WorkCurlBasis(2,2) = (-4.0d0*Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0

8635
               WorkCurlBasis(2,3) = w/(4.0d0*Sqrt(2.0d0))

8636


8637
               WorkBasis(3,1) = 0.0d0

8638
               WorkBasis(3,2) = (w*(-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0))

8639
               WorkBasis(3,3) = -(v*(-6.0d0 - 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0))

8640
               WorkCurlBasis(3,1) = (2.0d0*Sqrt(2.0d0) + 2.0d0*Sqrt(2.0d0)*u - Sqrt(6.0d0)*v - Sqrt(3.0d0)*w)/8.0d0

8641
               WorkCurlBasis(3,2) = -v/(4.0d0*Sqrt(2.0d0))

8642
               WorkCurlBasis(3,3) = -w/(4.0d0*Sqrt(2.0d0))

8643


8644
               IF (RedefineFaceBasis) THEN

8645
                 EdgeBasis(17,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:) 

8646
                 CurlBasis(17,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

8647
                 EdgeBasis(18,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

8648
                 CurlBasis(18,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

8649
               ELSE

8650
                 EdgeBasis(17,:) = D1 * WorkBasis(I1,:)

8651
                 CurlBasis(17,:) = D1 * WorkCurlBasis(I1,:)

8652
                 EdgeBasis(18,:) = D2 * WorkBasis(I2,:)

8653
                 CurlBasis(18,:) = D2 * WorkCurlBasis(I2,:)  

8654
               END IF

8655
               

8656
               !-------------------------------------------------

8657
               ! Two basis functions defined on the face 314:

8658
               !-------------------------------------------------

8659
               TriangleFaceMap(:) = (/ 3,1,4 /)          

8660
               FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

8661
               CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

8662


8663
               WorkBasis(1,1) = (w*(-2.0d0*Sqrt(2.0d0)*v + w))/16.0d0

8664
               WorkBasis(1,2) = (w*(-4.0d0*Sqrt(3.0d0) + 4.0d0*Sqrt(3.0d0)*u + &

8665
                   3.0d0*Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8666
               WorkBasis(1,3) = -((-1.0d0 + u + Sqrt(3.0d0)*v)*w)/16.0d0

8667
               WorkCurlBasis(1,1) = (2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u - 3.0d0*Sqrt(3.0d0)*w)/16.0d0

8668
               WorkCurlBasis(1,2) = (-2.0d0*Sqrt(2.0d0)*v + 3.0d0*w)/16.0d0

8669
               WorkCurlBasis(1,3) = w/(2.0d0*Sqrt(2.0d0))

8670


8671
               WorkBasis(2,1) = 0.0d0

8672
               WorkBasis(2,2) = (w*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0))

8673
               WorkBasis(2,3) = -(v*(-6.0d0 + 6.0d0*u + 2.0d0*Sqrt(3.0d0)*v + Sqrt(6.0d0)*w))/(24.0d0*Sqrt(2.0d0))

8674
               WorkCurlBasis(2,1) = (2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u - Sqrt(6.0d0)*v - Sqrt(3.0d0)*w)/8.0d0

8675
               WorkCurlBasis(2,2) = v/(4.0d0*Sqrt(2.0d0))

8676
               WorkCurlBasis(2,3) =  w/(4.0d0*Sqrt(2.0d0))

8677


8678
               WorkBasis(3,1) = ((2.0d0*Sqrt(2.0d0)*v - w)*w)/16.0d0

8679
               WorkBasis(3,2) = -(w*(-4.0d0*v + Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8680
               WorkBasis(3,3) = ((-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v)*&

8681
                   (-4.0d0*v + Sqrt(2.0d0)*w))/(16.0d0*Sqrt(6.0d0))

8682
               WorkCurlBasis(3,1) = (2.0d0*Sqrt(2.0d0) - 2.0d0*Sqrt(2.0d0)*u - &

8683
                   2.0d0*Sqrt(6.0d0)*v + Sqrt(3.0d0)*w)/16.0d0

8684
               WorkCurlBasis(3,2) = (4.0d0*Sqrt(2.0d0)*v - 3.0d0*w)/16.0d0

8685
               WorkCurlBasis(3,3) =  -w/(4.0d0*Sqrt(2.0d0))

8686


8687
               IF (RedefineFaceBasis) THEN

8688
                 EdgeBasis(19,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

8689
                 CurlBasis(19,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

8690
                 EdgeBasis(20,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

8691
                 CurlBasis(20,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

8692
               ELSE

8693
                 EdgeBasis(19,:) = D1 * WorkBasis(I1,:)

8694
                 CurlBasis(19,:) = D1 * WorkCurlBasis(I1,:)

8695
                 EdgeBasis(20,:) = D2 * WorkBasis(I2,:)

8696
                 CurlBasis(20,:) = D2 * WorkCurlBasis(I2,:)

8697
               END IF

8698
                 

8699
               ! Finally, scale to reduce ill-conditioning:

8700
               IF (ScaleFaceBasis) THEN

8701
                 EdgeBasis(13:20:2,:) = sqrt(fs1) * EdgeBasis(13:20:2,:)

8702
                 CurlBasis(13:20:2,:) = sqrt(fs1) * CurlBasis(13:20:2,:)

8703
                 EdgeBasis(14:20:2,:) = sqrt(fs2) * EdgeBasis(14:20:2,:)

8704
                 CurlBasis(14:20:2,:) = sqrt(fs2) * CurlBasis(14:20:2,:)                 

8705
               END IF

8706
             END IF

8707
           END IF

8708


8709
         CASE(6)

8710
           !--------------------------------------------------------------

8711
           ! This branch is for handling pyramidic elements

8712
           !--------------------------------------------------------------         

8713
           EdgeMap => GetEdgeMap(6)

8714


8715
           IF (SecondOrder) THEN

8716
             EdgeSign = 1.0d0

8717


8718
             LBasis(1) = 0.1D1 / 0.4D1 - u / 0.4D1 - v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 + &

8719
                 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 )

8720
             LBasis(2) = 0.1D1 / 0.4D1 + u / 0.4D1 - v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 - &

8721
                 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 )

8722
             LBasis(3) = 0.1D1 / 0.4D1 + u / 0.4D1 + v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 + &

8723
                 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 )

8724
             LBasis(4) = 0.1D1 / 0.4D1 - u / 0.4D1 + v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1 - &

8725
                 u * v / ( (0.1D1 - w * sqrt(0.2D1) / 0.2D1) * 0.4D1 )

8726
             LBasis(5) = w * sqrt(0.2D1) / 0.2D1

8727


8728
             Beta(1) = 0.1D1 / 0.2D1 - u / 0.2D1 - w * sqrt(0.2D1) / 0.4D1

8729
             Beta(2) = 0.1D1 / 0.2D1 - v / 0.2D1 - w * sqrt(0.2D1) / 0.4D1

8730
             Beta(3) = 0.1D1 / 0.2D1 + u / 0.2D1 - w * sqrt(0.2D1) / 0.4D1

8731
             Beta(4) = 0.1D1 / 0.2D1 + v / 0.2D1 - w * sqrt(0.2D1) / 0.4D1

8732


8733
             ! Edge 12:

8734
             !--------------------------------------------------------------

8735
             i = EdgeMap(1,1)

8736
             j = EdgeMap(1,2)

8737
             EdgeBasis(1,1) = 0.1D1 / 0.4D1 - v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1

8738
             EdgeBasis(1,2) = 0.0d0

8739
             EdgeBasis(1,3) = sqrt(0.2D1) * u * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / &

8740
                 ((w * sqrt(0.2D1) - 0.2D1) * 0.8D1)

8741
             CurlBasis(1,1) = sqrt(0.2D1) * u / ((w * sqrt(0.2D1) - 0.2D1) * 0.4D1)

8742
             CurlBasis(1,2) = -sqrt(0.2D1) / 0.8D1 - sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / &

8743
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8744
             CurlBasis(1,3) = 0.1D1 / 0.4D1

8745
             IF(GIndexes(j)<GIndexes(i)) THEN

8746
               EdgeBasis(1,:) = -EdgeBasis(1,:)

8747
               CurlBasis(1,:) = -CurlBasis(1,:)

8748
               EdgeSign(1) = -1.0d0

8749
             END IF

8750


8751
             EdgeBasis(2,1:3) = 3.0d0 * u * EdgeBasis(1,1:3)

8752
             CurlBasis(2,1) = 0.3D1 / 0.4D1 * u ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1)

8753
             CurlBasis(2,2) = -0.3D1 / 0.8D1 * u * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) + &

8754
                 4.0D0 * v - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1)

8755
             CurlBasis(2,3) = 0.3D1 / 0.4D1 * u

8756


8757
             ! Edge 23:

8758
             !--------------------------------------------------------------

8759
             k = 3 ! k=2 for first-order

8760
             i = EdgeMap(2,1)

8761
             j = EdgeMap(2,2)

8762
             EdgeBasis(k,1) = 0.0d0

8763
             EdgeBasis(k,2) = 0.1D1 / 0.4D1 + u / 0.4D1 - w * sqrt(0.2D1) / 0.8D1

8764
             EdgeBasis(k,3) = sqrt(0.2D1) * v * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / &

8765
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8766
             CurlBasis(k,1) = sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / &

8767
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 ) + sqrt(0.2D1) /  0.8D1

8768
             CurlBasis(k,2) = sqrt(0.2D1) * v / ( (w * sqrt(0.2D1) - 0.2D1) * 0.4D1 )

8769
             CurlBasis(k,3) = 0.1D1 / 0.4D1

8770
             IF(GIndexes(j)<GIndexes(i)) THEN

8771
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8772
               CurlBasis(k,:) = -CurlBasis(k,:)

8773
               EdgeSign(k) = -1.0d0

8774
             END IF

8775


8776
             EdgeBasis(k+1,1:3) = 3.0d0 * v * EdgeBasis(k,1:3)

8777
             CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * v * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) - & 

8778
                 4.0D0 * u - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1)

8779
             CurlBasis(k+1,2) = 0.3D1 / 0.4D1 * v ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1)

8780
             CurlBasis(k+1,3) = 0.3D1 / 0.4D1 * v

8781


8782
             ! Edge 43:

8783
             !--------------------------------------------------------------

8784
             k = 5 ! k=3 for first-order

8785
             i = EdgeMap(3,1)

8786
             j = EdgeMap(3,2)

8787
             EdgeBasis(k,1) = 0.1D1 / 0.4D1 + v / 0.4D1 - w * sqrt(0.2D1) / 0.8D1

8788
             EdgeBasis(k,2) = 0.0d0

8789
             EdgeBasis(k,3) = sqrt(0.2D1) * u * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / &

8790
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8791


8792
             CurlBasis(k,1) = -sqrt(0.2D1) * u / ( (w * sqrt(0.2D1) - 0.2D1) * 0.4D1 )

8793
             CurlBasis(k,2) = -sqrt(0.2D1) / 0.8D1 - sqrt(0.2D1) * (w * sqrt(0.2D1) - &

8794
                 2.0D0 * v - 0.2D1) / ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8795
             CurlBasis(k,3) = -0.1D1 / 0.4D1

8796
             IF(GIndexes(j)<GIndexes(i)) THEN

8797
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8798
               CurlBasis(k,:) = -CurlBasis(k,:)

8799
               EdgeSign(k) = -1.0d0

8800
             END IF

8801


8802
             EdgeBasis(k+1,1:3) = 3.0d0 * u * EdgeBasis(k,1:3)

8803
             CurlBasis(k+1,1) = -0.3D1 / 0.4D1 * u ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1)

8804
             CurlBasis(k+1,2) = -0.3D1 / 0.8D1 * u * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) - &

8805
                 4.0D0 * v - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1)

8806
             CurlBasis(k+1,3) = -0.3D1 / 0.4D1 * u

8807


8808


8809
             ! Edge 14:

8810
             !--------------------------------------------------------------

8811
             k = 7 ! k=4 for first-order

8812
             i = EdgeMap(4,1)

8813
             j = EdgeMap(4,2)

8814
             EdgeBasis(k,1) = 0.0d0 

8815
             EdgeBasis(k,2) = 0.1D1 / 0.4D1 - u / 0.4D1 - w * sqrt(0.2D1) / 0.8D1

8816
             EdgeBasis(k,3) = sqrt(0.2D1) * v * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / & 

8817
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8818


8819
             CurlBasis(k,1) = sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / ( (w * &

8820
                 sqrt(0.2D1) - 0.2D1) * 0.8D1 ) + sqrt(0.2D1) / 0.8D1

8821
             CurlBasis(k,2) = -sqrt(0.2D1) * v / ( (w * sqrt(0.2D1) - 0.2D1) * 0.4D1 )

8822
             CurlBasis(k,3) = -0.1D1 / 0.4D1

8823
             IF(GIndexes(j)<GIndexes(i)) THEN

8824
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8825
               CurlBasis(k,:) = -CurlBasis(k,:)

8826
               EdgeSign(k) = -1.0d0

8827
             END IF

8828


8829
             EdgeBasis(k+1,1:3) = 3.0d0 * v * EdgeBasis(k,1:3)

8830
             CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * v * sqrt(0.2D1) * (0.3D1 * w * sqrt(0.2D1) + &

8831
                 4.0D0 * u - 0.6D1) / (w * sqrt(0.2D1) - 0.2D1)

8832
             CurlBasis(k+1,2) = -0.3D1 / 0.4D1 * v ** 2 * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1)

8833
             CurlBasis(k+1,3) = -0.3D1 / 0.4D1 * v

8834


8835


8836
             ! Edge 15:

8837
             !--------------------------------------------------------------

8838
             k = 9 ! k=5 for first-order             

8839
             i = EdgeMap(5,1)

8840
             j = EdgeMap(5,2)

8841
             EdgeBasis(k,1) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / &

8842
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8843
             EdgeBasis(k,2) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / &

8844
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8845
             EdgeBasis(k,3) = -sqrt(0.2D1)/ 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w - &

8846
                 0.2D1 * sqrt(0.2D1) * u * w - &

8847
                 0.2D1 * sqrt(0.2D1) * v * w + u * w ** 2 + v * w ** 2 + 0.2D1 * w * sqrt(0.2D1) - &

8848
                 0.2D1 * u * v - w ** 2 + 0.2D1 * u + 0.2D1 * v - 0.2D1) / (w * sqrt(0.2D1) - 0.2D1) ** 2 

8849


8850
             CurlBasis(k,1) = (-sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * &

8851
                 u * w - 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 )

8852
             CurlBasis(k,2) = -(-sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * &

8853
                 v * w - 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 )

8854
             CurlBasis(k,3) = 0.0d0 

8855
             IF(GIndexes(j)<GIndexes(i)) THEN

8856
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8857
               CurlBasis(k,:) = -CurlBasis(k,:)

8858
               EdgeSign(k) = -1.0d0

8859
             END IF

8860


8861
             EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(1)+LBasis(3) )

8862


8863
             CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * (-0.9D1 * sqrt(0.2D1) * u * w ** 2 - &

8864
                 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 + &

8865
                 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w - &

8866
                 0.8D1 * u * v * w - 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) + &

8867
                 0.24D2 * u * w + 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - 0.16D2 * w) / &

8868
                 (w * sqrt(0.2D1) - 0.2D1)**2

8869
             CurlBasis(k+1,2) = -0.3D1 / 0.8D1 * (-0.3D1 * sqrt(0.2D1) * u * w ** 2 - &

8870
                 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) + &

8871
                 0.4D1 * sqrt(0.2D1) * v ** 2 + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u* v * w - &

8872
                 0.4D1 * v ** 2 * w - 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) + &

8873
                 0.12D2 * u * w + 0.24D2 * v * w + 0.2D1 * sqrt(0.2D1) - 0.16D2 * w) / &

8874
                 (w * sqrt(0.2D1) - 0.2D1)**2

8875
             CurlBasis(k+1,3) = 0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u - v) / (w * sqrt(0.2D1) - 0.2D1)

8876


8877


8878
             ! Edge 25:

8879
             !--------------------------------------------------------------

8880
             k = 11 ! k=6 for first-order  

8881
             i = EdgeMap(6,1)

8882
             j = EdgeMap(6,2)

8883
             EdgeBasis(k,1) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / &

8884
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8885
             EdgeBasis(k,2) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / &

8886
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

8887
             EdgeBasis(k,3) = sqrt(0.2D1)/ 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w - 0.2D1 * &

8888
                 sqrt(0.2D1) * u * w + 0.2D1 * sqrt(0.2D1) * v * w + u * w ** 2 - v * w ** 2 - &

8889
                 0.2D1 * w * sqrt(0.2D1) - 0.2D1 * u * v + w ** 2 + 0.2D1 * u - 0.2D1 * v + 0.2D1) / &

8890
                 (w * sqrt(0.2D1) - 0.2D1) ** 2 

8891
             CurlBasis(k,1) = -(sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * u * w + &

8892
                 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 )

8893
             CurlBasis(k,2) = (-sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * & 

8894
                 v * w - 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 )

8895
             CurlBasis(k,3) = 0.0d0 

8896
             IF(GIndexes(j)<GIndexes(i)) THEN

8897
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8898
               CurlBasis(k,:) = -CurlBasis(k,:)

8899
               EdgeSign(k) = -1.0d0

8900
             END IF

8901


8902
             EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(2)+LBasis(4) )

8903


8904
             CurlBasis(k+1,1) = 0.3D1 / 0.8D1 * (0.9D1 * sqrt(0.2D1) * u * w ** 2 - &

8905
                 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - &

8906
                 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u** 2 * w + &

8907
                 0.8D1 * u * v * w - 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) - &

8908
                 0.6D1 * v * sqrt(0.2D1) - 0.24D2 * u * w + 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - &

8909
                 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)**2

8910
             CurlBasis(k+1,2) = -0.3D1 / 0.8D1 * (-0.3D1 * sqrt(0.2D1) * u * w ** 2 + &

8911
                 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) - &

8912
                 0.4D1 * sqrt(0.2D1) * v ** 2 - 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + &

8913
                 0.4D1 * v ** 2 * w + 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + &

8914
                 0.6D1 * v * sqrt(0.2D1) + 0.12D2 * u * w - 0.24D2 * v * w - 0.2D1 * sqrt(0.2D1) + &

8915
                 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)** 2

8916
             CurlBasis(k+1,3) = 0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u + v) / (w * sqrt(0.2D1) - 0.2D1)

8917


8918


8919
             ! Edge 35:

8920
             !--------------------------------------------------------------

8921
             k = 13 ! k=7 for first-order  

8922
             i = EdgeMap(7,1)

8923
             j = EdgeMap(7,2)

8924
             EdgeBasis(k,1) = -w * sqrt(0.2D1)/ 0.8D1 * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / &

8925
                 (w * sqrt(0.2D1) - 0.2D1) 

8926
             EdgeBasis(k,2) = -w * sqrt(0.2D1) / 0.8D1 * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / & 

8927
                 (w * sqrt(0.2D1) - 0.2D1)

8928
             EdgeBasis(k,3) = -sqrt(0.2D1)/ 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w + 0.2D1 * &

8929
                 sqrt(0.2D1) * u * w + 0.2D1 * sqrt(0.2D1) * v * w - u * w ** 2 - v * w ** 2 + &

8930
                 0.2D1 * w * sqrt(0.2D1) - 0.2D1 * u * v - w ** 2 - 0.2D1 * u - 0.2D1 * v - 0.2D1) / &

8931
                 (w * sqrt(0.2D1) - 0.2D1) ** 2 

8932
             CurlBasis(k,1) = (sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * u * w + &

8933
                 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 )

8934
             CurlBasis(k,2) = -(sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * &

8935
                 v * w + 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / &

8936
                 ( (w * sqrt(0.2D1) - 0.2D1) ** 2 * 0.2D1 )

8937
             CurlBasis(k,3) = 0.0d0 

8938
             IF(GIndexes(j)<GIndexes(i)) THEN

8939
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8940
               CurlBasis(k,:) = -CurlBasis(k,:)

8941
               EdgeSign(k) = -1.0d0

8942
             END IF

8943


8944
             EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(3)+LBasis(1) )

8945


8946
             CurlBasis(k+1,1) = -0.3D1 / 0.8D1 * (0.9D1 * sqrt(0.2D1) * u * w ** 2 + &

8947
                 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 + &

8948
                 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w - &

8949
                 0.8D1 * u * v * w - 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) + &

8950
                 0.6D1 * v * sqrt(0.2D1) - 0.24D2 * u * w - 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - &

8951
                 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)**2

8952
             CurlBasis(k+1,2) = 0.3D1 / 0.8D1 * (0.3D1 * sqrt(0.2D1) * u * w ** 2 + &

8953
                 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) + &

8954
                 0.4D1 * sqrt(0.2D1) * v ** 2 + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u *v * w - &

8955
                 0.4D1 * v ** 2 * w - 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) + 0.6D1 * v * sqrt(0.2D1) - &

8956
                 0.12D2 * u * w - 0.24D2 * v * w + 0.2D1 * sqrt(0.2D1) - 0.16D2 * w) / &

8957
                 (w * sqrt(0.2D1) - 0.2D1) ** 2

8958
             CurlBasis(k+1,3) = -0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u - v) / (w * sqrt(0.2D1) - 0.2D1)

8959


8960


8961
             ! Edge 45:

8962
             !--------------------------------------------------------------

8963
             k = 15 ! k=8 for first-order  

8964
             i = EdgeMap(8,1)

8965
             j = EdgeMap(8,2)

8966
             EdgeBasis(k,1) = w * sqrt(0.2D1) / 0.8D1 * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / &

8967
                 (w * sqrt(0.2D1) - 0.2D1) 

8968
             EdgeBasis(k,2) = -w * sqrt(0.2D1) / 0.8D1 * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / &

8969
                 (w * sqrt(0.2D1) - 0.2D1)

8970
             EdgeBasis(k,3) = sqrt(0.2D1) / 0.4D1 * (0.2D1 * sqrt(0.2D1) * u * v * w + &

8971
                 0.2D1 * sqrt(0.2D1) * u * w - 0.2D1 * sqrt(0.2D1) * v * w - u * w ** 2 + v * w ** 2 - &

8972
                 0.2D1 * w * sqrt(0.2D1) - 0.2D1 * u * v + w ** 2 - 0.2D1 * u + 0.2D1 * v + 0.2D1) / &

8973
                 (w * sqrt(0.2D1) - 0.2D1) ** 2 

8974
             CurlBasis(k,1) = -(-sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.2D1 * u * w - &

8975
                 0.2D1 * sqrt(0.2D1) + 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1)** 2 * 0.2D1 )

8976
             CurlBasis(k,2) = (sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.2D1 * v * w + &

8977
                 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1)** 2 * 0.2D1 )

8978
             CurlBasis(k,3) = 0.0d0 

8979
             IF(GIndexes(j)<GIndexes(i)) THEN

8980
               EdgeBasis(k,:) = -EdgeBasis(k,:)

8981
               CurlBasis(k,:) = -CurlBasis(k,:)

8982
               EdgeSign(k) = -1.0d0

8983
             END IF

8984


8985
             EdgeBasis(k+1,1:3) = 3.0d0 * EdgeSign(k) * EdgeBasis(k,1:3) * ( LBasis(5)-LBasis(4)+LBasis(2) )

8986


8987
             CurlBasis(k+1,1) = -0.3D1 / 0.8D1 * (-0.9D1 * sqrt(0.2D1) * u * w ** 2 + &

8988
                 0.3D1 * sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - &

8989
                 0.6D1 * u * v * sqrt(0.2D1) + 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u** 2 * w + &

8990
                 0.8D1 * u * v * w - 0.6D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + &

8991
                 0.6D1 * v * sqrt(0.2D1) + 0.24D2 * u * w - 0.12D2 * v * w + 0.2D1 * sqrt(0.2D1) - &

8992
                 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1) ** 2

8993
             CurlBasis(k+1,2) = 0.3D1 / 0.8D1 * (0.3D1 * sqrt(0.2D1) * u * w ** 2 - &

8994
                 0.9D1 * sqrt(0.2D1) * v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) - &

8995
                 0.4D1 * sqrt(0.2D1) * v ** 2 - 0.13D2 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u *v * w + &

8996
                 0.4D1 * v ** 2 * w + 0.6D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) - &

8997
                 0.6D1 * v * sqrt(0.2D1) - 0.12D2 * u * w + 0.24D2 * v * w - 0.2D1 * sqrt(0.2D1) + &

8998
                 0.16D2 * w) / (w * sqrt(0.2D1) - 0.2D1)**2

8999
             CurlBasis(k+1,3) = -0.3D1 / 0.8D1 * w * sqrt(0.2D1) * (u + v) / (w * sqrt(0.2D1) - 0.2D1)

9000


9001


9002
             ! Square face:

9003
             ! ------------------------------------------------------------------

9004
             SquareFaceMap(:) = (/ 1,2,3,4 /)

9005


9006
             WorkBasis(1,1:3) = 2.0d0 * ( EdgeSign(1) * EdgeBasis(1,1:3) * Beta(4) + &

9007
                 EdgeSign(5) * EdgeBasis(5,1:3) * Beta(2) ) / (1.0d0 - LBasis(5))

9008
             WorkCurlBasis(1,1) = -0.2D1 * u * v * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) ** 2

9009
             WorkCurlBasis(1,2) = -(sqrt(0.2D1) * w ** 2 + 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / & 

9010
                 (w * sqrt(0.2D1) - 0.2D1) ** 2

9011
             WorkCurlBasis(1,3) = -0.2D1 * v / (w * sqrt(0.2D1) - 0.2D1)

9012


9013
             WorkBasis(2,1:3) = 3.0d0 * WorkBasis(1,1:3) * u

9014
             WorkCurlBasis(2,1) = -0.6D1 * u ** 2 * sqrt(0.2D1) * v / (w * sqrt(0.2D1) - 0.2D1)** 2

9015
             WorkCurlBasis(2,2) = 0.3D1 / 0.2D1 * u * (0.2D1 * sqrt(0.2D1) * v ** 2 - &

9016
                 0.3D1 * sqrt(0.2D1) * w ** 2 - 0.6D1 * sqrt(0.2D1) + 0.12D2 * w) / &

9017
                 (w * sqrt(0.2D1) - 0.2D1) ** 2

9018
             WorkCurlBasis(2,3) = -0.6D1 * u * v / (w * sqrt(0.2D1) - 0.2D1)

9019


9020
             WorkBasis(3,1:3) = 2.0d0 * ( EdgeSign(3) * EdgeBasis(3,1:3) * Beta(1) + &

9021
                 EdgeSign(7) * EdgeBasis(7,1:3) * Beta(3) ) / (1.0d0 - LBasis(5))

9022
             WorkCurlBasis(3,1) = (sqrt(0.2D1) * w ** 2 + 0.2D1 * sqrt(0.2D1) - 0.4D1 * w) / &

9023
                 (w * sqrt(0.2D1) - 0.2D1) ** 2

9024
             WorkCurlBasis(3,2) = 0.2D1 * u * v * sqrt(0.2D1) / (w * sqrt(0.2D1) - 0.2D1) ** 2

9025
             WorkCurlBasis(3,3) = 0.2D1 * u / (w * sqrt(0.2D1) - 0.2D1)

9026


9027
             WorkBasis(4,1:3) = 3.0d0 * WorkBasis(3,1:3) * v

9028
             WorkCurlBasis(4,1) = -0.3D1 / 0.2D1 * v * (0.2D1 * sqrt(0.2D1) * u ** 2 - &

9029
                 0.3D1 * sqrt(0.2D1) * w ** 2 - 0.6D1 * sqrt(0.2D1) + 0.12D2 * w) / &

9030
                 (w * sqrt(0.2D1) - 0.2D1) ** 2

9031
             WorkCurlBasis(4,2) = 0.6D1 * sqrt(0.2D1) * v ** 2 * u / (w * sqrt(0.2D1) - 0.2D1)**2

9032
             WorkCurlBasis(4,3) = 0.6D1 * u * v / (w * sqrt(0.2D1) - 0.2D1)

9033


9034
             ! -------------------------------------------------------------------

9035
             ! Finally apply an order change and sign reversions if needed. 

9036
             ! -------------------------------------------------------------------

9037
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

9038
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9039


9040
             EdgeBasis(17,:) = D1 * WorkBasis(2*(I1-1)+1,:)

9041
             CurlBasis(17,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

9042
             EdgeBasis(18,:) = WorkBasis(2*(I1-1)+2,:)

9043
             CurlBasis(18,:) = WorkCurlBasis(2*(I1-1)+2,:)

9044
             EdgeBasis(19,:) = D2 * WorkBasis(2*(I2-1)+1,:)

9045
             CurlBasis(19,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

9046
             EdgeBasis(20,:) = WorkBasis(2*(I2-1)+2,:)

9047
             CurlBasis(20,:) = WorkCurlBasis(2*(I2-1)+2,:) 

9048


9049
             

9050
             !-------------------------------------------------

9051
             ! Two basis functions defined on the face 125:

9052
             !-------------------------------------------------

9053
             TriangleFaceMap(:) = (/ 1,2,5 /)           

9054
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

9055
             CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9056


9057
             WorkBasis(1,1:3) = LBasis(5) * EdgeSign(1) * EdgeBasis(1,1:3)

9058
             WorkCurlBasis(1,1) = w * u / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1

9059
             WorkCurlBasis(1,2) = (-0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - & 

9060
                 0.4D1 * v * w - 0.2D1 * sqrt(0.2D1) + 0.8D1 * w) / &

9061
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

9062
             WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1

9063


9064
             WorkBasis(2,1:3) = Beta(3) * EdgeSign(9) * EdgeBasis(9,1:3)

9065
             WorkCurlBasis(2,1) = (sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - &

9066
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 - &

9067
                 0.2D1 * u * w - 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / &

9068
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9069
             WorkCurlBasis(2,2) = -(-0.3D1 * sqrt(0.2D1) * u * w ** 2 + 0.2D1 * sqrt(0.2D1) * &

9070
                 v * w ** 2 + 0.6D1 * u * v * sqrt(0.2D1) - 0.7D1 * sqrt(0.2D1) * w ** 2 - &

9071
                 0.8D1 * u * v * w + 0.3D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + 0.2D1 * v * sqrt(0.2D1) + &

9072
                 0.12D2 * u * w - 0.6D1 * v * w - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / &

9073
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1)**2 )

9074
             WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / &

9075
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.16D2 )

9076


9077
             WorkBasis(3,1:3) = Beta(1) * EdgeSign(11) * EdgeBasis(11,1:3)

9078
             WorkCurlBasis(3,1) = (-sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - &

9079
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 + &

9080
                 0.2D1 * u * w - 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / &

9081
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1)** 2 ) 

9082
             WorkCurlBasis(3,2) = -(-0.3D1 * sqrt(0.2D1) * u * w ** 2 - 0.2D1 * sqrt(0.2D1) * v * w ** 2 + &

9083
                 0.6D1 * u * v * sqrt(0.2D1) + 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w - &

9084
                 0.3D1 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) - 0.2D1 * v * sqrt(0.2D1) + 0.12D2 * u * w + &

9085
                 0.6D1 * v * w + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / &

9086
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1)**2 ) 

9087
             WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / &

9088
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9089


9090
             IF (RedefineFaceBasis) THEN

9091
               EdgeBasis(21,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

9092
               CurlBasis(21,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

9093
               EdgeBasis(22,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

9094
               CurlBasis(22,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

9095
             ELSE             

9096
               EdgeBasis(21,:) = D1 * WorkBasis(I1,:)

9097
               CurlBasis(21,:) = D1 * WorkCurlBasis(I1,:)

9098
               EdgeBasis(22,:) = D2 * WorkBasis(I2,:)

9099
               CurlBasis(22,:) = D2 * WorkCurlBasis(I2,:)              

9100
             END IF

9101
               

9102
             !-------------------------------------------------

9103
             ! Two basis functions defined on the face 235:

9104
             !-------------------------------------------------

9105
             TriangleFaceMap(:) = (/ 2,3,5 /)          

9106
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

9107
             CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9108


9109
             WorkBasis(1,1:3) = LBasis(5) * EdgeSign(3) * EdgeBasis(3,1:3)

9110
             WorkCurlBasis(1,1) = (0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - 0.4D1 * u * w + &

9111
                 0.2D1 * sqrt(0.2D1) - 0.8D1 * w) / ( (w * sqrt(0.2D1) - 0.2D1) * 0.8D1 )

9112
             WorkCurlBasis(1,2) = w * v / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1

9113
             WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1

9114


9115
             WorkBasis(2,1:3) = Beta(4) * EdgeSign(11) * EdgeBasis(11,1:3)

9116
             WorkCurlBasis(2,1) = -(0.2D1 * sqrt(0.2D1) * u * w ** 2 + 0.3D1 * sqrt(0.2D1) * v * w ** 2 + &

9117
                 0.6D1 * sqrt(0.2D1) * u * v + 0.7D1 * sqrt(0.2D1) * w** 2 - 0.8D1 * u * v * w - &

9118
                 0.3D1 * w ** 3 + 0.2D1 * u * sqrt(0.2D1) + 0.6D1 * v * sqrt(0.2D1) - 0.6D1 * u * w - &

9119
                 0.12D2 * w * v + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / &

9120
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2) 

9121
             WorkCurlBasis(2,2) = (sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - &

9122
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 - 0.2D1 * w * v - &

9123
                 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 )

9124
             WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / &

9125
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9126


9127
             WorkBasis(3,1:3) = Beta(2) * EdgeSign(13) * EdgeBasis(13,1:3)

9128
             WorkCurlBasis(3,1) = -(-0.2D1 * sqrt(0.2D1) * u * w ** 2 + 0.3D1 * sqrt(0.2D1) * v * w ** 2 + &

9129
                 0.6D1 * sqrt(0.2D1) * u * v - 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + &

9130
                 0.3D1 * w ** 3 - 0.2D1 * u * sqrt(0.2D1) + 0.6D1 * v * sqrt(0.2D1) + 0.6D1 * u * w - &

9131
                 0.12D2 * w * v - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / &

9132
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9133
             WorkCurlBasis(3,2) = (-sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - &

9134
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 + 0.2D1 * w * v - &

9135
                 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9136
             WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / &

9137
                 ( (w * sqrt(0.2D1) - 0.2D1) * 0.16D2 )

9138


9139
             IF (RedefineFaceBasis) THEN

9140
               EdgeBasis(23,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

9141
               CurlBasis(23,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

9142
               EdgeBasis(24,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

9143
               CurlBasis(24,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

9144
             ELSE

9145
               EdgeBasis(23,:) = D1 * WorkBasis(I1,:)

9146
               CurlBasis(23,:) = D1 * WorkCurlBasis(I1,:)

9147
               EdgeBasis(24,:) = D2 * WorkBasis(I2,:)

9148
               CurlBasis(24,:) = D2 * WorkCurlBasis(I2,:)

9149
             END IF

9150


9151
             !-------------------------------------------------

9152
             ! Two basis functions defined on the face 345:

9153
             !-------------------------------------------------

9154
             TriangleFaceMap(:) = (/ 3,4,5 /)           

9155
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

9156
             CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9157


9158
             WorkBasis(1,1:3) = -LBasis(5) * EdgeSign(5) * EdgeBasis(5,1:3)

9159
             WorkCurlBasis(1,1) = w * u / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1

9160
             WorkCurlBasis(1,2) = (0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * v * sqrt(0.2D1) - 0.4D1 * w * v + &

9161
                 0.2D1 * sqrt(0.2D1) - 0.8D1 * w) / (0.8D1 * (w * sqrt(0.2D1)- 0.2D1) )

9162
             WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1

9163


9164
             WorkBasis(2,1:3) = Beta(1) * EdgeSign(13) * EdgeBasis(13,1:3)

9165
             WorkCurlBasis(2,1) = -(-sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - &

9166
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 + 0.2D1 * u * w - &

9167
                 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9168
             WorkCurlBasis(2,2) = (0.3D1 * sqrt(0.2D1) * u * w ** 2 - 0.2D1 * sqrt(0.2D1) * v * w ** 2 + &

9169
                 0.6D1 * sqrt(0.2D1) * u * v - 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + &

9170
                 0.3D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) - 0.2D1 * v * sqrt(0.2D1) - 0.12D2 * u * w + &

9171
                 0.6D1 * w * v - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / &

9172
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9173
             WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * u - 0.2D1) / &

9174
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9175


9176
             WorkBasis(3,1:3) = Beta(3) * EdgeSign(15) * EdgeBasis(15,1:3)

9177
             WorkCurlBasis(3,1) = -(sqrt(0.2D1) * u * w ** 2 + 0.4D1 * sqrt(0.2D1) * u ** 2 - &

9178
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u ** 2 * w + 0.3D1 * w ** 3 - 0.2D1 * u * w - &

9179
                 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9180
             WorkCurlBasis(3,2) = (0.3D1 * sqrt(0.2D1) * u * w ** 2 + 0.2D1 * sqrt(0.2D1) * v * w ** 2 + &

9181
                 0.6D1 * sqrt(0.2D1) * u * v + 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w - &

9182
                 0.3D1 * w ** 3 + 0.6D1 * u * sqrt(0.2D1) + 0.2D1 * v * sqrt(0.2D1) - 0.12D2 * u * w - &

9183
                 0.6D1 * w * v + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / &

9184
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9185
             WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * u - 0.2D1) / &

9186
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9187


9188
             IF (RedefineFaceBasis) THEN

9189
               EdgeBasis(25,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

9190
               CurlBasis(25,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

9191
               EdgeBasis(26,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

9192
               CurlBasis(26,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

9193
             ELSE

9194
               EdgeBasis(25,:) = D1 * WorkBasis(I1,:)

9195
               CurlBasis(25,:) = D1 * WorkCurlBasis(I1,:)

9196
               EdgeBasis(26,:) = D2 * WorkBasis(I2,:)

9197
               CurlBasis(26,:) = D2 * WorkCurlBasis(I2,:)              

9198
             END IF

9199
               

9200
             !-------------------------------------------------

9201
             ! Two basis functions defined on the face 415:

9202
             !-------------------------------------------------

9203
             TriangleFaceMap(:) = (/ 4,1,5 /)          

9204
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

9205
             CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9206


9207
             WorkBasis(1,1:3) = -LBasis(5) * EdgeSign(7) * EdgeBasis(7,1:3)

9208
             WorkCurlBasis(1,1) = (-0.3D1 * sqrt(0.2D1) * w ** 2 + 0.2D1 * u * sqrt(0.2D1) - &

9209
                 0.4D1 * u * w - 0.2D1 * sqrt(0.2D1) + 0.8D1 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) )

9210
             WorkCurlBasis(1,2) = w * v / (w * sqrt(0.2D1) - 0.2D1) / 0.4D1

9211
             WorkCurlBasis(1,3) = w * sqrt(0.2D1) / 0.8D1

9212


9213
             WorkBasis(2,1:3) = Beta(2) * EdgeSign(15) * EdgeBasis(15,1:3)

9214
             WorkCurlBasis(2,1) = (-0.2D1 * sqrt(0.2D1) * u * w ** 2 - 0.3D1 * sqrt(0.2D1) * v * w ** 2 + &

9215
                 0.6D1 * sqrt(0.2D1) * u * v + 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w - &

9216
                 0.3D1 * w ** 3 - 0.2D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) + 0.6D1 * u * w + &

9217
                 0.12D2 * w * v + 0.2D1 * sqrt(0.2D1) - 0.10D2 * w) / &

9218
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 )

9219
             WorkCurlBasis(2,2) = -(-sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - &

9220
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 + 0.2D1 * w * v - &

9221
                 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9222
             WorkCurlBasis(2,3) = w * sqrt(0.2D1) * (w * sqrt(0.2D1) - 2.0D0 * v - 0.2D1) / &

9223
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9224


9225
             WorkBasis(3,1:3) = Beta(4) * EdgeSign(9) * EdgeBasis(9,1:3)

9226
             WorkCurlBasis(3,1) = (0.2D1 * sqrt(0.2D1) * u * w ** 2 - 0.3D1 * sqrt(0.2D1) * v * w ** 2 + &

9227
                 0.6D1 * sqrt(0.2D1) * u * v - 0.7D1 * sqrt(0.2D1) * w ** 2 - 0.8D1 * u * v * w + &

9228
                 0.3D1 * w ** 3 + 0.2D1 * u * sqrt(0.2D1) - 0.6D1 * v * sqrt(0.2D1) - 0.6D1 * u * w + &

9229
                 0.12D2 * w * v - 0.2D1 * sqrt(0.2D1) + 0.10D2 * w) / &

9230
                 (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9231
             WorkCurlBasis(3,2) = -(sqrt(0.2D1) * v * w ** 2 + 0.4D1 * sqrt(0.2D1) * v ** 2 - &

9232
                 0.8D1 * sqrt(0.2D1) * w ** 2 - 0.4D1 * v ** 2 * w + 0.3D1 * w ** 3 - 0.2D1 * w * v - &

9233
                 0.4D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.8D1 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9234
             WorkCurlBasis(3,3) = -w * sqrt(0.2D1) * (w * sqrt(0.2D1) + 2.0D0 * v - 0.2D1) / &

9235
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9236


9237
             IF (RedefineFaceBasis) THEN

9238
               EdgeBasis(27,:) = 0.5d0 * D1 * WorkBasis(I1,:) + 0.5d0 * D2 * WorkBasis(I2,:)

9239
               CurlBasis(27,:) = 0.5d0 * D1 * WorkCurlBasis(I1,:) + 0.5d0 * D2 * WorkCurlBasis(I2,:)

9240
               EdgeBasis(28,:) = 0.5d0 * D2 * WorkBasis(I2,:) - 0.5d0 * D1 * WorkBasis(I1,:)

9241
               CurlBasis(28,:) = 0.5d0 * D2 * WorkCurlBasis(I2,:) - 0.5d0 * D1 * WorkCurlBasis(I1,:)

9242
             ELSE

9243
               EdgeBasis(27,:) = D1 * WorkBasis(I1,:)

9244
               CurlBasis(27,:) = D1 * WorkCurlBasis(I1,:)

9245
               EdgeBasis(28,:) = D2 * WorkBasis(I2,:)

9246
               CurlBasis(28,:) = D2 * WorkCurlBasis(I2,:)              

9247
             END IF

9248


9249
             ! Finally three interior basis functions:

9250
             ! -----------------------------------------------------------------------------------

9251
             EdgeBasis(29,1:3) = LBasis(5) * Beta(4) * EdgeSign(1) * EdgeBasis(1,1:3)

9252
             CurlBasis(29,1) = u * v * w / (0.4D1 * (w * sqrt(0.2D1) - 0.2D1) ) 

9253
             CurlBasis(29,2) = (0.2D1 * sqrt(0.2D1) * v ** 2 - 0.9D1 * sqrt(0.2D1) * w ** 2 - &

9254
                 0.4D1 * v ** 2 * w + 0.4D1 * w ** 3 - 0.2D1 * sqrt(0.2D1) + 0.12D2 * w) / &

9255
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9256
             CurlBasis(29,3) = sqrt(0.2D1) * v * w / 0.8D1

9257


9258
             EdgeBasis(30,1:3) = LBasis(5) * Beta(3) * EdgeSign(7) * EdgeBasis(7,1:3)

9259
             CurlBasis(30,1) = -(0.2D1 * sqrt(0.2D1) * u ** 2 - 0.9D1 * sqrt(0.2D1) * w **2 - &

9260
                 0.4D1 * u ** 2 * w + 0.4D1 * w ** 3 - 0.2D1 * sqrt(0.2D1) + 0.12D2 * w) / &

9261
                 (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ) 

9262
             CurlBasis(30,2) = -u * v * w / (0.4D1* (w * sqrt(0.2D1) - 0.2D1) ) 

9263
             CurlBasis(30,3) = -sqrt(0.2D1) * u * w / 0.8D1

9264


9265
             EdgeBasis(31,1:3) = Beta(3) * Beta(4) * EdgeSign(9) * EdgeBasis(9,1:3)

9266
             CurlBasis(31,1) = (0.2D1 * sqrt(0.2D1) * u ** 2 * w ** 2 + 0.2D1 * sqrt(0.2D1) * u * v * w ** 2 -&

9267
                 0.2D1 * sqrt(0.2D1) * w ** 4 + 0.6D1 * sqrt(0.2D1) * u ** 2 * v - &

9268
                 0.11D2 * sqrt(0.2D1) * v * w ** 2 - 0.8D1 * u ** 2 * v * w + 0.4D1 * v * w ** 3 + &

9269
                 0.2D1 * sqrt(0.2D1) * u ** 2 - 0.15D2 * sqrt(0.2D1) * w ** 2 - 0.6D1 * u ** 2 * w - &

9270
                 0.4D1 * u * v * w + 0.13D2 * w ** 3 - 0.6D1 * v * sqrt(0.2D1) + 0.20D2 * w * v - &

9271
                 0.2D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9272
             CurlBasis(31,2) = -(0.2D1 * sqrt(0.2D1) * u * v * w ** 2 + 0.2D1 * sqrt(0.2D1) * v ** 2 * w**2 - &

9273
                 0.2D1 * sqrt(0.2D1) * w ** 4 + 0.6D1 * sqrt(0.2D1) * u * v ** 2 - &

9274
                 0.11D2 * sqrt(0.2D1) * u * w ** 2 - 0.8D1 * u * v ** 2 * w + 0.4D1 * u * w ** 3 + &

9275
                 0.2D1 * sqrt(0.2D1) * v ** 2 - 0.15D2 * sqrt(0.2D1) * w ** 2 - 0.4D1 * u * v * w - &

9276
                 0.6D1 * v ** 2 * w + 0.13D2 * w ** 3 - 0.6D1 * u * sqrt(0.2D1) + 0.20D2 * u *w - &

9277
                 0.2D1 * sqrt(0.2D1) + 0.14D2 * w) / (0.16D2 * (w * sqrt(0.2D1) - 0.2D1) ** 2 ) 

9278
             CurlBasis(31,3) = -(u - v) * w * sqrt(0.2D1) / 0.16D2

9279


9280
             ! Finally, scale to reduce ill-conditioning:

9281
             IF (ScaleFaceBasis) THEN

9282
               EdgeBasis(21:27:2,:) = sqrt(fs1) * EdgeBasis(21:27:2,:)

9283
               CurlBasis(21:27:2,:) = sqrt(fs1) * CurlBasis(21:27:2,:)

9284
               EdgeBasis(22:28:2,:) = sqrt(fs2) * EdgeBasis(22:28:2,:)

9285
               CurlBasis(22:28:2,:) = sqrt(fs2) * CurlBasis(22:28:2,:)                 

9286


9287
               EdgeBasis(29:30,:) = sqrt(506.9d0) * EdgeBasis(29:30,:)

9288
               CurlBasis(29:30,:) = sqrt(506.9d0) * CurlBasis(29:30,:)

9289
               EdgeBasis(31,:) = sqrt(167.8d0) * EdgeBasis(31,:)

9290
               CurlBasis(31,:) = sqrt(167.8d0) * CurlBasis(31,:)

9291
             END IF

9292
             

9293
           ELSE

9294
             !-----------------------------------------------------------------------------------------

9295
             ! The lowest-order pyramid from the optimal family. Now these basis functions are 

9296
             ! also contained in the set of hierarchic basis functions, so this branch could be

9297
             ! removed by making some code modifications (to do?).

9298
             !-----------------------------------------------------------------------------------------

9299
             i = EdgeMap(1,1)

9300
             j = EdgeMap(1,2)

9301
             EdgeBasis(1,1) = (v*(-1 + (2*v)/(2 - Sqrt(2.0d0)*w)))/4.0d0

9302
             EdgeBasis(1,2) = 0.0d0

9303
             EdgeBasis(1,3) = (u*v*(-Sqrt(2.0d0) + Sqrt(2.0d0)*v + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9304
             CurlBasis(1,1) = (u*(-Sqrt(2.0d0) + 2*Sqrt(2.0d0)*v + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9305
             CurlBasis(1,2) = (v*(Sqrt(2.0d0) - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9306
             CurlBasis(1,3) = (-2 + 4*v + Sqrt(2.0d0)*w)/(-8 + 4*Sqrt(2.0d0)*w)

9307
             IF(GIndexes(j)<GIndexes(i)) THEN

9308
               EdgeBasis(1,:) = -EdgeBasis(1,:)

9309
               CurlBasis(1,:) = -CurlBasis(1,:)

9310
             END IF

9311


9312
             i = EdgeMap(2,1)

9313
             j = EdgeMap(2,2)

9314
             EdgeBasis(2,1) = 0.0d0

9315
             EdgeBasis(2,2) = (u*(1 + (2*u)/(2 - Sqrt(2.0d0)*w)))/4.0d0

9316
             EdgeBasis(2,3) = (u*v*(Sqrt(2.0d0) + Sqrt(2.0d0)*u - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9317
             CurlBasis(2,1) = (u*(Sqrt(2.0d0) - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9318
             CurlBasis(2,2) = -(v*(Sqrt(2.0d0) + 2*Sqrt(2.0d0)*u - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9319
             CurlBasis(2,3) = (2 + 4*u - Sqrt(2.0d0)*w)/(8 - 4*Sqrt(2.0d0)*w)

9320
             IF(GIndexes(j)<GIndexes(i)) THEN

9321
               EdgeBasis(2,:) = -EdgeBasis(2,:)

9322
               CurlBasis(2,:) = -CurlBasis(2,:)

9323
             END IF

9324


9325
             i = EdgeMap(3,1)

9326
             j = EdgeMap(3,2)

9327
             EdgeBasis(3,1) = (v*(1 + (2*v)/(2 - Sqrt(2.0d0)*w)))/4.0d0

9328
             EdgeBasis(3,2) = 0.0d0

9329
             EdgeBasis(3,3) = (u*v*(Sqrt(2.0d0) + Sqrt(2.0d0)*v - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9330
             CurlBasis(3,1) = (u*(Sqrt(2.0d0) + 2*Sqrt(2.0d0)*v - w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9331
             CurlBasis(3,2) = (v*(-Sqrt(2.0d0) + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9332
             CurlBasis(3,3) = (2 + 4*v - Sqrt(2.0d0)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9333
             IF(GIndexes(j)<GIndexes(i)) THEN

9334
               EdgeBasis(3,:) = -EdgeBasis(3,:)

9335
               CurlBasis(3,:) = -CurlBasis(3,:)

9336
             END IF

9337


9338
             i = EdgeMap(4,1)

9339
             j = EdgeMap(4,2)

9340
             EdgeBasis(4,1) = 0.0d0

9341
             EdgeBasis(4,2) = (u*(-1 + (2*u)/(2 - Sqrt(2.0d0)*w)))/4.0d0

9342
             EdgeBasis(4,3) = (u*v*(-Sqrt(2.0d0) + Sqrt(2.0d0)*u + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9343
             CurlBasis(4,1) = (u*(-Sqrt(2.0d0) + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9344
             CurlBasis(4,2) = -(v*(-Sqrt(2.0d0) + 2*Sqrt(2.0d0)*u + w))/(2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9345
             CurlBasis(4,3) = (2 - 4*u - Sqrt(2.0d0)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9346
             IF(GIndexes(j)<GIndexes(i)) THEN

9347
               EdgeBasis(4,:) = -EdgeBasis(4,:)

9348
               CurlBasis(4,:) = -CurlBasis(4,:)

9349
             END IF

9350


9351
             i = EdgeMap(5,1)

9352
             j = EdgeMap(5,2)

9353
             EdgeBasis(5,1) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*v + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9354
             EdgeBasis(5,2) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*u + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9355
             EdgeBasis(5,3) = (u*(-2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - 2*w) + 4*w - Sqrt(2.0d0)*w**2) - &

9356
                 (-1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2))/(4.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9357
             CurlBasis(5,1) = (-2*Sqrt(2.0d0) + 2*u*(Sqrt(2.0d0) - w) + 4*w - Sqrt(2.0d0)*w**2)/ &

9358
                 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9359
             CurlBasis(5,2) = (2*Sqrt(2.0d0) - 2*Sqrt(2.0d0)*v - 4*w + 2*v*w + Sqrt(2.0d0)*w**2)/ &

9360
                 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9361
             CurlBasis(5,3) = 0.0d0

9362
             IF(GIndexes(j)<GIndexes(i)) THEN

9363
               EdgeBasis(5,:) = -EdgeBasis(5,:)

9364
               CurlBasis(5,:) = -CurlBasis(5,:)

9365
             END IF

9366


9367
             i = EdgeMap(6,1)

9368
             j = EdgeMap(6,2)

9369
             EdgeBasis(6,1) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*v + w))/(8.0d0 - 4*Sqrt(2.0d0)*w)

9370
             EdgeBasis(6,2) = (w*(-Sqrt(2.0d0) - Sqrt(2.0d0)*u + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9371
             EdgeBasis(6,3) = (-((-1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2)) + & 

9372
                 u*(2*Sqrt(2.0d0) - 2*Sqrt(2.0d0)*v - 4*w + 4*v*w + Sqrt(2.0d0)*w**2))/ &

9373
                 (4.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9374
             CurlBasis(6,1) = -(2*Sqrt(2.0d0) + 2*u*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ &

9375
                 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9376
             CurlBasis(6,2) = (-2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - w) + 4*w - Sqrt(2.0d0)*w**2)/ &

9377
                 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2) 

9378
             CurlBasis(6,3) = 0.0d0

9379
             IF(GIndexes(j)<GIndexes(i)) THEN

9380
               EdgeBasis(6,:) = -EdgeBasis(6,:)

9381
               CurlBasis(6,:) = -CurlBasis(6,:)

9382
             END IF

9383


9384
             i = EdgeMap(7,1)

9385
             j = EdgeMap(7,2)

9386
             EdgeBasis(7,1) = ((Sqrt(2.0d0) + Sqrt(2.0d0)*v - w)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9387
             EdgeBasis(7,2) = ((Sqrt(2.0d0) + Sqrt(2.0d0)*u - w)*w)/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9388
             EdgeBasis(7,3) = ((1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2) + &

9389
                 u*(2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - 2*w) - 4*w + Sqrt(2.0d0)*w**2))/ &

9390
                 (4.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9391
             CurlBasis(7,1) = (2*Sqrt(2.0d0) + 2*u*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ &

9392
                 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9393
             CurlBasis(7,2) = -(2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ &

9394
                 (2.0d0*(-2 + Sqrt(2.0d0)*w)**2)

9395
             CurlBasis(7,3) = 0.0d0

9396
             IF(GIndexes(j)<GIndexes(i)) THEN

9397
               EdgeBasis(7,:) = -EdgeBasis(7,:)

9398
               CurlBasis(7,:) = -CurlBasis(7,:)

9399
             END IF

9400


9401
             i = EdgeMap(8,1)

9402
             j = EdgeMap(8,2)

9403
             EdgeBasis(8,1) = (w*(-Sqrt(2.0d0) - Sqrt(2.0d0)*v + w))/(-8.0d0 + 4*Sqrt(2.0d0)*w)

9404
             EdgeBasis(8,2) = (w*(-Sqrt(2.0d0) + Sqrt(2.0d0)*u + w))/(8.0d0 - 4*Sqrt(2.0d0)*w)

9405
             EdgeBasis(8,3) = ((1 + v)*(2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2) - &

9406
                 u*(2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - 2*w) - 4*w + Sqrt(2.0d0)*w**2))/ &

9407
                 (4.0d0*(-2.0d0 + Sqrt(2.0d0)*w)**2)

9408
             CurlBasis(8,1) = (2*Sqrt(2.0d0) - 2*Sqrt(2.0d0)*u - 4*w + 2*u*w + Sqrt(2.0d0)*w**2)/ &

9409
                 (2.0d0*(-2.0d0 + Sqrt(2.0d0)*w)**2)

9410
             CurlBasis(8,2) = (2*Sqrt(2.0d0) + 2*v*(Sqrt(2.0d0) - w) - 4*w + Sqrt(2.0d0)*w**2)/ &

9411
                 (2.0d0*(-2.0d0 + Sqrt(2.0d0)*w)**2)

9412
             CurlBasis(8,3) = 0.0d0

9413
             IF(GIndexes(j)<GIndexes(i)) THEN

9414
               EdgeBasis(8,:) = -EdgeBasis(8,:)

9415
               CurlBasis(8,:) = -CurlBasis(8,:)

9416
             END IF

9417


9418
             ! ------------------------------------------------------------------

9419
             ! The last two basis functions are associated with the square face.

9420
             ! We first create the basis function in the default order without

9421
             ! sign reversions.

9422
             ! ------------------------------------------------------------------

9423
             SquareFaceMap(:) = (/ 1,2,3,4 /)

9424


9425
             WorkBasis(1,1) = (2.0d0 - 2*v**2 - 2*Sqrt(2.0d0)*w + w**2)/(4.0d0 - 2*Sqrt(2.0d0)*w)

9426
             WorkBasis(1,2) = 0.0d0

9427
             WorkBasis(1,3) = (u*(1.0d0 - (4*v**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2))/(2.0d0*Sqrt(2.0d0))

9428
             WorkCurlBasis(1,1) = (-2*Sqrt(2.0d0)*u*v)/(-2.0d0 + Sqrt(2.0d0)*w)**2

9429
             WorkCurlBasis(1,2) = (-2*Sqrt(2.0d0) + 4*w - Sqrt(2.0d0)*w**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2

9430
             WorkCurlBasis(1,3) = (2.0d0*v)/(2.0d0 - Sqrt(2.0d0)*w)

9431


9432
             WorkBasis(2,1) = 0.0d0

9433
             WorkBasis(2,2) = (2.0d0 - 2*u**2 - 2*Sqrt(2.0d0)*w + w**2)/(4.0d0 - 2*Sqrt(2.0d0)*w)

9434
             WorkBasis(2,3) = (v*(1.0d0 - (4*u**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2))/(2.0d0*Sqrt(2.0d0))

9435
             WorkCurlBasis(2,1) = (2*Sqrt(2.0d0) - 4*w + Sqrt(2.0d0)*w**2)/(-2.0d0 + Sqrt(2.0d0)*w)**2

9436
             WorkCurlBasis(2,2) = (2*Sqrt(2.0d0)*u*v)/(-2.0d0 + Sqrt(2.0d0)*w)**2

9437
             WorkCurlBasis(2,3) = (2*u)/(-2.0d0 + Sqrt(2.0d0)*w)

9438


9439
             ! -------------------------------------------------------------------

9440
             ! Finally apply an order change and sign reversions if needed. 

9441
             ! -------------------------------------------------------------------

9442
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

9443
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9444


9445
             EdgeBasis(9,:) = D1 * WorkBasis(I1,:)

9446
             CurlBasis(9,:) = D1 * WorkCurlBasis(I1,:)

9447
             EdgeBasis(10,:) = D2 * WorkBasis(I2,:)

9448
             CurlBasis(10,:) = D2 * WorkCurlBasis(I2,:)          

9449
           END IF

9450


9451
         CASE(7)

9452
           !--------------------------------------------------------------

9453
           ! This branch is for handling prismatic (or wedge) elements

9454
           !--------------------------------------------------------------           

9455
           EdgeMap => GetEdgeMap(7)

9456


9457
           IF (SecondOrder) THEN

9458
             !---------------------------------------------------------------

9459
             ! The second-order element from the Nedelec's first family 

9460
             ! (note that the lowest-order prism element is from a different 

9461
             ! family). This element may not be optimally accurate if 

9462
             ! the physical element is not affine.

9463
             !--------------------------------------------------------------             

9464
             h1 = 0.5d0 * (1-w)

9465
             dh1 = -0.5d0

9466
             h2 = 0.5d0 * (1+w)

9467
             dh2 = 0.5d0

9468
             h3 = h1 * h2

9469
             dh3 = -0.5d0 * w

9470


9471
             ! ---------------------------------------------------------

9472
             ! The first and fourth edges ...

9473
             !--------------------------------------------------------

9474
             ! The corresponding basis functions for the triangle:

9475
             !--------------------------------------------------------

9476
             WorkBasis(1,1) = (3.0d0 - Sqrt(3.0d0)*v)/6.0d0

9477
             WorkBasis(1,2) = u/(2.0d0*Sqrt(3.0d0))

9478
             WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0)

9479
             WorkBasis(2,1) = -(u*(-3.0d0 + Sqrt(3.0d0)*v))/2.0d0

9480
             WorkBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0

9481
             WorkCurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0

9482


9483
             i = EdgeMap(1,1)

9484
             j = EdgeMap(1,2)

9485
             EdgeBasis(1,1:2) = WorkBasis(1,1:2) * h1

9486
             CurlBasis(1,1) = -WorkBasis(1,2) * dh1

9487
             CurlBasis(1,2) = WorkBasis(1,1) * dh1

9488
             CurlBasis(1,3) = WorkCurlBasis(1,3) * h1

9489
             EdgeBasis(2,1:2) = WorkBasis(2,1:2) * h1

9490
             CurlBasis(2,1) = -WorkBasis(2,2) * dh1

9491
             CurlBasis(2,2) = WorkBasis(2,1) * dh1

9492
             CurlBasis(2,3) = WorkCurlBasis(2,3) * h1

9493
             IF(GIndexes(j)<GIndexes(i)) THEN

9494
               EdgeBasis(1,1:2) = -EdgeBasis(1,1:2)

9495
               CurlBasis(1,1:3) = -CurlBasis(1,1:3)

9496
             END IF

9497


9498
             i = EdgeMap(4,1)

9499
             j = EdgeMap(4,2)

9500
             EdgeBasis(7,1:2) = WorkBasis(1,1:2) * h2

9501
             CurlBasis(7,1) = -WorkBasis(1,2) * dh2

9502
             CurlBasis(7,2) = WorkBasis(1,1) * dh2

9503
             CurlBasis(7,3) = WorkCurlBasis(1,3) * h2

9504
             EdgeBasis(8,1:2) = WorkBasis(2,1:2) * h2

9505
             CurlBasis(8,1) = -WorkBasis(2,2) * dh2

9506
             CurlBasis(8,2) = WorkBasis(2,1) * dh2

9507
             CurlBasis(8,3) = WorkCurlBasis(2,3) * h2

9508
             IF(GIndexes(j)<GIndexes(i)) THEN

9509
               EdgeBasis(7,1:2) = -EdgeBasis(7,1:2)

9510
               CurlBasis(7,1:3) = -CurlBasis(7,1:3)

9511
             END IF

9512


9513
             ! ---------------------------------------------------------

9514
             ! The second and fifth edges ...

9515
             !--------------------------------------------------------

9516
             ! The corresponding basis functions for the triangle:

9517
             !--------------------------------------------------------

9518
             WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0))

9519
             WorkBasis(1,2) = (1 + u)/(2.0d0*Sqrt(3.0d0))

9520
             WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0)

9521
             WorkBasis(2,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*v)/4.0d0

9522
             WorkBasis(2,2) = (Sqrt(3.0d0)*(1.0d0 + u)*(-1.0d0 - u + Sqrt(3.0d0)*v))/4.0d0

9523
             WorkCurlBasis(2,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0

9524


9525
             i = EdgeMap(2,1)

9526
             j = EdgeMap(2,2)

9527
             EdgeBasis(3,1:2) = WorkBasis(1,1:2) * h1

9528
             CurlBasis(3,1) = -WorkBasis(1,2) * dh1

9529
             CurlBasis(3,2) = WorkBasis(1,1) * dh1

9530
             CurlBasis(3,3) = WorkCurlBasis(1,3) * h1

9531
             EdgeBasis(4,1:2) = WorkBasis(2,1:2) * h1

9532
             CurlBasis(4,1) = -WorkBasis(2,2) * dh1

9533
             CurlBasis(4,2) = WorkBasis(2,1) * dh1

9534
             CurlBasis(4,3) = WorkCurlBasis(2,3) * h1

9535
             IF(GIndexes(j)<GIndexes(i)) THEN

9536
               EdgeBasis(3,1:2) = -EdgeBasis(3,1:2)

9537
               CurlBasis(3,1:3) = -CurlBasis(3,1:3)

9538
             END IF

9539


9540
             i = EdgeMap(5,1)

9541
             j = EdgeMap(5,2)

9542
             EdgeBasis(9,1:2) = WorkBasis(1,1:2) * h2

9543
             CurlBasis(9,1) = -WorkBasis(1,2) * dh2

9544
             CurlBasis(9,2) = WorkBasis(1,1) * dh2

9545
             CurlBasis(9,3) = WorkCurlBasis(1,3) * h2

9546
             EdgeBasis(10,1:2) = WorkBasis(2,1:2) * h2

9547
             CurlBasis(10,1) = -WorkBasis(2,2) * dh2

9548
             CurlBasis(10,2) = WorkBasis(2,1) * dh2

9549
             CurlBasis(10,3) = WorkCurlBasis(2,3) * h2

9550
             IF(GIndexes(j)<GIndexes(i)) THEN

9551
               EdgeBasis(9,1:2) = -EdgeBasis(9,1:2)

9552
               CurlBasis(9,1:3) = -CurlBasis(9,1:3)

9553
             END IF

9554


9555
             ! ---------------------------------------------------------

9556
             ! The third and sixth edges ...

9557
             !--------------------------------------------------------

9558
             ! The corresponding basis functions for the triangle:

9559
             !--------------------------------------------------------

9560
             WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0))

9561
             WorkBasis(1,2) = (-1 + u)/(2.0d0*Sqrt(3.0d0))

9562
             WorkCurlBasis(1,3) =  1.0d0/Sqrt(3.0d0)

9563
             WorkBasis(2,1) = (v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0

9564
             WorkBasis(2,2) = -(Sqrt(3.0d0)*(-1.0d0 + u)*(-1.0d0 + u + Sqrt(3.0d0)*v))/4.0d0

9565
             WorkCurlBasis(2,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0

9566


9567
             i = EdgeMap(3,1)

9568
             j = EdgeMap(3,2)

9569
             EdgeBasis(5,1:2) = WorkBasis(1,1:2) * h1

9570
             CurlBasis(5,1) = -WorkBasis(1,2) * dh1

9571
             CurlBasis(5,2) = WorkBasis(1,1) * dh1

9572
             CurlBasis(5,3) = WorkCurlBasis(1,3) * h1

9573
             EdgeBasis(6,1:2) = WorkBasis(2,1:2) * h1

9574
             CurlBasis(6,1) = -WorkBasis(2,2) * dh1

9575
             CurlBasis(6,2) = WorkBasis(2,1) * dh1

9576
             CurlBasis(6,3) = WorkCurlBasis(2,3) * h1

9577
             IF(GIndexes(j)<GIndexes(i)) THEN

9578
               EdgeBasis(5,1:2) = -EdgeBasis(5,1:2)

9579
               CurlBasis(5,1:3) = -CurlBasis(5,1:3)

9580
             END IF

9581


9582
             i = EdgeMap(6,1)

9583
             j = EdgeMap(6,2)

9584
             EdgeBasis(11,1:2) = WorkBasis(1,1:2) * h2

9585
             CurlBasis(11,1) = -WorkBasis(1,2) * dh2

9586
             CurlBasis(11,2) = WorkBasis(1,1) * dh2

9587
             CurlBasis(11,3) = WorkCurlBasis(1,3) * h2

9588
             EdgeBasis(12,1:2) = WorkBasis(2,1:2) * h2

9589
             CurlBasis(12,1) = -WorkBasis(2,2) * dh2

9590
             CurlBasis(12,2) = WorkBasis(2,1) * dh2

9591
             CurlBasis(12,3) = WorkCurlBasis(2,3) * h2

9592
             IF(GIndexes(j)<GIndexes(i)) THEN

9593
               EdgeBasis(11,1:2) = -EdgeBasis(11,1:2)

9594
               CurlBasis(11,1:3) = -CurlBasis(11,1:3)

9595
             END IF

9596


9597
             ! -------------------------------------------------------

9598
             ! The edges 14, 25 and 36

9599
             !--------------------------------------------------------

9600
             DO q = 1,3

9601
               i = EdgeMap(6+q,1)

9602
               j = EdgeMap(6+q,2)

9603
               grad(1:2) = dTriangleNodalPBasis(q, u, v)

9604
               EdgeBasis(12+(q-1)*2+1,3) = 0.5d0 * TriangleNodalPBasis(q, u, v)

9605
               CurlBasis(12+(q-1)*2+1,1) = 0.5d0* grad(2)

9606
               CurlBasis(12+(q-1)*2+1,2) = -0.5d0* grad(1)

9607
               EdgeBasis(12+(q-1)*2+2,3) = 3.0d0 * EdgeBasis(12+(q-1)*2+1,3) * w

9608
               CurlBasis(12+(q-1)*2+2,1) = 1.5d0 * grad(2) * w

9609
               CurlBasis(12+(q-1)*2+2,2) = -1.5d0 * grad(1) * w

9610


9611
               IF(GIndexes(j)<GIndexes(i)) THEN

9612
                 EdgeBasis(12+(q-1)*2+1,3) = -EdgeBasis(12+(q-1)*2+1,3)

9613
                 CurlBasis(12+(q-1)*2+1,1:2) = -CurlBasis(12+(q-1)*2+1,1:2)

9614
               END IF

9615
             END DO

9616


9617
             !-------------------------------------------------

9618
             ! Two basis functions defined on the face 123:

9619
             !-------------------------------------------------

9620
             TriangleFaceMap(:) = (/ 1,2,3 /)

9621
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

9622
             CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9623


9624
             WorkBasis(1,1) = ((Sqrt(3.0d0) - v)*v)/6.0d0

9625
             WorkBasis(1,2) = (u*v)/6.0d0

9626
             WorkCurlBasis(1,3) = (-Sqrt(3.0d0) + 3.0d0*v)/6.0d0

9627
             WorkBasis(2,1) = (v*(1.0d0 + u - v/Sqrt(3.0d0)))/(4.0d0*Sqrt(3.0d0))

9628
             WorkBasis(2,2) = ((-1.0d0 + u)*(-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0))

9629
             WorkCurlBasis(2,3) =(-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0

9630
             WorkBasis(3,1) = (v*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0))

9631
             WorkBasis(3,2) = -((1.0d0 + u)*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0))

9632
             WorkCurlBasis(3,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0

9633


9634
             IF (RedefineFaceBasis) THEN

9635
               EdgeBasis(19,1:2) = (D1 * WorkBasis(I1,1:2) + D2 * WorkBasis(I2,1:2)) * 0.5d0 * h1

9636
               EdgeBasis(20,1:2) = (-D1 * WorkBasis(I1,1:2) + D2 * WorkBasis(I2,1:2)) * 0.5d0 * h1

9637


9638
               CurlBasis(19,1) = -(D1 * WorkBasis(I1,2) + D2 * WorkBasis(I2,2)) * 0.5d0 * dh1

9639
               CurlBasis(19,2) = (D1 * WorkBasis(I1,1) + D2 * WorkBasis(I2,1)) * 0.5d0 * dh1

9640
               CurlBasis(19,3) = (D1 * WorkCurlBasis(I1,3) + D2 * WorkCurlBasis(I2,3)) * 0.5d0 * h1

9641


9642
               CurlBasis(20,1) = -(-D1 * WorkBasis(I1,2) + D2 * WorkBasis(I2,2)) * 0.5d0 * dh1

9643
               CurlBasis(20,2) = (-D1 * WorkBasis(I1,1) + D2 * WorkBasis(I2,1)) * 0.5d0 * dh1

9644
               CurlBasis(20,3) = (-D1 * WorkCurlBasis(I1,3) + D2 * WorkCurlBasis(I2,3)) * 0.5d0 * h1

9645
               

9646
             ELSE

9647
               EdgeBasis(19,1:2) = D1 * WorkBasis(I1,1:2) * h1

9648
               CurlBasis(19,1) = -D1 * WorkBasis(I1,2) * dh1

9649
               CurlBasis(19,2) = D1 * WorkBasis(I1,1) * dh1

9650
               CurlBasis(19,3) = D1 * WorkCurlBasis(I1,3) * h1

9651


9652
               EdgeBasis(20,1:2) = D2 * WorkBasis(I2,1:2) * h1

9653
               CurlBasis(20,1) = -D2 * WorkBasis(I2,2) * dh1

9654
               CurlBasis(20,2) = D2 * WorkBasis(I2,1) * dh1

9655
               CurlBasis(20,3) = D2 * WorkCurlBasis(I2,3) * h1

9656
             END IF

9657
               

9658
             !-------------------------------------------------

9659
             ! Two basis functions defined on the face 456:

9660
             !-------------------------------------------------

9661
             TriangleFaceMap(:) = (/ 4,5,6 /)

9662
             FaceIndices(1:3) = GIndexes(TriangleFaceMap(1:3))

9663
             CALL TriangleFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9664


9665
             IF (RedefineFaceBasis) THEN

9666
               EdgeBasis(21,1:2) = (D1 * WorkBasis(I1,1:2) + D2 * WorkBasis(I2,1:2)) * 0.5d0 * h2

9667
               EdgeBasis(22,1:2) = (-D1 * WorkBasis(I1,1:2) + D2 * WorkBasis(I2,1:2)) * 0.5d0 * h2

9668


9669
               CurlBasis(21,1) = -(D1 * WorkBasis(I1,2) + D2 * WorkBasis(I2,2)) * 0.5d0 * dh2

9670
               CurlBasis(21,2) = (D1 * WorkBasis(I1,1) + D2 * WorkBasis(I2,1)) * 0.5d0 * dh2

9671
               CurlBasis(21,3) = (D1 * WorkCurlBasis(I1,3) + D2 * WorkCurlBasis(I2,3)) * 0.5d0 * h2

9672


9673
               CurlBasis(22,1) = -(-D1 * WorkBasis(I1,2) + D2 * WorkBasis(I2,2)) * 0.5d0 * dh2

9674
               CurlBasis(22,2) = (-D1 * WorkBasis(I1,1) + D2 * WorkBasis(I2,1)) * 0.5d0 * dh2

9675
               CurlBasis(22,3) = (-D1 * WorkCurlBasis(I1,3) + D2 * WorkCurlBasis(I2,3)) * 0.5d0 * h2

9676
               

9677
             ELSE

9678
               EdgeBasis(21,1:2) = D1 * WorkBasis(I1,1:2) * h2

9679
               CurlBasis(21,1) = -D1 * WorkBasis(I1,2) * dh2

9680
               CurlBasis(21,2) = D1 * WorkBasis(I1,1) * dh2

9681
               CurlBasis(21,3) = D1 * WorkCurlBasis(I1,3) * h2

9682


9683
               EdgeBasis(22,1:2) = D2 * WorkBasis(I2,1:2) * h2

9684
               CurlBasis(22,1) = -D2 * WorkBasis(I2,2) * dh2

9685
               CurlBasis(22,2) = D2 * WorkBasis(I2,1) * dh2

9686
               CurlBasis(22,3) = D2 * WorkCurlBasis(I2,3) * h2

9687
             END IF

9688


9689
             ! scale to reduce ill-conditioning:

9690
             IF (ScaleFaceBasis) THEN

9691
               EdgeBasis(19:21:2,:) = sqrt(fs1) * EdgeBasis(19:21:2,:)

9692
               CurlBasis(19:21:2,:) = sqrt(fs1) * CurlBasis(19:21:2,:)

9693
               EdgeBasis(20:22:2,:) = sqrt(fs2) * EdgeBasis(20:22:2,:)

9694
               CurlBasis(20:22:2,:) = sqrt(fs2) * CurlBasis(20:22:2,:)

9695
             END IF

9696
               

9697
             !-------------------------------------------------

9698
             ! Four basis functions defined on the face 1254:

9699
             !-------------------------------------------------              

9700
             SquareFaceMap(:) = (/ 1,2,5,4 /)          

9701
             WorkBasis = 0.0d0

9702
             WorkCurlBasis = 0.0d0

9703


9704
             WorkBasis(1,1) = (3.0d0 - Sqrt(3.0d0)*v)/6.0d0 * 4.0d0 * h3

9705
             WorkBasis(1,2) = u/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3

9706
             WorkCurlBasis(1,1) = -WorkBasis(1,2)/h3 * dh3 

9707
             WorkCurlBasis(1,2) = WorkBasis(1,1)/h3 * dh3 

9708
             WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) * 4.0d0 * h3

9709
             WorkBasis(2,1) = -(u*(-3.0d0 + Sqrt(3.0d0)*v))/2.0d0 * 4.0d0 * h3

9710
             WorkBasis(2,2) = (Sqrt(3.0d0)*u**2)/2.0d0 * 4.0d0 * h3

9711
             WorkCurlBasis(2,1) = -WorkBasis(2,2)/h3 * dh3 

9712
             WorkCurlBasis(2,2) = WorkBasis(2,1)/h3 * dh3

9713
             WorkCurlBasis(2,3) = (3.0d0*Sqrt(3.0d0)*u)/2.0d0 * 4.0d0 * h3

9714


9715
             WorkBasis(3,3) = 2.0d0 * TriangleNodalPBasis(1, u, v) * TriangleNodalPBasis(2, u, v)

9716
             grad(1:2) = dTriangleNodalPBasis(1, u, v) * TriangleNodalPBasis(2, u, v) + &

9717
                 TriangleNodalPBasis(1, u, v) * dTriangleNodalPBasis(2, u, v)

9718
             WorkCurlBasis(3,1) = 2.0d0 * grad(2)

9719
             WorkCurlBasis(3,2) = -2.0d0 * grad(1)

9720
             WorkBasis(4,3) = 3.0d0 * WorkBasis(3,3) * w

9721
             WorkCurlBasis(4,1) = 6.0d0 * grad(2) * w

9722
             WorkCurlBasis(4,2) = -6.0d0 * grad(1) * w

9723


9724
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

9725
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9726


9727
             EdgeBasis(23,:) = D1 * WorkBasis(2*(I1-1)+1,:)

9728
             CurlBasis(23,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

9729
             EdgeBasis(24,:) = WorkBasis(2*(I1-1)+2,:)

9730
             CurlBasis(24,:) = WorkCurlBasis(2*(I1-1)+2,:)

9731
             EdgeBasis(25,:) = D2 * WorkBasis(2*(I2-1)+1,:)

9732
             CurlBasis(25,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

9733
             EdgeBasis(26,:) = WorkBasis(2*(I2-1)+2,:)

9734
             CurlBasis(26,:) = WorkCurlBasis(2*(I2-1)+2,:)            

9735


9736
             !-------------------------------------------------

9737
             ! Four basis functions defined on the face 2365:

9738
             !-------------------------------------------------              

9739
             SquareFaceMap(:) = (/ 2,3,6,5 /)          

9740
             WorkBasis = 0.0d0

9741
             WorkCurlBasis = 0.0d0

9742


9743
             WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3

9744
             WorkBasis(1,2) = (1 + u)/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3

9745
             WorkCurlBasis(1,1) = -WorkBasis(1,2)/h3 * dh3 

9746
             WorkCurlBasis(1,2) = WorkBasis(1,1)/h3 * dh3 

9747
             WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) * 4.0d0 * h3

9748
             WorkBasis(2,1) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v)*v)/4.0d0 * 4.0d0 * h3

9749
             WorkBasis(2,2) = (Sqrt(3.0d0)*(1.0d0 + u)*(-1.0d0 - u + Sqrt(3.0d0)*v))/4.0d0 * 4.0d0 * h3

9750
             WorkCurlBasis(2,1) = -WorkBasis(2,2)/h3 * dh3 

9751
             WorkCurlBasis(2,2) = WorkBasis(2,1)/h3 * dh3

9752
             WorkCurlBasis(2,3) = (-3.0d0*(Sqrt(3.0d0) + Sqrt(3.0d0)*u - 3.0d0*v))/4.0d0 * 4.0d0 * h3

9753


9754
             WorkBasis(3,3) = 2.0d0 * TriangleNodalPBasis(2, u, v) * TriangleNodalPBasis(3, u, v)

9755
             grad(1:2) = dTriangleNodalPBasis(2, u, v) * TriangleNodalPBasis(3, u, v) + &

9756
                 TriangleNodalPBasis(2, u, v) * dTriangleNodalPBasis(3, u, v)

9757
             WorkCurlBasis(3,1) = 2.0d0 * grad(2)

9758
             WorkCurlBasis(3,2) = -2.0d0 * grad(1)

9759
             WorkBasis(4,3) = 3.0d0 * WorkBasis(3,3) * w

9760
             WorkCurlBasis(4,1) = 6.0d0 * grad(2) * w

9761
             WorkCurlBasis(4,2) = -6.0d0 * grad(1) * w

9762


9763
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

9764
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9765


9766
             EdgeBasis(27,:) = D1 * WorkBasis(2*(I1-1)+1,:)

9767
             CurlBasis(27,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

9768
             EdgeBasis(28,:) = WorkBasis(2*(I1-1)+2,:)

9769
             CurlBasis(28,:) = WorkCurlBasis(2*(I1-1)+2,:)

9770
             EdgeBasis(29,:) = D2 * WorkBasis(2*(I2-1)+1,:)

9771
             CurlBasis(29,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

9772
             EdgeBasis(30,:) = WorkBasis(2*(I2-1)+2,:)

9773
             CurlBasis(30,:) = WorkCurlBasis(2*(I2-1)+2,:)  

9774


9775
             !-------------------------------------------------

9776
             ! Four basis functions defined on the face 3146:

9777
             !-------------------------------------------------              

9778
             SquareFaceMap(:) = (/ 3,1,4,6 /)          

9779
             WorkBasis = 0.0d0

9780
             WorkCurlBasis = 0.0d0

9781


9782
             WorkBasis(1,1) = -v/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3

9783
             WorkBasis(1,2) = (-1 + u)/(2.0d0*Sqrt(3.0d0)) * 4.0d0 * h3

9784
             WorkCurlBasis(1,1) = -WorkBasis(1,2)/h3 * dh3 

9785
             WorkCurlBasis(1,2) = WorkBasis(1,1)/h3 * dh3 

9786
             WorkCurlBasis(1,3) = 1.0d0/Sqrt(3.0d0) * 4.0d0 * h3

9787
             WorkBasis(2,1) = (v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 * 4.0d0 * h3

9788
             WorkBasis(2,2) =  -(Sqrt(3.0d0)*(-1.0d0 + u)*(-1.0d0 + u + Sqrt(3.0d0)*v))/4.0d0 * 4.0d0 * h3

9789
             WorkCurlBasis(2,1) = -WorkBasis(2,2)/h3 * dh3 

9790
             WorkCurlBasis(2,2) = WorkBasis(2,1)/h3 * dh3

9791
             WorkCurlBasis(2,3) = (-3.0d0*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + 3.0d0*v))/4.0d0 * 4.0d0 * h3

9792


9793
             WorkBasis(3,3) = 2.0d0 * TriangleNodalPBasis(3, u, v) * TriangleNodalPBasis(1, u, v)

9794
             grad(1:2) = dTriangleNodalPBasis(3, u, v) * TriangleNodalPBasis(1, u, v) + &

9795
                 TriangleNodalPBasis(3, u, v) * dTriangleNodalPBasis(1, u, v)

9796
             WorkCurlBasis(3,1) = 2.0d0 * grad(2)

9797
             WorkCurlBasis(3,2) = -2.0d0 * grad(1)

9798
             WorkBasis(4,3) = 3.0d0 * WorkBasis(3,3) * w

9799
             WorkCurlBasis(4,1) = 6.0d0 * grad(2) * w

9800
             WorkCurlBasis(4,2) = -6.0d0 * grad(1) * w

9801


9802
             FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

9803
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9804


9805
             EdgeBasis(31,:) = D1 * WorkBasis(2*(I1-1)+1,:)

9806
             CurlBasis(31,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

9807
             EdgeBasis(32,:) = WorkBasis(2*(I1-1)+2,:)

9808
             CurlBasis(32,:) = WorkCurlBasis(2*(I1-1)+2,:)

9809
             EdgeBasis(33,:) = D2 * WorkBasis(2*(I2-1)+1,:)

9810
             CurlBasis(33,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

9811
             EdgeBasis(34,:) = WorkBasis(2*(I2-1)+2,:)

9812
             CurlBasis(34,:) = WorkCurlBasis(2*(I2-1)+2,:)  

9813


9814
             !-------------------------------------------------

9815
             ! Two basis functions associated with the interior

9816
             !-------------------------------------------------    

9817
             EdgeBasis(35,1) = (v*(1.0d0 + u - v/Sqrt(3.0d0)))/(4.0d0*Sqrt(3.0d0)) * h3

9818
             EdgeBasis(35,2) = ((-1.0d0 + u)*(-3.0d0 - 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) * h3

9819
             CurlBasis(35,1) = -EdgeBasis(35,2)/h3 * dh3

9820
             CurlBasis(35,2) = EdgeBasis(35,1)/h3 * dh3

9821
             CurlBasis(35,3) = (-Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u + 3.0d0*v)/12.0d0 * h3

9822


9823
             EdgeBasis(36,1) = (v*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) * h3

9824
             EdgeBasis(36,2) = -((1.0d0 + u)*(-3.0d0 + 3.0d0*u + Sqrt(3.0d0)*v))/(12.0d0*Sqrt(3.0d0)) * h3

9825
             CurlBasis(36,1) = -EdgeBasis(36,2)/h3 * dh3

9826
             CurlBasis(36,2) = EdgeBasis(36,1)/h3 * dh3

9827
             CurlBasis(36,3) = (Sqrt(3.0d0) - 3.0d0*Sqrt(3.0d0)*u - 3.0d0*v)/12.0d0 * h3

9828


9829
             IF (ScaleFaceBasis) THEN

9830
               EdgeBasis(35:36,1:2) = sqrt(150.0d0) * EdgeBasis(35:36,1:2)

9831
               CurlBasis(35:36,1:3) = sqrt(150.0d0) * CurlBasis(35:36,1:3)

9832
             END IF

9833
             

9834
           ELSE

9835
             !--------------------------------------------------------------

9836
             ! The lowest-order element from the optimal family. The optimal

9837
             ! accuracy is obtained also for non-affine meshes.

9838
             ! -------------------------------------------------------------

9839
             ! First nine basis functions associated with the edges

9840
             ! -------------------------------------------------------------

9841
             i = EdgeMap(1,1)

9842
             j = EdgeMap(1,2)

9843
             EdgeBasis(1,1) = -((-3.0d0 + Sqrt(3.0d0)*v)*(-1.0d0 + w)*w)/12.0d0

9844
             EdgeBasis(1,2) = (u*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0))

9845
             EdgeBasis(1,3) = 0.0d0

9846
             CurlBasis(1,1) = (u*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9847
             CurlBasis(1,2) = -((-3.0d0 + Sqrt(3.0d0)*v)*(-1.0d0 + 2*w))/12.0d0

9848
             CurlBasis(1,3) = ((-1.0d0 + w)*w)/(2.0d0*Sqrt(3.0d0))

9849
             IF(GIndexes(j)<GIndexes(i)) THEN

9850
               EdgeBasis(1,:) = -EdgeBasis(1,:)

9851
               CurlBasis(1,:) = -CurlBasis(1,:)

9852
             END IF

9853


9854
             i = EdgeMap(2,1)

9855
             j = EdgeMap(2,2)

9856
             EdgeBasis(2,1) = -(v*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0))

9857
             EdgeBasis(2,2) = ((1.0d0 + u)*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0)) 

9858
             EdgeBasis(2,3) = 0.0d0

9859
             CurlBasis(2,1) = ((1.0d0 + u)*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9860
             CurlBasis(2,2) = (v*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9861
             CurlBasis(2,3) = ((-1.0d0 + w)*w)/(2.0d0*Sqrt(3.0d0))

9862
             IF(GIndexes(j)<GIndexes(i)) THEN

9863
               EdgeBasis(2,:) = -EdgeBasis(2,:)

9864
               CurlBasis(2,:) = -CurlBasis(2,:)

9865
             END IF

9866


9867
             i = EdgeMap(3,1)

9868
             j = EdgeMap(3,2)

9869
             EdgeBasis(3,1) = -(v*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0))

9870
             EdgeBasis(3,2) = ((-1.0d0 + u)*(-1.0d0 + w)*w)/(4.0d0*Sqrt(3.0d0))

9871
             EdgeBasis(3,3) = 0.0d0

9872
             CurlBasis(3,1) = ((-1.0d0 + u)*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9873
             CurlBasis(3,2) = (v*(1.0d0 - 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9874
             CurlBasis(3,3) = ((-1.0d0 + w)*w)/(2.0d0*Sqrt(3.0d0))

9875
             IF(GIndexes(j)<GIndexes(i)) THEN

9876
               EdgeBasis(3,:) = -EdgeBasis(3,:)

9877
               CurlBasis(3,:) = -CurlBasis(3,:)

9878
             END IF

9879


9880
             i = EdgeMap(4,1)

9881
             j = EdgeMap(4,2)

9882
             EdgeBasis(4,1) = -((-3.0d0 + Sqrt(3.0d0)*v)*w*(1.0d0 + w))/12.0d0

9883
             EdgeBasis(4,2) = (u*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0))

9884
             EdgeBasis(4,3) = 0.0d0

9885
             CurlBasis(4,1) = -(u*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9886
             CurlBasis(4,2) = -((-3.0d0 + Sqrt(3.0d0)*v)*(1.0d0 + 2.0d0*w))/12.0d0

9887
             CurlBasis(4,3) = (w*(1.0d0 + w))/(2.0d0*Sqrt(3.0d0))

9888
             IF(GIndexes(j)<GIndexes(i)) THEN

9889
               EdgeBasis(4,:) = -EdgeBasis(4,:)

9890
               CurlBasis(4,:) = -CurlBasis(4,:)

9891
             END IF

9892


9893
             i = EdgeMap(5,1)

9894
             j = EdgeMap(5,2)

9895
             EdgeBasis(5,1) = -(v*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0))

9896
             EdgeBasis(5,2) = ((1.0d0 + u)*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0))

9897
             EdgeBasis(5,3) = 0.0d0

9898
             CurlBasis(5,1) = -((1.0d0 + u)*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9899
             CurlBasis(5,2) = -(v*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9900
             CurlBasis(5,3) = (w*(1.0d0 + w))/(2.0d0*Sqrt(3.0d0))

9901
             IF(GIndexes(j)<GIndexes(i)) THEN

9902
               EdgeBasis(5,:) = -EdgeBasis(5,:)

9903
               CurlBasis(5,:) = -CurlBasis(5,:)

9904
             END IF

9905


9906
             i = EdgeMap(6,1)

9907
             j = EdgeMap(6,2)

9908
             EdgeBasis(6,1) = -(v*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0))

9909
             EdgeBasis(6,2) = ((-1.0d0 + u)*w*(1.0d0 + w))/(4.0d0*Sqrt(3.0d0))

9910
             EdgeBasis(6,3) = 0.0d0

9911
             CurlBasis(6,1) = -((-1.0d0 + u)*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9912
             CurlBasis(6,2) = -(v*(1.0d0 + 2.0d0*w))/(4.0d0*Sqrt(3.0d0))

9913
             CurlBasis(6,3) = (w*(1.0d0 + w))/(2.0d0*Sqrt(3.0d0))

9914
             IF(GIndexes(j)<GIndexes(i)) THEN

9915
               EdgeBasis(6,:) = -EdgeBasis(6,:)

9916
               CurlBasis(6,:) = -CurlBasis(6,:)

9917
             END IF

9918


9919
             i = EdgeMap(7,1)

9920
             j = EdgeMap(7,2)

9921
             EdgeBasis(7,1) = 0.0d0

9922
             EdgeBasis(7,2) = 0.0d0

9923
             EdgeBasis(7,3) = (3*u**2 + v*(-Sqrt(3.0d0) + v) + u*(-3.0d0 + 2*Sqrt(3.0d0)*v))/12.0d0

9924
             CurlBasis(7,1) = (-Sqrt(3.0d0) + 2*Sqrt(3.0d0)*u + 2*v)/12.0d0

9925
             CurlBasis(7,2) = (3.0d0 - 6*u - 2*Sqrt(3.0d0)*v)/12.0d0

9926
             CurlBasis(7,3) = 0.0d0

9927
             IF(GIndexes(j)<GIndexes(i)) THEN

9928
               EdgeBasis(7,:) = -EdgeBasis(7,:)

9929
               CurlBasis(7,:) = -CurlBasis(7,:)

9930
             END IF

9931


9932
             i = EdgeMap(8,1)

9933
             j = EdgeMap(8,2)

9934
             EdgeBasis(8,1) = 0.0d0

9935
             EdgeBasis(8,2) = 0.0d0

9936
             EdgeBasis(8,3) = (3*u**2 + v*(-Sqrt(3.0d0) + v) + u*(3.0d0 - 2*Sqrt(3.0d0)*v))/12.0d0

9937
             CurlBasis(8,1) = (-Sqrt(3.0d0) - 2*Sqrt(3.0d0)*u + 2*v)/12.0d0

9938
             CurlBasis(8,2) = (-3.0d0 - 6*u + 2*Sqrt(3.0d0)*v)/12.0d0 

9939
             CurlBasis(8,3) = 0.0d0

9940
             IF(GIndexes(j)<GIndexes(i)) THEN

9941
               EdgeBasis(8,:) = -EdgeBasis(8,:)

9942
               CurlBasis(8,:) = -CurlBasis(8,:)

9943
             END IF

9944


9945
             i = EdgeMap(9,1)

9946
             j = EdgeMap(9,2)

9947
             EdgeBasis(9,1) = 0.0d0

9948
             EdgeBasis(9,2) = 0.0d0

9949
             EdgeBasis(9,3) = (v*(-Sqrt(3.0d0) + 2*v))/6.0d0

9950
             CurlBasis(9,1) = (-Sqrt(3.0d0) + 4*v)/6.0d0

9951
             CurlBasis(9,2) = 0.0d0

9952
             CurlBasis(9,3) = 0.0d0

9953
             IF(GIndexes(j)<GIndexes(i)) THEN

9954
               EdgeBasis(9,:) = -EdgeBasis(9,:)

9955
               CurlBasis(9,:) = -CurlBasis(9,:)

9956
             END IF

9957


9958
             ! ---------------------------------------------------------------------

9959
             ! Additional six basis functions on the square faces (two per face).

9960
             ! ---------------------------------------------------------------------         

9961
             PrismSquareFaceMap(1,:) = (/ 1,2,5,4 /)

9962
             PrismSquareFaceMap(2,:) = (/ 2,3,6,5 /)

9963
             PrismSquareFaceMap(3,:) = (/ 3,1,4,6 /)

9964


9965
             ! The first square face:

9966
             WorkBasis(1,1) = ((-3.0d0 + Sqrt(3.0d0)*v)*(-1.0d0 + w**2))/6.0d0

9967
             WorkBasis(1,2) = -(u*(-1.0d0 + w**2))/(2.0d0*Sqrt(3.0d0))

9968
             WorkBasis(1,3) = 0.0d0

9969
             WorkCurlBasis(1,1) = (u*w)/Sqrt(3.0d0)

9970
             WorkCurlBasis(1,2) = (-1.0d0 + v/Sqrt(3.0d0))*w

9971
             WorkCurlBasis(1,3) = -((-1.0d0 + w**2)/Sqrt(3.0d0)) 

9972


9973
             WorkBasis(2,1) = 0.0d0

9974
             WorkBasis(2,2) = 0.0d0

9975
             WorkBasis(2,3) = (3.0d0 - 3*u**2 - 2*Sqrt(3.0d0)*v + v**2)/6.0d0

9976
             WorkCurlBasis(2,1) = (-Sqrt(3.0d0) + v)/3.0d0

9977
             WorkCurlBasis(2,2) = u

9978
             WorkCurlBasis(2,3) = 0.0d0

9979


9980
             FaceIndices(1:4) = GIndexes(PrismSquareFaceMap(1,1:4))

9981
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

9982


9983
             EdgeBasis(10,:) = D1 * WorkBasis(I1,:)

9984
             CurlBasis(10,:) = D1 * WorkCurlBasis(I1,:)

9985
             EdgeBasis(11,:) = D2 * WorkBasis(I2,:)

9986
             CurlBasis(11,:) = D2 * WorkCurlBasis(I2,:) 

9987


9988
             ! The second square face:

9989
             WorkBasis(1,1) = (v*(-1.0d0 + w**2))/(2.0d0*Sqrt(3.0d0))

9990
             WorkBasis(1,2) = -((1.0d0 + u)*(-1.0d0 + w**2))/(2.0d0*Sqrt(3.0d0))

9991
             WorkBasis(1,3) = 0.0d0

9992
             WorkCurlBasis(1,1) = ((1.0d0 + u)*w)/Sqrt(3.0d0)

9993
             WorkCurlBasis(1,2) = (v*w)/Sqrt(3.0d0)

9994
             WorkCurlBasis(1,3) = -((-1.0d0 + w**2)/Sqrt(3.0d0))

9995


9996
             WorkBasis(2,1) = 0.0d0

9997
             WorkBasis(2,2) = 0.0d0

9998
             WorkBasis(2,3) = ((Sqrt(3.0d0) + Sqrt(3.0d0)*u - v)*v)/3.0d0

9999
             WorkCurlBasis(2,1) = (Sqrt(3.0d0) + Sqrt(3.0d0)*u - 2*v)/3.0d0

10000
             WorkCurlBasis(2,2) = -(v/Sqrt(3.0d0))

10001
             WorkCurlBasis(2,3) = 0.0d0 

10002


10003
             FaceIndices(1:4) = GIndexes(PrismSquareFaceMap(2,1:4))

10004
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10005


10006
             EdgeBasis(12,:) = D1 * WorkBasis(I1,:)

10007
             CurlBasis(12,:) = D1 * WorkCurlBasis(I1,:)

10008
             EdgeBasis(13,:) = D2 * WorkBasis(I2,:)

10009
             CurlBasis(13,:) = D2 * WorkCurlBasis(I2,:) 

10010


10011
             ! The third square face:

10012
             WorkBasis(1,1) = (v*(-1.0d0 + w**2))/(2.0d0*SQRT(3.0d0))

10013
             WorkBasis(1,2) = -((-1.0d0 + u)*(-1.0d0 + w**2))/(2.0d0*SQRT(3.0d0))

10014
             WorkBasis(1,3) = 0.0d0

10015
             WorkCurlBasis(1,1) = ((-1.0d0 + u)*w)/SQRT(3.0d0)

10016
             WorkCurlBasis(1,2) = (v*w)/SQRT(3.0d0)

10017
             WorkCurlBasis(1,3) = -(-1.0d0 + w**2)/SQRT(3.0d0)

10018


10019
             WorkBasis(2,1) = 0.0d0

10020
             WorkBasis(2,2) = 0.0d0

10021
             WorkBasis(2,3) = -(v*(-Sqrt(3.0d0) + Sqrt(3.0d0)*u + v))/3.0d0

10022
             WorkCurlBasis(2,1) = (Sqrt(3.0d0) - Sqrt(3.0d0)*u - 2*v)/3.0d0

10023
             WorkCurlBasis(2,2) = v/Sqrt(3.0d0)

10024
             WorkCurlBasis(2,3) = 0.0d0

10025


10026
             FaceIndices(1:4) = GIndexes(PrismSquareFaceMap(3,1:4))

10027
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10028


10029
             EdgeBasis(14,:) = D1 * WorkBasis(I1,:)

10030
             CurlBasis(14,:) = D1 * WorkCurlBasis(I1,:)

10031
             EdgeBasis(15,:) = D2 * WorkBasis(I2,:)

10032
             CurlBasis(15,:) = D2 * WorkCurlBasis(I2,:) 

10033
           END IF

10034


10035
         CASE(8)

10036
           !--------------------------------------------------------------

10037
           ! This branch is for handling brick elements

10038
           !--------------------------------------------------------------           

10039
           EdgeMap => GetEdgeMap(8)

10040
           

10041
           IF (SecondOrder) THEN

10042
             !---------------------------------------------------------------

10043
             ! The second-order element from the Nedelec's first family 

10044
             ! (note that the lowest-order brick element is from a different 

10045
             ! family). This element may not be optimally accurate if 

10046
             ! the physical element is not affine.

10047
             !--------------------------------------------------------------             

10048
  

10049
             ! Edges 12 and 43 ...

10050
             DO q=1,2

10051
               k = 2*q-1 ! Edge number k: 1 ~ 12 and 3 ~ 43 

10052
               i = EdgeMap(k,1)

10053
               j = EdgeMap(k,2)

10054
               EdgeBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(1,w) * LineNodalPBasis(q,v) 

10055
               CurlBasis(2*(k-1)+1,2) = 0.5d0 * (-0.5d0) * LineNodalPBasis(q,v) 

10056
               CurlBasis(2*(k-1)+1,3) = -0.5d0 * LineNodalPBasis(1,w) * dLineNodalPBasis(q,v)

10057
               EdgeBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(1,w) * u * LineNodalPBasis(q,v) 

10058
               CurlBasis(2*(k-1)+2,2) = 1.5d0 * (-0.5d0) * u * LineNodalPBasis(q,v) 

10059
               CurlBasis(2*(k-1)+2,3) = -1.5d0 * LineNodalPBasis(1,w) * u * dLineNodalPBasis(q,v)

10060
               IF(GIndexes(j)<GIndexes(i)) THEN

10061
                 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:)

10062
                 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:)

10063
               END IF

10064
             END DO

10065


10066
             ! Edges 56 and 87 ...

10067
             DO q=1,2

10068
               k = 4 + 2*q-1 ! Edge number k: 5 ~ 56 and 7 ~ 87 

10069
               i = EdgeMap(k,1)

10070
               j = EdgeMap(k,2)

10071
               EdgeBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(2,w) * LineNodalPBasis(q,v) 

10072
               CurlBasis(2*(k-1)+1,2) = 0.5d0 * 0.5d0 * LineNodalPBasis(q,v) 

10073
               CurlBasis(2*(k-1)+1,3) = -0.5d0 * LineNodalPBasis(2,w) * dLineNodalPBasis(q,v)

10074
               EdgeBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(2,w) * u * LineNodalPBasis(q,v) 

10075
               CurlBasis(2*(k-1)+2,2) = 1.5d0 * 0.5d0 * u * LineNodalPBasis(q,v) 

10076
               CurlBasis(2*(k-1)+2,3) = -1.5d0 * LineNodalPBasis(2,w) * u * dLineNodalPBasis(q,v)

10077
               IF(GIndexes(j)<GIndexes(i)) THEN

10078
                 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:)

10079
                 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:)

10080
               END IF

10081
             END DO

10082


10083
             ! Edges 23 and 14 ...

10084
             DO q=1,2

10085
               k = 2*q ! Edge number k: 2 ~ 23 and 4 ~ 14 

10086
               i = EdgeMap(k,1)

10087
               j = EdgeMap(k,2)

10088
               EdgeBasis(2*(k-1)+1,2) = 0.5d0 * LineNodalPBasis(1,w) * LineNodalPBasis(3-q,u) 

10089
               CurlBasis(2*(k-1)+1,1) = -0.5d0 * (-0.5d0) * LineNodalPBasis(3-q,u) 

10090
               CurlBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(1,w) * dLineNodalPBasis(3-q,u)

10091
               EdgeBasis(2*(k-1)+2,2) = 1.5d0 * LineNodalPBasis(1,w) * v * LineNodalPBasis(3-q,u) 

10092
               CurlBasis(2*(k-1)+2,1) = -1.5d0 * (-0.5d0) * v * LineNodalPBasis(3-q,u) 

10093
               CurlBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(1,w) * v * dLineNodalPBasis(3-q,u)

10094
               IF(GIndexes(j)<GIndexes(i)) THEN

10095
                 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:)

10096
                 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:)

10097
               END IF

10098
             END DO            

10099


10100
             ! Edges 67 and 58 ...

10101
             DO q=1,2

10102
               k = 4+2*q ! Edge number k: 6 ~ 67 and 8 ~ 58 

10103
               i = EdgeMap(k,1)

10104
               j = EdgeMap(k,2)

10105
               EdgeBasis(2*(k-1)+1,2) = 0.5d0 * LineNodalPBasis(2,w) * LineNodalPBasis(3-q,u) 

10106
               CurlBasis(2*(k-1)+1,1) = -0.5d0 * 0.5d0 * LineNodalPBasis(3-q,u) 

10107
               CurlBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(2,w) * dLineNodalPBasis(3-q,u)

10108
               EdgeBasis(2*(k-1)+2,2) = 1.5d0 * LineNodalPBasis(2,w) * v * LineNodalPBasis(3-q,u) 

10109
               CurlBasis(2*(k-1)+2,1) = -1.5d0 * 0.5d0 * v * LineNodalPBasis(3-q,u) 

10110
               CurlBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(2,w) * v * dLineNodalPBasis(3-q,u)

10111
               IF(GIndexes(j)<GIndexes(i)) THEN

10112
                 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:)

10113
                 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:)

10114
               END IF

10115
             END DO          

10116


10117
             ! Edges 15 and 48 ...

10118
             DO q=1,2

10119
               k = 8+3*(q-1)+1 ! Edge number k: 9 ~ 15 and 12 ~ 48 

10120
               i = EdgeMap(k,1)

10121
               j = EdgeMap(k,2)

10122
               EdgeBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(1,u) * LineNodalPBasis(q,v) 

10123
               CurlBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(1,u) * dLineNodalPBasis(q,v) 

10124
               CurlBasis(2*(k-1)+1,2) = -0.5d0 * dLineNodalPBasis(1,u) * LineNodalPBasis(q,v)

10125
               EdgeBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(1,u) * w * LineNodalPBasis(q,v) 

10126
               CurlBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(1,u) * w * dLineNodalPBasis(q,v) 

10127
               CurlBasis(2*(k-1)+2,2) = -1.5d0 * dLineNodalPBasis(1,u) * w * LineNodalPBasis(q,v)

10128
               IF(GIndexes(j)<GIndexes(i)) THEN

10129
                 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:)

10130
                 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:)

10131
               END IF

10132
             END DO         

10133


10134
             ! Edges 26 and 37 ...

10135
             DO q=1,2

10136
               k = 9+q ! Edge number k: 10 ~ 26 and 11 ~ 37 

10137
               i = EdgeMap(k,1)

10138
               j = EdgeMap(k,2)

10139
               EdgeBasis(2*(k-1)+1,3) = 0.5d0 * LineNodalPBasis(2,u) * LineNodalPBasis(q,v) 

10140
               CurlBasis(2*(k-1)+1,1) = 0.5d0 * LineNodalPBasis(2,u) * dLineNodalPBasis(q,v) 

10141
               CurlBasis(2*(k-1)+1,2) = -0.5d0 * dLineNodalPBasis(2,u) * LineNodalPBasis(q,v)

10142
               EdgeBasis(2*(k-1)+2,3) = 1.5d0 * LineNodalPBasis(2,u) * w * LineNodalPBasis(q,v) 

10143
               CurlBasis(2*(k-1)+2,1) = 1.5d0 * LineNodalPBasis(2,u) * w * dLineNodalPBasis(q,v) 

10144
               CurlBasis(2*(k-1)+2,2) = -1.5d0 * dLineNodalPBasis(2,u) * w * LineNodalPBasis(q,v)

10145
               IF(GIndexes(j)<GIndexes(i)) THEN

10146
                 EdgeBasis(2*(k-1)+1,:) = -EdgeBasis(2*(k-1)+1,:)

10147
                 CurlBasis(2*(k-1)+1,:) = -CurlBasis(2*(k-1)+1,:)

10148
               END IF

10149
             END DO     

10150


10151
             ! ---------------------------------------------------------------------

10152
             ! Additional basis functions on the square faces (four per face).

10153
             ! ---------------------------------------------------------------------         

10154


10155
             ! Faces 1234 and 5678:

10156
             DO q=1,2

10157
               SELECT CASE(q)

10158
               CASE(1)

10159
                 SquareFaceMap(:) = (/ 1,2,3,4 /)

10160
               CASE(2)

10161
                 SquareFaceMap(:) = (/ 5,6,7,8 /)

10162
               END SELECT

10163


10164
               WorkBasis = 0.0d0

10165
               WorkCurlBasis = 0.0d0

10166


10167
               WorkBasis(1,1) = 2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * LineNodalPBasis(q,w)

10168
               WorkCurlBasis(1,2) = 2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * dLineNodalPBasis(q,w)

10169
               WorkCurlBasis(1,3) = v * LineNodalPBasis(q,w)

10170


10171
               WorkBasis(2,1) = 12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * u * LineNodalPBasis(q,w)

10172
               WorkCurlBasis(2,2) = 12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * u * dLineNodalPBasis(q,w)

10173
               WorkCurlBasis(2,3) = -12.0d0 * (-0.5d0 * v) * u * dLineNodalPBasis(q,w) 

10174


10175
               WorkBasis(3,2) = 2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * LineNodalPBasis(q,w)

10176
               WorkCurlBasis(3,1) = -2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * dLineNodalPBasis(q,w)

10177
               WorkCurlBasis(3,3) = -u * LineNodalPBasis(q,w)

10178
               

10179
               WorkBasis(4,2) = 12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * v * LineNodalPBasis(q,w)

10180
               WorkCurlBasis(4,1) = -12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * v * dLineNodalPBasis(q,w)

10181
               WorkCurlBasis(4,3) = 12.0d0 * (-0.5d0 * u) * v * LineNodalPBasis(q,w)

10182
               

10183
               FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

10184
               CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10185


10186
               k = 24

10187
               EdgeBasis(k+4*(q-1)+1,:) = D1 * WorkBasis(2*(I1-1)+1,:)

10188
               CurlBasis(k+4*(q-1)+1,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

10189
               EdgeBasis(k+4*(q-1)+2,:) = WorkBasis(2*(I1-1)+2,:)

10190
               CurlBasis(k+4*(q-1)+2,:) = WorkCurlBasis(2*(I1-1)+2,:)

10191
               EdgeBasis(k+4*(q-1)+3,:) = D2 * WorkBasis(2*(I2-1)+1,:)

10192
               CurlBasis(k+4*(q-1)+3,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

10193
               EdgeBasis(k+4*(q-1)+4,:) = WorkBasis(2*(I2-1)+2,:)

10194
               CurlBasis(k+4*(q-1)+4,:) = WorkCurlBasis(2*(I2-1)+2,:)

10195
             END DO

10196


10197
             ! Faces 1265 and 4378:

10198
             DO q=1,2

10199
               SELECT CASE(q)

10200
               CASE(1)

10201
                 SquareFaceMap(:) = (/ 1,2,6,5 /)

10202
                 k = 32

10203
               CASE(2)

10204
                 SquareFaceMap(:) = (/ 4,3,7,8 /)

10205
                 k = 40

10206
               END SELECT

10207


10208
               WorkBasis = 0.0d0

10209
               WorkCurlBasis = 0.0d0

10210


10211
               WorkBasis(1,1) = 2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * LineNodalPBasis(q,v)

10212
               WorkCurlBasis(1,2) = 2.0d0 * (-0.5d0 * w) * LineNodalPBasis(q,v)

10213
               WorkCurlBasis(1,3) = -2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * dLineNodalPBasis(q,v)

10214


10215
               WorkBasis(2,1) = 12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * LineNodalPBasis(q,v)

10216
               WorkCurlBasis(2,2) = 12.0d0 * (-0.5d0 * w) * u * LineNodalPBasis(q,v)

10217
               WorkCurlBasis(2,3) = -12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * dLineNodalPBasis(q,v)

10218


10219
               WorkBasis(3,3) = 2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * LineNodalPBasis(q,v)

10220
               WorkCurlBasis(3,1) = 2.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * dLineNodalPBasis(q,v)

10221
               WorkCurlBasis(3,2) = u * LineNodalPBasis(q,v)

10222
               

10223
               WorkBasis(4,3) = 12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * w * LineNodalPBasis(q,v)

10224
               WorkCurlBasis(4,1) = 12.0d0 * LineNodalPBasis(1,u) * LineNodalPBasis(2,u) * w * dLineNodalPBasis(q,v)

10225
               WorkCurlBasis(4,2) = -12.0d0 * (-0.5d0 * u) * w * LineNodalPBasis(q,v)

10226
               

10227
               FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

10228
               CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10229


10230
               EdgeBasis(k+1,:) = D1 * WorkBasis(2*(I1-1)+1,:)

10231
               CurlBasis(k+1,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

10232
               EdgeBasis(k+2,:) = WorkBasis(2*(I1-1)+2,:)

10233
               CurlBasis(k+2,:) = WorkCurlBasis(2*(I1-1)+2,:)

10234
               EdgeBasis(k+3,:) = D2 * WorkBasis(2*(I2-1)+1,:)

10235
               CurlBasis(k+3,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

10236
               EdgeBasis(k+4,:) = WorkBasis(2*(I2-1)+2,:)

10237
               CurlBasis(k+4,:) = WorkCurlBasis(2*(I2-1)+2,:)

10238
             END DO

10239
             

10240
             ! Faces 2376 and 1485:

10241
             DO q=1,2

10242
               SELECT CASE(q)

10243
               CASE(1)

10244
                 SquareFaceMap(:) = (/ 1,4,8,5 /)

10245
                 k = 44

10246
               CASE(2)

10247
                 SquareFaceMap(:) = (/ 2,3,7,6 /)

10248
                 k = 36

10249
               END SELECT

10250


10251
               WorkBasis = 0.0d0

10252
               WorkCurlBasis = 0.0d0

10253


10254
               WorkBasis(1,2) = 2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * LineNodalPBasis(q,u)

10255
               WorkCurlBasis(1,1) = -2.0d0 * (-0.5d0 * w) * LineNodalPBasis(q,u)

10256
               WorkCurlBasis(1,3) = 2.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * dLineNodalPBasis(q,u)

10257


10258
               WorkBasis(2,2) = 12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * LineNodalPBasis(q,u)

10259
               WorkCurlBasis(2,1) = -12.0d0 * (-0.5d0 * w) * v * LineNodalPBasis(q,u)

10260
               WorkCurlBasis(2,3) = 12.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * dLineNodalPBasis(q,u)

10261


10262
               WorkBasis(3,3) = 2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * LineNodalPBasis(q,u)

10263
               WorkCurlBasis(3,1) = 2.0d0 * (-0.5d0 * v) * LineNodalPBasis(q,u)

10264
               WorkCurlBasis(3,2) = -2.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * dLineNodalPBasis(q,u)

10265
               

10266
               WorkBasis(4,3) = 12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * LineNodalPBasis(q,u)

10267
               WorkCurlBasis(4,1) = 12.0d0 * (-0.5d0 * v) * w * LineNodalPBasis(q,u)

10268
               WorkCurlBasis(4,2) = -12.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * dLineNodalPBasis(q,u)

10269
               

10270
               FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

10271
               CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10272


10273
               EdgeBasis(k+1,:) = D1 * WorkBasis(2*(I1-1)+1,:)

10274
               CurlBasis(k+1,:) = D1 * WorkCurlBasis(2*(I1-1)+1,:)

10275
               EdgeBasis(k+2,:) = WorkBasis(2*(I1-1)+2,:)

10276
               CurlBasis(k+2,:) = WorkCurlBasis(2*(I1-1)+2,:)

10277
               EdgeBasis(k+3,:) = D2 * WorkBasis(2*(I2-1)+1,:)

10278
               CurlBasis(k+3,:) = D2 * WorkCurlBasis(2*(I2-1)+1,:)

10279
               EdgeBasis(k+4,:) = WorkBasis(2*(I2-1)+2,:)

10280
               CurlBasis(k+4,:) = WorkCurlBasis(2*(I2-1)+2,:)

10281
             END DO

10282


10283
             ! Interior basis functions, two per coordinate direction:

10284


10285
             EdgeBasis(49,1) = 8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * &

10286
                 LineNodalPBasis(1,v) * LineNodalPBasis(2,v)

10287
             CurlBasis(49,2) = 8.0d0 * (-0.5d0 * w) * LineNodalPBasis(1,v) * LineNodalPBasis(2,v)

10288
             CurlBasis(49,3) = -8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * (-0.5d0 * v)

10289


10290
             EdgeBasis(50,1) = 24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u * &

10291
                 LineNodalPBasis(1,v) * LineNodalPBasis(2,v)

10292
             CurlBasis(50,2) = 24.0d0 * (-0.5d0 * w) * u * LineNodalPBasis(1,v) * LineNodalPBasis(2,v)

10293
             CurlBasis(50,3) = -24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * u *  (-0.5d0 * v)

10294


10295
 

10296
             EdgeBasis(51,2) = 8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * &

10297
                 LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10298
             CurlBasis(51,1) = -8.0d0 * (-0.5d0 * w) * LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10299
             CurlBasis(51,3) = 8.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * (-0.5d0 * u)

10300


10301
             EdgeBasis(52,2) = 24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * &

10302
                 LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10303
             CurlBasis(52,1) = -24.0d0 * (-0.5d0 * w) * v * LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10304
             CurlBasis(52,3) = 24.0d0 * LineNodalPBasis(1,w) * LineNodalPBasis(2,w) * v * (-0.5d0 * u)

10305
            

10306
             EdgeBasis(53,3) = 8.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * &

10307
                 LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10308
             CurlBasis(53,1) = 8.0d0 * (-0.5d0 * v) * LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10309
             CurlBasis(53,2) = -8.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * (-0.5d0 * u)

10310


10311
             EdgeBasis(54,3) = 24.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * &

10312
                 LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10313
             CurlBasis(54,1) = 24.0d0 * (-0.5d0 * v) * w * LineNodalPBasis(1,u) * LineNodalPBasis(2,u)

10314
             CurlBasis(54,2) = -24.0d0 * LineNodalPBasis(1,v) * LineNodalPBasis(2,v) * w * (-0.5d0 * u)

10315


10316
           ELSE

10317
             !--------------------------------------------------------------

10318
             ! The lowest-order element from the optimal family. The optimal

10319
             ! accuracy is obtained also for non-affine meshes.

10320
             ! -------------------------------------------------------------

10321
             ! First twelve basis functions associated with the edges

10322
             ! -------------------------------------------------------------

10323
             i = EdgeMap(1,1)

10324
             j = EdgeMap(1,2)

10325
             EdgeBasis(1,1) = ((-1.0d0 + v)*v*(-1.0d0 + w)*w)/8.0d0

10326
             EdgeBasis(1,2) = 0.0d0

10327
             EdgeBasis(1,3) = 0.0d0

10328
             CurlBasis(1,1) = 0.0d0

10329
             CurlBasis(1,2) = ((-1.0d0 + v)*v*(-1.0d0 + 2*w))/8.0d0

10330
             CurlBasis(1,3) = -((-1.0d0 + 2*v)*(-1.0d0 + w)*w)/8.0d0

10331
             IF(GIndexes(j)<GIndexes(i)) THEN

10332
               EdgeBasis(1,:) = -EdgeBasis(1,:)

10333
               CurlBasis(1,:) = -CurlBasis(1,:)

10334
             END IF

10335


10336
             i = EdgeMap(2,1)

10337
             j = EdgeMap(2,2)

10338
             EdgeBasis(2,1) = 0.0d0

10339
             EdgeBasis(2,2) = (u*(1.0d0 + u)*(-1.0d0 + w)*w)/8.0d0

10340
             EdgeBasis(2,3) = 0.0d0

10341
             CurlBasis(2,1) = -(u*(1.0d0 + u)*(-1.0d0 + 2*w))/8.0d0

10342
             CurlBasis(2,2) = 0.0d0

10343
             CurlBasis(2,3) = ((1.0d0 + 2*u)*(-1.0d0 + w)*w)/8.0d0

10344
             IF(GIndexes(j)<GIndexes(i)) THEN

10345
               EdgeBasis(2,:) = -EdgeBasis(2,:)

10346
               CurlBasis(2,:) = -CurlBasis(2,:)

10347
             END IF

10348


10349
             i = EdgeMap(3,1)

10350
             j = EdgeMap(3,2)

10351
             EdgeBasis(3,1) = (v*(1.0d0 + v)*(-1.0d0 + w)*w)/8.0d0

10352
             EdgeBasis(3,2) = 0.0d0

10353
             EdgeBasis(3,3) = 0.0d0

10354
             CurlBasis(3,1) = 0.0d0

10355
             CurlBasis(3,2) = (v*(1.0d0 + v)*(-1.0d0 + 2*w))/8.0d0

10356
             CurlBasis(3,3) = -((1.0d0 + 2*v)*(-1.0d0 + w)*w)/8.0d0

10357
             IF(GIndexes(j)<GIndexes(i)) THEN

10358
               EdgeBasis(3,:) = -EdgeBasis(3,:)

10359
               CurlBasis(3,:) = -CurlBasis(3,:)

10360
             END IF

10361


10362
             i = EdgeMap(4,1)

10363
             j = EdgeMap(4,2)

10364
             EdgeBasis(4,1) = 0.0d0

10365
             EdgeBasis(4,2) = ((-1.0d0 + u)*u*(-1.0d0 + w)*w)/8.0d0

10366
             EdgeBasis(4,3) = 0.0d0

10367
             CurlBasis(4,1) = -((-1.0d0 + u)*u*(-1.0d0 + 2*w))/8.0d0

10368
             CurlBasis(4,2) = 0.0d0

10369
             CurlBasis(4,3) = ((-1.0d0 + 2*u)*(-1.0d0 + w)*w)/8.0d0

10370
             IF(GIndexes(j)<GIndexes(i)) THEN

10371
               EdgeBasis(4,:) = -EdgeBasis(4,:)

10372
               CurlBasis(4,:) = -CurlBasis(4,:)

10373
             END IF

10374


10375
             i = EdgeMap(5,1)

10376
             j = EdgeMap(5,2)

10377
             EdgeBasis(5,1) = ((-1.0d0 + v)*v*w*(1.0d0 + w))/8.0d0

10378
             EdgeBasis(5,2) = 0.0d0

10379
             EdgeBasis(5,3) = 0.0d0

10380
             CurlBasis(5,1) = 0.0d0

10381
             CurlBasis(5,2) = ((-1.0d0 + v)*v*(1.0d0 + 2*w))/8.0d0 

10382
             CurlBasis(5,3) = -((-1.0d0 + 2*v)*w*(1.0d0 + w))/8.0d0

10383
             IF(GIndexes(j)<GIndexes(i)) THEN

10384
               EdgeBasis(5,:) = -EdgeBasis(5,:)

10385
               CurlBasis(5,:) = -CurlBasis(5,:)

10386
             END IF

10387


10388
             i = EdgeMap(6,1)

10389
             j = EdgeMap(6,2)

10390
             EdgeBasis(6,1) = 0.0d0

10391
             EdgeBasis(6,2) = (u*(1.0d0 + u)*w*(1.0d0 + w))/8.0d0

10392
             EdgeBasis(6,3) = 0.0d0

10393
             CurlBasis(6,1) = -(u*(1.0d0 + u)*(1.0d0 + 2*w))/8.0d0

10394
             CurlBasis(6,2) = 0.0d0

10395
             CurlBasis(6,3) = ((1.0d0 + 2*u)*w*(1.0d0 + w))/8.0d0

10396
             IF(GIndexes(j)<GIndexes(i)) THEN

10397
               EdgeBasis(6,:) = -EdgeBasis(6,:)

10398
               CurlBasis(6,:) = -CurlBasis(6,:)

10399
             END IF

10400


10401
             i = EdgeMap(7,1)

10402
             j = EdgeMap(7,2)

10403
             EdgeBasis(7,1) = (v*(1.0d0 + v)*w*(1.0d0 + w))/8.0d0

10404
             EdgeBasis(7,2) = 0.0d0

10405
             EdgeBasis(7,3) = 0.0d0

10406
             CurlBasis(7,1) = 0.0d0

10407
             CurlBasis(7,2) = (v*(1.0d0 + v)*(1.0d0 + 2*w))/8.0d0

10408
             CurlBasis(7,3) = -((1.0d0 + 2*v)*w*(1.0d0 + w))/8.0d0

10409
             IF(GIndexes(j)<GIndexes(i)) THEN

10410
               EdgeBasis(7,:) = -EdgeBasis(7,:)

10411
               CurlBasis(7,:) = -CurlBasis(7,:)

10412
             END IF

10413


10414
             i = EdgeMap(8,1)

10415
             j = EdgeMap(8,2)

10416
             EdgeBasis(8,1) = 0.0d0

10417
             EdgeBasis(8,2) = ((-1.0d0 + u)*u*w*(1.0d0 + w))/8.0d0

10418
             EdgeBasis(8,3) = 0.0d0

10419
             CurlBasis(8,1) = -((-1.0d0 + u)*u*(1.0d0 + 2*w))/8.0d0

10420
             CurlBasis(8,2) = 0.0d0

10421
             CurlBasis(8,3) = ((-1.0d0 + 2*u)*w*(1.0d0 + w))/8.0d0

10422
             IF(GIndexes(j)<GIndexes(i)) THEN

10423
               EdgeBasis(8,:) = -EdgeBasis(8,:)

10424
               CurlBasis(8,:) = -CurlBasis(8,:)

10425
             END IF

10426


10427
             i = EdgeMap(9,1)

10428
             j = EdgeMap(9,2)

10429
             EdgeBasis(9,1) = 0.0d0

10430
             EdgeBasis(9,2) = 0.0d0

10431
             EdgeBasis(9,3) = ((-1.0d0 + u)*u*(-1.0d0 + v)*v)/8.0d0

10432
             CurlBasis(9,1) = ((-1.0d0 + u)*u*(-1.0d0 + 2*v))/8.0d0

10433
             CurlBasis(9,2) = -((-1.0d0 + 2*u)*(-1.0d0 + v)*v)/8.0d0

10434
             CurlBasis(9,3) = 0.0d0

10435
             IF(GIndexes(j)<GIndexes(i)) THEN

10436
               EdgeBasis(9,:) = -EdgeBasis(9,:)

10437
               CurlBasis(9,:) = -CurlBasis(9,:)

10438
             END IF

10439


10440
             i = EdgeMap(10,1)

10441
             j = EdgeMap(10,2)

10442
             EdgeBasis(10,1) = 0.0d0

10443
             EdgeBasis(10,2) = 0.0d0

10444
             EdgeBasis(10,3) = (u*(1.0d0 + u)*(-1.0d0 + v)*v)/8.0d0

10445
             CurlBasis(10,1) = (u*(1.0d0 + u)*(-1.0d0 + 2*v))/8.0d0

10446
             CurlBasis(10,2) = -((1.0d0 + 2*u)*(-1.0d0 + v)*v)/8.0d0

10447
             CurlBasis(10,3) = 0.0d0

10448
             IF(GIndexes(j)<GIndexes(i)) THEN

10449
               EdgeBasis(10,:) = -EdgeBasis(10,:)

10450
               CurlBasis(10,:) = -CurlBasis(10,:)

10451
             END IF

10452


10453
             i = EdgeMap(11,1)

10454
             j = EdgeMap(11,2)

10455
             EdgeBasis(11,1) = 0.0d0

10456
             EdgeBasis(11,2) = 0.0d0

10457
             EdgeBasis(11,3) = (u*(1.0d0 + u)*v*(1.0d0 + v))/8.0d0

10458
             CurlBasis(11,1) = (u*(1.0d0 + u)*(1.0d0 + 2*v))/8.0d0

10459
             CurlBasis(11,2) = -((1.0d0 + 2*u)*v*(1.0d0 + v))/8.0d0

10460
             CurlBasis(11,3) = 0.0d0

10461
             IF(GIndexes(j)<GIndexes(i)) THEN

10462
               EdgeBasis(11,:) = -EdgeBasis(11,:)

10463
               CurlBasis(11,:) = -CurlBasis(11,:)

10464
             END IF

10465


10466
             i = EdgeMap(12,1)

10467
             j = EdgeMap(12,2)

10468
             EdgeBasis(12,1) = 0.0d0

10469
             EdgeBasis(12,2) = 0.0d0

10470
             EdgeBasis(12,3) = ((-1.0d0 + u)*u*v*(1.0d0 + v))/8.0d0

10471
             CurlBasis(12,1) = ((-1.0d0 + u)*u*(1.0d0 + 2*v))/8.0d0

10472
             CurlBasis(12,2) = -((-1.0d0 + 2*u)*v*(1.0d0 + v))/8.0d0

10473
             CurlBasis(12,3) = 0.0d0

10474
             IF(GIndexes(j)<GIndexes(i)) THEN

10475
               EdgeBasis(12,:) = -EdgeBasis(12,:)

10476
               CurlBasis(12,:) = -CurlBasis(12,:)

10477
             END IF

10478


10479
             ! ---------------------------------------------------------------------

10480
             ! Additional twelve basis functions on the square faces (two per face).

10481
             ! ---------------------------------------------------------------------         

10482
             BrickFaceMap(1,:) = (/ 1,2,3,4 /)          

10483
             BrickFaceMap(2,:) = (/ 5,6,7,8 /)

10484
             BrickFaceMap(3,:) = (/ 1,2,6,5 /)

10485
             BrickFaceMap(4,:) = (/ 2,3,7,6 /)

10486
             BrickFaceMap(5,:) = (/ 4,3,7,8 /)

10487
             BrickFaceMap(6,:) = (/ 1,4,8,5 /)

10488


10489
             ! The first face:

10490
             WorkBasis(1,1) = -((-1.0d0 + v**2)*(-1.0d0 + w)*w)/4.0d0

10491
             WorkBasis(1,2) = 0.0d0

10492
             WorkBasis(1,3) = 0.0d0

10493
             WorkCurlBasis(1,1) = 0.0d0

10494
             WorkCurlBasis(1,2) = -((-1.0d0 + v**2)*(-1.0d0 + 2*w))/4.0d0

10495
             WorkCurlBasis(1,3) = (v*(-1.0d0 + w)*w)/2.0d0

10496


10497
             WorkBasis(2,1) = 0.0d0

10498
             WorkBasis(2,2) = -((-1.0d0 + u**2)*(-1.0d0 + w)*w)/4.0d0

10499
             WorkBasis(2,3) = 0.0d0

10500
             WorkCurlBasis(2,1) = ((-1.0d0 + u**2)*(-1.0d0 + 2*w))/4.0d0

10501
             WorkCurlBasis(2,2) = 0.0d0

10502
             WorkCurlBasis(2,3) = -(u*(-1.0d0 + w)*w)/2.0d0

10503


10504
             FaceIndices(1:4) = GIndexes(BrickFaceMap(1,1:4))

10505
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10506


10507
             EdgeBasis(13,:) = D1 * WorkBasis(I1,:)

10508
             CurlBasis(13,:) = D1 * WorkCurlBasis(I1,:)

10509
             EdgeBasis(14,:) = D2 * WorkBasis(I2,:)

10510
             CurlBasis(14,:) = D2 * WorkCurlBasis(I2,:) 

10511


10512
             ! The second face:

10513
             WorkBasis(1,1) = -((-1.0d0 + v**2)*w*(1.0d0 + w))/4.0d0

10514
             WorkBasis(1,2) = 0.0d0

10515
             WorkBasis(1,3) = 0.0d0

10516
             WorkCurlBasis(1,1) = 0.0d0

10517
             WorkCurlBasis(1,2) = -((-1.0d0 + v**2)*(1.0d0 + 2*w))/4.0d0

10518
             WorkCurlBasis(1,3) = (v*w*(1.0d0 + w))/2.0d0

10519


10520
             WorkBasis(2,1) = 0.0d0

10521
             WorkBasis(2,2) = -((-1.0d0 + u**2)*w*(1.0d0 + w))/4.0d0

10522
             WorkBasis(2,3) = 0.0d0

10523
             WorkCurlBasis(2,1) = ((-1.0d0 + u**2)*(1.0d0 + 2*w))/4.0d0

10524
             WorkCurlBasis(2,2) = 0.0d0

10525
             WorkCurlBasis(2,3) = -(u*w*(1.0d0 + w))/2.0d0

10526


10527
             FaceIndices(1:4) = GIndexes(BrickFaceMap(2,1:4))

10528
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10529


10530
             EdgeBasis(15,:) = D1 * WorkBasis(I1,:)

10531
             CurlBasis(15,:) = D1 * WorkCurlBasis(I1,:)

10532
             EdgeBasis(16,:) = D2 * WorkBasis(I2,:)

10533
             CurlBasis(16,:) = D2 * WorkCurlBasis(I2,:) 

10534


10535
             ! The third face:

10536
             WorkBasis(1,1) = -((-1.0d0 + v)*v*(-1.0d0 + w**2))/4.0d0

10537
             WorkBasis(1,2) = 0.0d0

10538
             WorkBasis(1,3) = 0.0d0

10539
             WorkCurlBasis(1,1) = 0.0d0

10540
             WorkCurlBasis(1,2) = -((-1.0d0 + v)*v*w)/2.0d0

10541
             WorkCurlBasis(1,3) = ((-1.0d0 + 2*v)*(-1.0d0 + w**2))/4.0d0

10542


10543
             WorkBasis(2,1) = 0.0d0

10544
             WorkBasis(2,2) = 0.0d0

10545
             WorkBasis(2,3) = -((-1.0d0 + u**2)*(-1.0d0 + v)*v)/4.0d0

10546
             WorkCurlBasis(2,1) = -((-1.0d0 + u**2)*(-1.0d0 + 2*v))/4.0d0

10547
             WorkCurlBasis(2,2) = (u*(-1.0d0 + v)*v)/2.0d0

10548
             WorkCurlBasis(2,3) = 0.0d0

10549


10550
             FaceIndices(1:4) = GIndexes(BrickFaceMap(3,1:4))

10551
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10552


10553
             EdgeBasis(17,:) = D1 * WorkBasis(I1,:)

10554
             CurlBasis(17,:) = D1 * WorkCurlBasis(I1,:)

10555
             EdgeBasis(18,:) = D2 * WorkBasis(I2,:)

10556
             CurlBasis(18,:) = D2 * WorkCurlBasis(I2,:) 

10557


10558
             ! The fourth face:

10559
             WorkBasis(1,1) = 0.0d0

10560
             WorkBasis(1,2) = -(u*(1.0d0 + u)*(-1.0d0 + w**2))/4.0d0

10561
             WorkBasis(1,3) = 0.0d0

10562
             WorkCurlBasis(1,1) = (u*(1.0d0 + u)*w)/2.0d0

10563
             WorkCurlBasis(1,2) = 0.0d0

10564
             WorkCurlBasis(1,3) = -((1.0d0 + 2*u)*(-1.0d0 + w**2))/4.0d0

10565


10566
             WorkBasis(2,1) = 0.0d0

10567
             WorkBasis(2,2) = 0.0d0

10568
             WorkBasis(2,3) = -(u*(1.0d0 + u)*(-1 + v**2))/4.0d0

10569
             WorkCurlBasis(2,1) = -(u*(1.0d0 + u)*v)/2.0d0

10570
             WorkCurlBasis(2,2) = ((1.0d0 + 2*u)*(-1.0d0 + v**2))/4.0d0

10571
             WorkCurlBasis(2,3) = 0.0d0

10572


10573
             FaceIndices(1:4) = GIndexes(BrickFaceMap(4,1:4))

10574
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10575


10576
             EdgeBasis(19,:) = D1 * WorkBasis(I1,:)

10577
             CurlBasis(19,:) = D1 * WorkCurlBasis(I1,:)

10578
             EdgeBasis(20,:) = D2 * WorkBasis(I2,:)

10579
             CurlBasis(20,:) = D2 * WorkCurlBasis(I2,:) 

10580


10581
             ! The fifth face:

10582
             WorkBasis(1,1) = -(v*(1.0d0 + v)*(-1.0d0 + w**2))/4.0d0

10583
             WorkBasis(1,2) = 0.0d0

10584
             WorkBasis(1,3) = 0.0d0

10585
             WorkCurlBasis(1,1) = 0.0d0

10586
             WorkCurlBasis(1,2) = -(v*(1.0d0 + v)*w)/2.0d0

10587
             WorkCurlBasis(1,3) = ((1.0d0 + 2*v)*(-1.0d0 + w**2))/4.0d0

10588


10589
             WorkBasis(2,1) = 0.0d0

10590
             WorkBasis(2,2) = 0.0d0

10591
             WorkBasis(2,3) = -((-1.0d0 + u**2)*v*(1.0d0 + v))/4.0d0

10592
             WorkCurlBasis(2,1) = -((-1.0d0 + u**2)*(1.0d0 + 2*v))/4.0d0

10593
             WorkCurlBasis(2,2) = (u*v*(1.0d0 + v))/2.0d0

10594
             WorkCurlBasis(2,3) = 0.0d0

10595


10596
             FaceIndices(1:4) = GIndexes(BrickFaceMap(5,1:4))

10597
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10598


10599
             EdgeBasis(21,:) = D1 * WorkBasis(I1,:)

10600
             CurlBasis(21,:) = D1 * WorkCurlBasis(I1,:)

10601
             EdgeBasis(22,:) = D2 * WorkBasis(I2,:)

10602
             CurlBasis(22,:) = D2 * WorkCurlBasis(I2,:) 

10603


10604
             ! The sixth face:

10605
             WorkBasis(1,1) = 0.0d0

10606
             WorkBasis(1,2) = -((-1.0d0 + u)*u*(-1.0d0 + w**2))/4.0d0

10607
             WorkBasis(1,3) = 0.0d0

10608
             WorkCurlBasis(1,1) = ((-1.0d0 + u)*u*w)/2.0d0

10609
             WorkCurlBasis(1,2) = 0.0d0

10610
             WorkCurlBasis(1,3) = -((-1.0d0 + 2*u)*(-1.0d0 + w**2))/4.0d0

10611


10612
             WorkBasis(2,1) = 0.0d0

10613
             WorkBasis(2,2) = 0.0d0

10614
             WorkBasis(2,3) = -((-1.0d0 + u)*u*(-1.0d0 + v**2))/4.0d0

10615
             WorkCurlBasis(2,1) = -((-1.0d0 + u)*u*v)/2.0d0

10616
             WorkCurlBasis(2,2) = ((-1.0d0 + 2*u)*(-1.0d0 + v**2))/4.0d0

10617
             WorkCurlBasis(2,3) = 0.0d0

10618


10619
             FaceIndices(1:4) = GIndexes(BrickFaceMap(6,1:4))

10620
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

10621


10622
             EdgeBasis(23,:) = D1 * WorkBasis(I1,:)

10623
             CurlBasis(23,:) = D1 * WorkCurlBasis(I1,:)

10624
             EdgeBasis(24,:) = D2 * WorkBasis(I2,:)

10625
             CurlBasis(24,:) = D2 * WorkCurlBasis(I2,:) 

10626


10627
             ! ------------------------------------------------------------------------

10628
             ! Additional basis functions on the element interior (three per element)

10629
             ! -----------------------------------------------------------------------

10630
             EdgeBasis(25,1) = ((-1.0d0 + v**2)*(-1.0d0 + w**2))/2.0d0

10631
             EdgeBasis(25,2) = 0.0d0

10632
             EdgeBasis(25,3) = 0.0d0

10633
             CurlBasis(25,1) = 0.0d0

10634
             CurlBasis(25,2) = (-1.0d0 + v**2)*w

10635
             CurlBasis(25,3) = v - v*w**2

10636


10637
             EdgeBasis(26,1) = 0.0d0

10638
             EdgeBasis(26,2) = ((-1.0d0 + u**2)*(-1.0d0 + w**2))/2.0d0

10639
             EdgeBasis(26,3) = 0.0d0

10640
             CurlBasis(26,1) = w - u**2*w

10641
             CurlBasis(26,2) = 0.0d0

10642
             CurlBasis(26,3) = u*(-1 + w**2)

10643


10644
             EdgeBasis(27,1) = 0.0d0

10645
             EdgeBasis(27,2) = 0.0d0

10646
             EdgeBasis(27,3) = ((-1.0d0 + u**2)*(-1.0d0 + v**2))/2.0d0

10647
             CurlBasis(27,1) = (-1.0d0 + u**2)*v

10648
             CurlBasis(27,2) = u - u*v**2

10649
             CurlBasis(27,3) = 0.0d0

10650
           END IF

10651


10652
         CASE DEFAULT

10653
           CALL Fatal('ElementDescription::EdgeElementInfo','Unsupported element type')

10654
         END SELECT

10655
       END IF

10656


10657
       IF (cdim == dim) THEN

10658
          !--------------------------------------------------------------------------------

10659
          ! To optimize computation, this branch avoids calling the ElementMetric function

10660
          ! since all necessary data has already been found via PiolaTransformationData.

10661
          !-------------------------------------------------------------------------------

10662
          IF (PerformPiolaTransform) THEN

10663
             DO j=1,DOFs

10664
                DO k=1,dim

10665
                   B(k) = SUM( LG(k,1:dim) * EdgeBasis(j,1:dim) )

10666
                END DO

10667
                EdgeBasis(j,1:dim) = B(1:dim)

10668


10669
                IF (dim == 2) THEN

10670
                   CurlBasis(j,3) = 1.0d0/DetF * CurlBasis(j,3)

10671
                ELSE

10672
                   DO k=1,dim

10673
                      B(k) = 1.0d0/DetF * SUM( LF(k,1:dim) * CurlBasis(j,1:dim) )

10674
                   END DO

10675
                   CurlBasis(j,1:dim) = B(1:dim)

10676
                END IF

10677
             END DO

10678
             ! Make the returned value DetF to act as a metric term for integration

10679
             ! over the volume of the element: 

10680
             DetF = ABS(DetF)

10681
          END IF

10682


10683
          ! ----------------------------------------------------------------------

10684
          ! Get global first derivatives of the nodal basis functions if wanted:

10685
          ! ----------------------------------------------------------------------

10686
          IF ( PRESENT(dBasisdx) ) THEN

10687
             dBasisdx = 0.0d0

10688
             DO i=1,n

10689
                DO j=1,dim

10690
                   DO k=1,dim

10691
                      dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LG(j,k)

10692
                   END DO

10693
                END DO

10694
             END DO

10695
          END IF

10696
       ELSE

10697
          ! ----------------------------------------------------------------------

10698
          ! We should enter this branch in the case of 2-D elements (dim=2) 

10699
          ! embedded in the three-dimensional space (cdim=3). The following function

10700
          ! defines LG to be the transpose of the pseudoinverse of F = LF.

10701
          ! ----------------------------------------------------------------------       

10702
          IF (PerformPiolaTransform .OR. PRESENT(dBasisdx) .OR. ApplyTraceMapping) THEN

10703
             IF ( .NOT. ElementMetric( n, Element, Nodes, &

10704
                  ElmMetric, detJ, dLBasisdx, LG ) ) THEN

10705
                stat = .FALSE.

10706
                RETURN

10707
             END IF

10708
          END IF

10709


10710
          IF (ApplyTraceMapping) THEN

10711
            ! Perform operation b -> b x n. The resulting field transforms under the usual 

10712
            ! Piola transform (like div-conforming field). For a general surface element

10713
            ! embedded in 3D we return B(f(p))=1/sqrt(a) F(b x n) where a is the determinant of

10714
            ! the metric tensor, F=[a1 a2] with a1 and a2 surface basis vectors and (b x n) is

10715
            ! considered to be 2-vector (the trivial component ignored). Note that asking simultaneously 

10716
            ! for the curl of the basis is not an expected combination.

10717
            DO j=1,DOFs

10718
              WorkBasis(1,1:2) = EdgeBasis(j,1:2)

10719
              EdgeBasis(j,1) = WorkBasis(1,2)

10720
              EdgeBasis(j,2) = -WorkBasis(1,1)

10721
            END DO

10722
            IF (PerformPiolaTransform) THEN

10723
              DO j=1,DOFs 

10724
                DO k=1,cdim

10725
                  B(k) = SUM( LF(k,1:dim) * EdgeBasis(j,1:dim) ) / DetJ

10726
                END DO

10727
                EdgeBasis(j,1:cdim) = B(1:cdim)                

10728
              END DO

10729
            END IF

10730
          ELSE

10731
            IF (PerformPiolaTransform) THEN

10732
              DO j=1,DOFs

10733
                DO k=1,cdim

10734
                  B(k) = SUM( LG(k,1:dim) * EdgeBasis(j,1:dim) )

10735
                END DO

10736
                EdgeBasis(j,1:cdim) = B(1:cdim)

10737
                ! The returned spatial curl in the case cdim=3 and dim=2 handled here

10738
                ! has limited usability. This handles only either a transformation of

10739
                ! the type x_3 = p_3 or the normal component of curl for an arbitrarily

10740
                ! oriented surface element. Note that the normal component is returned

10741
                ! as the third entry, so this value has to be multiplied with the normal

10742
                ! vector to get the vector representation of the normal component with

10743
                ! respect to the coordinate axes. 

10744
                CurlBasis(j,3) = 1.0d0/DetJ * CurlBasis(j,3)

10745
              END DO

10746
            END IF

10747
          END IF

10748


10749
          ! Make the returned value DetF to act as a metric term for integration

10750
          ! over the volume of the element: 

10751
          DetF = DetJ

10752


10753
          ! ----------------------------------------------------------------------

10754
          ! Get global first derivatives of the nodal basis functions if wanted:

10755
          ! ----------------------------------------------------------------------

10756
          IF ( PRESENT(dBasisdx) ) THEN

10757
             dBasisdx = 0.0d0

10758
             DO i=1,n

10759
                DO j=1,cdim

10760
                   DO k=1,dim

10761
                      dBasisdx(i,j) = dBasisdx(i,j) + dLBasisdx(i,k)*LG(j,k)

10762
                   END DO

10763
                END DO

10764
             END DO

10765
          END IF

10766


10767
       END IF

10768


10769
       IF(PRESENT(F)) F = LF

10770
       IF(PRESENT(G)) G = LG

10771
       IF(PRESENT(RotBasis)) RotBasis(1:DOFs,:) = CurlBasis(1:DOFs,:)

10772
!-----------------------------------------------------------------------------

10773
     END FUNCTION EdgeElementInfo

10774
!------------------------------------------------------------------------------

10775


10776
     

10777
     

10778
!----------------------------------------------------------------------------

10779
     SUBROUTINE TriangleFaceDofsOrdering(I1,I2,D1,D2,Ind)       

10780
!-----------------------------------------------------------------------------

10781
! This is used for selecting what additional basis functions are associated

10782
! with a triangular face in the case of second-order approximation in H(curl).

10783
! Given a triangular face [ijk] this subroutine can be used to pick two basis

10784
! functions from an array of three candidate functions (for Nedelec's first family)

10785
!

10786
!    b_1 = L_k W_{ij}

10787
!    b_2 = L_j W_{ik}

10788
!    b_3 = L_i W_{jk}       

10789
!

10790
! such that the two basis functions are L_C W_{AB} and L_B W_{AC}. Here W_{ij}

10791
! denotes the Whitney form and {A,B,C} are the global node indices such that

10792
! A < B < C. D1 and D2 indicate whether sign reversions must be applied to

10793
! the pre-tabulated basis functions.        

10794
! ----------------------------------------------------------------------------

10795
       INTEGER, INTENT(OUT) :: I1, I2

10796
       REAL(KIND=dp), INTENT(OUT) :: D1, D2

10797
       INTEGER, INTENT(IN) :: Ind(4)

10798
!---------------------------------------------------------------------------

10799
       INTEGER ::  k, A

10800
! --------------------------------------------------------------------------

10801
       D1 = 1.0d0

10802
       D2 = 1.0d0

10803
       IF ( Ind(1) < Ind(2) ) THEN

10804
          k = 1

10805
       ELSE

10806
          k = 2

10807
       END IF

10808
       IF ( Ind(k) > Ind(3) ) THEN

10809
          k = 3

10810
       END IF

10811
       A = k

10812


10813
       SELECT CASE(A)

10814
       CASE(1)

10815
          IF (Ind(3) > Ind(2)) THEN

10816
             ! C = 3

10817
             I1 = 1

10818
             I2 = 2

10819
          ELSE

10820
             ! C = 2

10821
             I1 = 2

10822
             I2 = 1             

10823
          END IF

10824
       CASE(2)

10825
         IF (Ind(3) > Ind(1)) THEN

10826
             ! C = 3

10827
             I1 = 1

10828
             I2 = 3

10829
             D1 = -1.0d0

10830
          ELSE

10831
             ! C = 1

10832
             I1 = 3

10833
             I2 = 1

10834
             D2 = -1.0d0             

10835
          END IF

10836
       CASE(3)

10837
          IF (Ind(2) > Ind(1)) THEN

10838
             ! C = 2

10839
             I1 = 2

10840
             I2 = 3

10841
          ELSE

10842
             ! C = 1

10843
             I1 = 3

10844
             I2 = 2

10845
          END IF

10846
          D1 = -1.0d0

10847
          D2 = -1.0d0          

10848
       CASE DEFAULT

10849
          CALL Fatal('ElementDescription::TriangleFaceDofsOrdering','Erratic triangular face Indices')

10850
       END SELECT

10851
!---------------------------------------------------------

10852
     END SUBROUTINE TriangleFaceDofsOrdering

10853
!-----------------------------------------------------------

10854


10855
!----------------------------------------------------------------------------

10856
     SUBROUTINE TriangleFaceDofsOrdering2nd(I1,I2,I3,Ind)       

10857
!-----------------------------------------------------------------------------

10858
! This is used for selecting the order of additional basis functions associated

10859
! with a triangular face in the case of a higher-order approximation in H(curl) when

10860
! the Nedelec second family is used. Given a triangular face [ijk] this subroutine

10861
! can be used to permute an array of three candidate basis functions

10862
!

10863
!    b_1 = L_j L_k grad L_i

10864
!    b_2 = L_i L_k grad L_j

10865
!    b_3 = L_i L_j grad L_k

10866
!

10867
! such that the basis functions are  {L_B L_C grad L_A, L_A L_C grad L_B,

10868
! L_A L_B grad L_C}. Here {A,B,C} are the global node indices such that

10869
! A < B < C. 

10870
! ----------------------------------------------------------------------------

10871
       INTEGER, INTENT(OUT) :: I1, I2, I3

10872
       INTEGER, INTENT(IN) :: Ind(3)

10873
!---------------------------------------------------------------------------

10874
       INTEGER ::  k, A

10875
! --------------------------------------------------------------------------

10876
       IF ( Ind(1) < Ind(2) ) THEN

10877
          k = 1

10878
       ELSE

10879
          k = 2

10880
       END IF

10881
       IF ( Ind(k) > Ind(3) ) THEN

10882
          k = 3

10883
       END IF

10884
       A = k

10885


10886
       SELECT CASE(A)

10887
       CASE(1)

10888
          IF (Ind(3) > Ind(2)) THEN

10889
             ! C = 3

10890
             I1 = 1

10891
             I2 = 2

10892
             I3 = 3

10893
          ELSE

10894
             ! C = 2

10895
             I1 = 1

10896
             I2 = 3

10897
             I3 = 2

10898
          END IF

10899
       CASE(2)

10900
         IF (Ind(3) > Ind(1)) THEN

10901
             ! C = 3

10902
             I1 = 2

10903
             I2 = 1

10904
             I3 = 3

10905
          ELSE

10906
             ! C = 1

10907
             I1 = 2

10908
             I2 = 3

10909
             I3 = 1

10910
          END IF

10911
       CASE(3)

10912
          IF (Ind(2) > Ind(1)) THEN

10913
             ! C = 2

10914
             I1 = 3

10915
             I2 = 1

10916
             I3 = 2

10917
          ELSE

10918
             ! C = 1

10919
             I1 = 3

10920
             I2 = 2

10921
             I3 = 1

10922
          END IF

10923
       CASE DEFAULT

10924
          CALL Fatal('ElementDescription::TriangleFaceDofsOrdering2nd','Erratic triangular face Indices')

10925
       END SELECT

10926
!---------------------------------------------------------

10927
     END SUBROUTINE TriangleFaceDofsOrdering2nd

10928
!-----------------------------------------------------------

10929


10930
     

10931


10932
!-------------------------------------------------------------

10933
     SUBROUTINE TriangleFaceDofsOrdering2(t,s,Ind)       

10934
!-------------------------------------------------------------------------------

10935
! Returns two unit vectors t and s for spanning constant vector fields

10936
! defined on a triangular face. As a rule for orientation, the vector t is defined 

10937
! as t = Grad L_B - Grad L_A where L_A and L_B are the Lagrange basis functions

10938
! associated with the nodes that has the smallest global indices A and B (A<B).

10939
! Then s = Sqrt(3)* grad L_C, with C corresponding to the largest global index.

10940
!-------------------------------------------------------------------------------

10941
       INTEGER ::  Ind(4)

10942
       REAL(KIND=dp) :: t(3), s(3)

10943
!----------------------------------------------------------

10944
       INTEGER ::  k, A

10945
! -------------------------------------------------------------------

10946
       t = 0.0d0

10947
       s = 0.0d0

10948


10949
       IF ( Ind(1) < Ind(2) ) THEN

10950
          k = 1

10951
       ELSE

10952
          k = 2

10953
       END IF

10954
       IF ( Ind(k) > Ind(3) ) THEN

10955
          k = 3

10956
       END IF

10957
       A = k

10958


10959
       SELECT CASE(A)

10960
       CASE(1)

10961
          IF ( Ind(2) < Ind(3) ) THEN ! B=2, tangent = AB = 12

10962
             t(1) = 1.0d0

10963
             t(2) = 0.0

10964
             s(1) = 0.0d0

10965
             s(2) = 1.0d0

10966
          ELSE ! B=3, tangent = AB = 13

10967
             t(1) = 0.5d0

10968
             t(2) = Sqrt(3.0d0)/2.0d0

10969
             s(1) = Sqrt(3.0d0)/2.0d0

10970
             s(2) = -0.5d0

10971
          END IF

10972
       CASE(2)     

10973
          IF ( Ind(1) < Ind(3) ) THEN ! B=1, tangent = AB = 21

10974
             t(1) = -1.0d0

10975
             t(2) = 0.0

10976
             s(1) = 0.0d0

10977
             s(2) = 1.0d0

10978
          ELSE ! B=3, tangent = AB = 23

10979
             t(1) = -0.5d0

10980
             t(2) = Sqrt(3.0d0)/2.0d0

10981
             s(1) = -Sqrt(3.0d0)/2.0d0

10982
             s(2) = -0.5d0

10983
          END IF

10984
       CASE(3)

10985
          IF ( Ind(1) < Ind(2) ) THEN ! B=1, tangent = AB = 31

10986
             t(1) = -0.5d0

10987
             t(2) = -Sqrt(3.0d0)/2.0d0

10988
             s(1) = Sqrt(3.0d0)/2.0d0

10989
             s(2) = -0.5d0          

10990
          ELSE ! B=2, tangent = AB = 32

10991
             t(1) = 0.5d0

10992
             t(2) = -Sqrt(3.0d0)/2.0d0            

10993
             s(1) = -Sqrt(3.0d0)/2.0d0

10994
             s(2) = -0.5d0       

10995
          END IF

10996
       CASE DEFAULT

10997
          CALL Fatal('ElementDescription::TriangleFaceDofsOrdering','Erratic square face Indices')

10998
       END SELECT

10999
!---------------------------------------------------------

11000
     END SUBROUTINE TriangleFaceDofsOrdering2

11001
!-----------------------------------------------------------

11002


11003
!---------------------------------------------------------

11004
!> This subroutine can be used to create a unique parametrization of

11005
!> quadrilateral faces so that different elements sharing the same

11006
!> face can list the basis functions associated with the face in

11007
!> a unique order. If the face of the reference element is represented

11008
!> by default using two basis vectors e(1,:) and e(2,:), the unique

11009
!> parametrization uses the basis E1 = D1 * e(I1,:) and 

11010
!> E2 = D2 * e(I2,:). 

11011
!----------------------------------------------------------------------

11012
     SUBROUTINE SquareFaceDofsOrdering(I1, I2, D1, D2, Ind, ReverseSign)       

11013
!----------------------------------------------------------------------

11014
       INTEGER, INTENT(OUT) ::  I1, I2      !< Permutation info about coordinate directions

11015
       REAL(KIND=dp), INTENT(OUT) :: D1, D2 !< Sign reversion info related to coordinate directions  

11016
       INTEGER, INTENT(IN) :: Ind(4)        !< The global indices of quadrilateral face

11017
       LOGICAL, OPTIONAL, INTENT(OUT) :: ReverseSign   ! Is e(1,:) x e(2,:) /=  E1 x E2

11018
!----------------------------------------------------------

11019
       INTEGER ::  i, j, k, l, A

11020
       LOGICAL :: ReverseNormal

11021
! -------------------------------------------------------------------

11022
!  Find input for applying an order change and sign reversions to two

11023
!  basis functions associated with a square face. To this end, 

11024
!  find nodes A, B, C such that A has the minimal global index,

11025
!  AB and AC are edges, with C having the largest global index. 

11026
!  Then AB gives the positive direction for the first face DOF and

11027
!  AC gives the positive direction for the second face DOF.

11028
!  REMARK: This convention must be followed when creating basis

11029
!  functions for other element types which are intended to be compatible

11030
!  with the element type to which this rule is applied.

11031
! -------------------------------------------------------------------

11032
       i = 1

11033
       j = 2

11034
       IF ( Ind(i) < Ind(j) ) THEN

11035
          k = i

11036
       ELSE

11037
          k = j

11038
       END IF

11039
       i = 4

11040
       j = 3 

11041
       IF ( Ind(i) < Ind(j) ) THEN

11042
          l = i

11043
       ELSE

11044
          l = j

11045
       END IF

11046
       IF ( Ind(k) > Ind(l) ) THEN

11047
          k = l

11048
       END IF

11049
       A = k

11050


11051
       ReverseNormal = .FALSE.

11052
       

11053
       SELECT CASE(A)

11054
       CASE(1)

11055
          IF ( Ind(2) < Ind(4) ) THEN

11056
             I1 = 1

11057
             I2 = 2

11058
             D1 = 1.0d0

11059
             D2 = 1.0d0

11060
          ELSE

11061
             I1 = 2

11062
             I2 = 1

11063
             D1 = 1.0d0

11064
             D2 = 1.0d0

11065
             ReverseNormal = .TRUE.

11066
          END IF

11067
       CASE(2)

11068
          IF ( Ind(3) < Ind(1) ) THEN

11069
             I1 = 2

11070
             I2 = 1

11071
             D1 = 1.0d0

11072
             D2 = -1.0d0

11073
          ELSE

11074
             I1 = 1

11075
             I2 = 2

11076
             D1 = -1.0d0

11077
             D2 = 1.0d0

11078
             ReverseNormal = .TRUE.

11079
          END IF

11080
       CASE(3)

11081
          IF ( Ind(4) < Ind(2) ) THEN

11082
             I1 = 1

11083
             I2 = 2

11084
             D1 = -1.0d0

11085
             D2 = -1.0d0

11086
          ELSE

11087
             I1 = 2

11088
             I2 = 1

11089
             D1 = -1.0d0

11090
             D2 = -1.0d0

11091
             ReverseNormal = .TRUE.

11092
          END IF

11093
       CASE(4)

11094
          IF ( Ind(1) < Ind(3) ) THEN

11095
             I1 = 2

11096
             I2 = 1

11097
             D1 = -1.0d0

11098
             D2 = 1.0d0

11099
          ELSE

11100
             I1 = 1

11101
             I2 = 2

11102
             D1 = 1.0d0

11103
             D2 = -1.0d0

11104
             ReverseNormal = .TRUE.

11105
          END IF

11106
       CASE DEFAULT

11107
          CALL Fatal('ElementDescription::SquareFaceDofsOrdering','Erratic square face Indices')

11108
       END SELECT

11109


11110
       IF (PRESENT(ReverseSign)) ReverseSign = ReverseNormal

11111
!----------------------------------------------------------

11112
     END SUBROUTINE SquareFaceDofsOrdering

11113
!----------------------------------------------------------

11114


11115
!----------------------------------------------------------------------------------

11116
!>  Returns data for rearranging H(curl)-conforming basis functions so that 

11117
!>  compatibility with the convention for defining global DOFs is attained.

11118
!>  If n basis function value have already been tabulated in the default order

11119
!>  as BasisArray(1:n,:), then SignVec(1:n) * BasisArray(PermVec(1:n),:) gives

11120
!>  the basis vector values corresponding to the global DOFs.

11121
!>  TO DO: support for second-order basis functions, triangles and quads missing

11122
!------------------------------------------------------------------------------------

11123
     SUBROUTINE ReorderingAndSignReversionsData(Element,Nodes,PermVec,SignVec)

11124
!-------------------------------------------------------------------------------------

11125
       IMPLICIT NONE

11126


11127
       TYPE(Element_t), TARGET :: Element        !< Element structure

11128
       TYPE(Nodes_t) :: Nodes                    !< Data corresponding to the classic element nodes

11129
       INTEGER :: PermVec(:)                     !< At exit the permutation vector for performing reordering

11130
       REAL(KIND=dp) :: SignVec(:)               !< At exit the vector for performing sign changes

11131
!---------------------------------------------------------------------------------------------------

11132
       TYPE(Mesh_t), POINTER :: Mesh       

11133
       INTEGER, POINTER :: EdgeMap(:,:)

11134
       INTEGER :: SquareFaceMap(4), BrickFaceMap(6,4), PrismSquareFaceMap(3,4), GIndexes(27), DOFs, i, j, k

11135
       INTEGER :: FaceIndices(4), I1, I2, n

11136
       REAL(KIND=dp) :: D1, D2

11137
       LOGICAL :: Parallel

11138
!---------------------------------------------------------------------------------------------------

11139
       Mesh => CurrentModel % Solver % Mesh

11140


11141
       Parallel = ASSOCIATED(Mesh % ParallelInfo % GInterface)

11142
       

11143
       SignVec = 1.0d0

11144
       

11145
       n = Element % TYPE % NumberOfNodes

11146
       GIndexes(1:n) = Element % NodeIndexes(1:n)

11147
       IF(Parallel) GIndexes(1:n) = Mesh % ParallelInfo % GlobalDofs(GIndexes(1:n))

11148


11149
       SELECT CASE( Element % TYPE % ElementCode / 100 )

11150
       !CASE(3) needs to be done

11151


11152
       !CASE(4) needs to be done

11153


11154
       CASE(5)

11155
         ! NOTE: The Nedelec second family is not yet supported

11156
         EdgeMap => GetEdgeMap(5)

11157
         DO k=1,6

11158
           i = EdgeMap(k,1)

11159
           j = EdgeMap(k,2)

11160
           IF (GIndexes(j)<GIndexes(i)) SignVec(k) = -1.0d0

11161
           PermVec(k) = k

11162
         END DO

11163


11164
       CASE(6)

11165
          EdgeMap => GetEdgeMap(6)

11166
          DO k=1,8

11167
             i = EdgeMap(k,1)

11168
             j = EdgeMap(k,2)

11169
             IF (GIndexes(j)<GIndexes(i)) SignVec(k) = -1.0d0

11170
             PermVec(k) = k

11171
          END DO

11172
          ! -----------------------------------------------------

11173
          ! Additional two basis functions on the square face

11174
          ! -----------------------------------------------------

11175
          SquareFaceMap(:) = (/ 1,2,3,4 /)

11176
          FaceIndices(1:4) = GIndexes(SquareFaceMap(1:4))

11177
          CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

11178
          i = 8

11179
          PermVec(i+1) = i+I1 

11180
          PermVec(i+2) = i+I2

11181
          SignVec(i+1) = D1

11182
          SignVec(i+2) = D2

11183
 

11184
       CASE(7)

11185
          EdgeMap => GetEdgeMap(7)

11186
          DO k=1,9

11187
             i = EdgeMap(k,1)

11188
             j = EdgeMap(k,2)

11189
             IF (GIndexes(j)<GIndexes(i)) SignVec(k) = -1.0d0

11190
             PermVec(k) = k

11191
          END DO

11192
          ! ---------------------------------------------------------------------

11193
          ! Additional six basis functions on the square faces (two per face).

11194
          ! ---------------------------------------------------------------------         

11195
          PrismSquareFaceMap(1,:) = (/ 1,2,5,4 /)

11196
          PrismSquareFaceMap(2,:) = (/ 2,3,6,5 /)

11197
          PrismSquareFaceMap(3,:) = (/ 3,1,4,6 /)

11198
          DO k=1,3

11199
             FaceIndices(1:4) = GIndexes(PrismSquareFaceMap(k,1:4))

11200
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

11201
             i = 9+(k-1)*2

11202
             PermVec(i+1) = i+I1 

11203
             PermVec(i+2) = i+I2

11204
             SignVec(i+1) = D1

11205
             SignVec(i+2) = D2 

11206
          END DO

11207


11208
       CASE(8)

11209
          EdgeMap => GetEdgeMap(8)

11210
          DO k=1,12

11211
             i = EdgeMap(k,1)

11212
             j = EdgeMap(k,2)

11213
             IF (GIndexes(j)<GIndexes(i)) SignVec(k) = -1.0d0

11214
             PermVec(k) = k

11215
          END DO

11216
          ! ---------------------------------------------------------------------

11217
          ! Additional twelve basis functions on the square faces (two per face).

11218
          ! ---------------------------------------------------------------------         

11219
          BrickFaceMap(1,:) = (/ 1,2,3,4 /)          

11220
          BrickFaceMap(2,:) = (/ 5,6,7,8 /)

11221
          BrickFaceMap(3,:) = (/ 1,2,6,5 /)

11222
          BrickFaceMap(4,:) = (/ 2,3,7,6 /)

11223
          BrickFaceMap(5,:) = (/ 4,3,7,8 /)

11224
          BrickFaceMap(6,:) = (/ 1,4,8,5 /)

11225
          DO k=1,6

11226
             FaceIndices(1:4) = GIndexes(BrickFaceMap(k,1:4))

11227
             CALL SquareFaceDofsOrdering(I1,I2,D1,D2,FaceIndices)

11228
             i = 12+(k-1)*2

11229
             PermVec(i+1) = i+I1 

11230
             PermVec(i+2) = i+I2

11231
             SignVec(i+1) = D1

11232
             SignVec(i+2) = D2 

11233
          END DO

11234
          PermVec(25) = 25

11235
          PermVec(26) = 26         

11236
          PermVec(27) = 27

11237
           

11238
       CASE DEFAULT

11239
          CALL Fatal('ElementDescription::ReorderingAndSignReversionsData','Unsupported element type')

11240
       END SELECT

11241
!----------------------------------------------------------

11242
     END SUBROUTINE ReorderingAndSignReversionsData

11243
!----------------------------------------------------------

11244


11245


11246
! --------------------------------------------------------------------------------------

11247
!> This subroutine contains an older design for providing edge element basis functions

11248
!> of the lowest-degree. Obtaining optimal accuracy with these elements may require that 

11249
!> the element map is affine, while the edge basis functions given by the newer design 

11250
!> (the function EdgeElementInfo) should also work on general meshes. 

11251
!------------------------------------------------------------------------

11252
   SUBROUTINE GetEdgeBasis( Element, WBasis, RotWBasis, Basis, dBasisdx )

11253
!------------------------------------------------------------------------

11254
     TYPE(Element_t),TARGET :: Element

11255
     REAL(KIND=dp) :: WBasis(:,:), RotWBasis(:,:), Basis(:), dBasisdx(:,:)

11256
!------------------------------------------------------------------------

11257
     TYPE(Element_t),POINTER :: Edge

11258
     TYPE(Mesh_t), POINTER :: Mesh

11259
     TYPE(Nodes_t), SAVE :: Nodes

11260
     REAL(KIND=dp) :: u,v,w,dudx(3,3),du(3),Base,dBase(3),tBase(3), &

11261
                rBase(3),triBase(3),dtriBase(3,3), G(3,3), F(3,3), detF, detG, &

11262
                EdgeBasis(8,3), CurlBasis(8,3)

11263
     LOGICAL :: Parallel,stat

11264
     INTEGER :: i,j,k,n,nj,nk,i1,i2

11265
     INTEGER, POINTER :: EdgeMap(:,:)

11266
!------------------------------------------------------------------------

11267
     Mesh => CurrentModel % Solver % Mesh

11268


11269
     Parallel = ASSOCIATED(Mesh % ParallelInfo % GInterface)

11270
     

11271
     IF (Element % TYPE % BasisFunctionDegree>1) THEN

11272
       CALL Fatal('GetEdgeBasis',"Can't handle but linear elements, sorry.") 

11273
     END IF

11274


11275
     SELECT CASE(Element % TYPE % ElementCode / 100)

11276
     CASE(4,7,8)

11277
       n = Element % TYPE % NumberOfNodes

11278
       u = SUM(Basis(1:n)*Element % TYPE % NodeU(1:n))

11279
       v = SUM(Basis(1:n)*Element % TYPE % NodeV(1:n))

11280
       w = SUM(Basis(1:n)*Element % TYPE % NodeW(1:n))

11281


11282
       dudx(1,:) = MATMUL(Element % TYPE % NodeU(1:n),dBasisdx(1:n,:))

11283
       dudx(2,:) = MATMUL(Element % TYPE % NodeV(1:n),dBasisdx(1:n,:))

11284
       dudx(3,:) = MATMUL(Element % TYPE % NodeW(1:n),dBasisdx(1:n,:))

11285


11286
       triBase(1) = 1-u-v

11287
       triBase(2) = u

11288
       triBase(3) = v

11289


11290
       dtriBase(1,:) = -dudx(1,:)-dudx(2,:) 

11291
       dtriBase(2,:) =  dudx(1,:)

11292
       dtriBase(3,:) =  dudx(2,:)

11293
     CASE(6)

11294
       n = Element % TYPE % NumberOfNodes

11295
       u = SUM(Basis(1:n)*Element % TYPE % NodeU(1:n))

11296
       v = SUM(Basis(1:n)*Element % TYPE % NodeV(1:n))

11297
       w = SUM(Basis(1:n)*Element % TYPE % NodeW(1:n))

11298


11299
       G(1,:) = MATMUL(Element % TYPE % NodeU(1:n),dBasisdx(1:n,:))

11300
       G(2,:) = MATMUL(Element % TYPE % NodeV(1:n),dBasisdx(1:n,:))

11301
       G(3,:) = MATMUL(Element % TYPE % NodeW(1:n),dBasisdx(1:n,:))            

11302


11303
       detG =  G(1,1) * ( G(2,2)*G(3,3) - G(2,3)*G(3,2) ) + &

11304
                  G(1,2) * ( G(2,3)*G(3,1) - G(2,1)*G(3,3) ) + &

11305
                  G(1,3) * ( G(2,1)*G(3,2) - G(2,2)*G(3,1) )

11306
       detF = 1.0d0/detG

11307
       CALL InvertMatrix3x3(G,F,detG)

11308
       

11309
       !------------------------------------------------------------

11310
       ! The basis functions spanning the reference element space and

11311
       ! their Curl with respect to the local coordinates

11312
       ! ------------------------------------------------------------

11313
       EdgeBasis(1,1) = (1.0d0 - v - w)/4.0d0

11314
       EdgeBasis(1,2) = 0.0d0

11315
       EdgeBasis(1,3) = (u*(-1.0d0 + v + w))/(4.0d0*(-1.0d0 + w))

11316
       CurlBasis(1,1) = u/(4.0d0*(-1.0d0 + w))

11317
       CurlBasis(1,2) = -(-2.0d0 + v + 2.0d0*w)/(4.0d0*(-1.0d0 + w))

11318
       CurlBasis(1,3) = 0.25d0

11319


11320
       EdgeBasis(2,1) = 0.0d0

11321
       EdgeBasis(2,2) = (1.0d0 + u - w)/4.0d0

11322
       EdgeBasis(2,3) = (v*(1.0d0 + u - w))/(4.0d0 - 4.0d0*w)

11323
       CurlBasis(2,1) = (2.0d0 + u - 2.0d0*w)/(4.0d0 - 4.0d0*w)

11324
       CurlBasis(2,2) = v/(4.0d0*(-1.0d0 + w))

11325
       CurlBasis(2,3) = 0.25d0       

11326


11327
       EdgeBasis(3,1) = (1.0d0 + v - w)/4.0d0

11328
       EdgeBasis(3,2) = 0.0d0

11329
       EdgeBasis(3,3) = (u*(1.0d0 + v - w))/(4.0d0 - 4.0d0*w)

11330
       CurlBasis(3,1) = u/(4.0d0 - 4.0d0*w)

11331
       CurlBasis(3,2) = (2.0d0 + v - 2.0d0*w)/(4.0d0*(-1.0d0 + w))

11332
       CurlBasis(3,3) = -0.25d0

11333


11334
       EdgeBasis(4,1) = 0.0d0

11335
       EdgeBasis(4,2) = (1.0d0 - u - w)/4.0d0

11336
       EdgeBasis(4,3) = (v*(-1.0d0 + u + w))/(4.0d0*(-1.0d0 + w))

11337
       CurlBasis(4,1) = (-2.0d0 + u + 2.0d0*w)/(4.0d0*(-1.0d0 + w))

11338
       CurlBasis(4,2) = v/(4.0d0 - 4.0d0*w)

11339
       CurlBasis(4,3) = -0.25d0

11340


11341
       EdgeBasis(5,1) = (w*(-1.0d0 + v + w))/(4.0d0*(-1.0d0 + w))

11342
       EdgeBasis(5,2) = (w*(-1.0d0 + u + w))/(4.0d0*(-1.0d0 + w))

11343
       EdgeBasis(5,3) = (-((-1.0d0 + v)*(-1.0d0 + w)**2) + u*(v - (-1.0d0 + w)**2 - 2.0d0*v*w))/&

11344
            (4.0d0*(-1.0d0 + w)**2)

11345
       CurlBasis(5,1) = -(-1.0d0 + u + w)/(2.0d0*(-1.0d0 + w))

11346
       CurlBasis(5,2) = (-1.0d0 + v + w)/(2.0d0*(-1.0d0 + w))

11347
       CurlBasis(5,3) = 0.0d0

11348


11349
       EdgeBasis(6,1) = -(w*(-1.0d0 + v + w))/(4.0d0*(-1.0d0 + w))

11350
       EdgeBasis(6,2) = (w*(-1.0d0 - u + w))/(4.0d0*(-1.0d0 + w))

11351
       EdgeBasis(6,3) = (-((-1.0d0 + v)*(-1.0d0 + w)**2) + u*((-1.0d0 + w)**2 + v*(-1.0d0 + 2.0d0*w)))/&

11352
            (4.0d0*(-1.0d0 + w)**2)

11353
       CurlBasis(6,1) = (1.0d0 + u - w)/(2.0d0*(-1.0d0 + w))

11354
       CurlBasis(6,2) = -(-1.0d0 + v + w)/(2.0d0*(-1.0d0 + w))

11355
       CurlBasis(6,3) = 0.0d0    

11356


11357
       EdgeBasis(7,1) = ((1.0d0 + v - w)*w)/(4.0d0*(-1.0d0 + w))

11358
       EdgeBasis(7,2) = ((1.0d0 + u - w)*w)/(4.0d0*(-1.0d0 + w))

11359
       EdgeBasis(7,3) = ((1.0d0 + v)*(-1.0d0 + w)**2 + u*(v + (-1.0d0 + w)**2 - 2.0d0*v*w))/&

11360
            (4.0d0*(-1.0d0 + w)**2)

11361
       CurlBasis(7,1) = (1.0d0 + u - w)/(2.0d0 - 2.0d0*w)

11362
       CurlBasis(7,2) = (1.0d0 + v - w)/(2.0d0*(-1.0d0 + w))

11363
       CurlBasis(7,3) = 0.0d0

11364


11365
       EdgeBasis(8,1) = (w*(-1.0d0 - v + w))/(4.0d0*(-1.0d0 + w))

11366
       EdgeBasis(8,2) = -(w*(-1.0d0 + u + w))/(4.0d0*(-1.0d0 + w))

11367
       EdgeBasis(8,3) = ((1.0d0 + v)*(-1.0d0 + w)**2 - u*(v + (-1.0d0 + w)**2 - 2.0d0*v*w))/&

11368
            (4.0d0*(-1.0d0 + w)**2)

11369
       CurlBasis(8,1) = (-1.0d0 + u + w)/(2.0d0*(-1.0d0 + w))

11370
       CurlBasis(8,2) = (1.0d0 + v - w)/(2.0d0 - 2.0d0*w)

11371
       CurlBasis(8,3) = 0.0d0

11372


11373
     END SELECT

11374


11375
     EdgeMap => GetEdgeMap(Element % TYPE % ElementCode / 100)

11376
     DO i=1,SIZE(Edgemap,1)

11377
       j = EdgeMap(i,1); k = EdgeMap(i,2)

11378


11379
       nj = Element % Nodeindexes(j)

11380
       nk = Element % Nodeindexes(k)

11381
       IF (Parallel) THEN

11382
         nj=Mesh % ParallelInfo % GlobalDOFs(nj)

11383
         nk=Mesh % ParallelInfo % GlobalDOFs(nk)

11384
       END IF

11385
         

11386
       SELECT CASE(Element % TYPE % ElementCode / 100)

11387
       CASE(3,5)

11388
         WBasis(i,:) = Basis(j)*dBasisdx(k,:) - Basis(k)*dBasisdx(j,:)

11389


11390
         RotWBasis(i,1) = 2.0_dp * ( dBasisdx(j,2) * dBasisdx(k,3) - &

11391
                       dBasisdx(j,3) * dBasisdx(k,2) )

11392
         RotWBasis(i,2) = 2.0_dp * ( dBasisdx(j,3) * dBasisdx(k,1) - &

11393
                       dBasisdx(j,1) * dBasisdx(k,3) )

11394
         RotWBasis(i,3) = 2.0_dp * ( dBasisdx(j,1) * dBasisdx(k,2) - &

11395
                       dBasisdx(j,2) * dBasisdx(k,1) )

11396


11397
       CASE(6)

11398
          !-----------------------------------------------------------------------

11399
          ! Create the referential description of basis functions and their 

11400
          ! spatial curl on the physical element via applying the Piola transform:

11401
          !-----------------------------------------------------------------------

11402
          DO k=1,3

11403
             WBasis(i,k) = SUM( G(1:3,k) * EdgeBasis(i,1:3) )

11404
          END DO

11405
          DO k=1,3

11406
             RotWBasis(i,k) = 1.0d0/DetF * SUM( F(k,1:3) * CurlBasis(i,1:3) )

11407
          END DO

11408


11409
       CASE(7)

11410
         SELECT CASE(i)

11411
          CASE(1)

11412
            j=1;k=2; Base=(1-w)/2; dBase=-dudx(3,:)/2

11413
          CASE(2)

11414
            j=2;k=3; Base=(1-w)/2; dBase=-dudx(3,:)/2

11415
          CASE(3)

11416
            j=3;k=1; Base=(1-w)/2; dBase=-dudx(3,:)/2

11417
          CASE(4)

11418
            j=1;k=2; Base=(1+w)/2; dBase= dudx(3,:)/2

11419
          CASE(5)

11420
            j=2;k=3; Base=(1+w)/2; dBase= dudx(3,:)/2

11421
          CASE(6)

11422
            j=3;k=1; Base=(1+w)/2; dBase= dudx(3,:)/2

11423
          CASE(7)

11424
            Base=triBase(1); dBase=dtriBase(1,:); du=dudx(3,:)/2

11425
          CASE(8)

11426
            Base=triBase(2); dBase=dtriBase(2,:); du=dudx(3,:)/2

11427
          CASE(9)

11428
            Base=triBase(3); dBase=dtriBase(3,:); du=dudx(3,:)/2

11429
         END SELECT

11430


11431
         IF(i<=6) THEN

11432
            tBase = (triBase(j)*dtriBase(k,:)-triBase(k)*dtriBase(j,:))

11433
            rBase(1) = 2*Base*(dtriBase(j,2)*dtriBase(k,3)-dtriBase(k,2)*dtriBase(j,3)) + &

11434
                              dBase(2)*tBase(3) - dBase(3)*tBase(2)

11435


11436
            rBase(2) = 2*Base*(dtriBase(j,3)*dtriBase(k,1)-dtriBase(k,3)*dtriBase(j,1)) + &

11437
                              dBase(3)*tBase(1) - dBase(1)*tBase(3)

11438


11439
            rBase(3) = 2*Base*(dtriBase(j,1)*dtriBase(k,2)-dtriBase(k,1)*dtriBase(j,2)) + &

11440
                              dBase(1)*tBase(2) - dBase(2)*tBase(1)

11441


11442
            RotWBasis(i,:)=rBase

11443
            WBasis(i,:)=tBase*Base

11444
         ELSE

11445
            WBasis(i,:)=Base*du

11446
            RotWBasis(i,1)=(dBase(2)*du(3) - dBase(3)*du(2))

11447
            RotWBasis(i,2)=(dBase(3)*du(1) - dBase(1)*du(3))

11448
            RotWBasis(i,3)=(dBase(1)*du(2) - dBase(2)*du(1))

11449
         END IF

11450
       CASE(4)

11451
         SELECT CASE(i)

11452
          CASE(1)

11453
             du=dudx(1,:); Base=(1-v)*(1-w)

11454
             dBase(:)=-dudx(2,:)*(1-w)-(1-v)*dudx(3,:)

11455
          CASE(2)

11456
             du=dudx(2,:); Base=(1+u)*(1-w)

11457
             dBase(:)= dudx(1,:)*(1-w)-(1+u)*dudx(3,:)

11458
          CASE(3)

11459
             du=-dudx(1,:); Base=(1+v)*(1-w)

11460
             dBase(:)= dudx(2,:)*(1-w)-(1+v)*dudx(3,:)

11461
          CASE(4)

11462
             du=-dudx(2,:); Base=(1-u)*(1-w)

11463
             dBase(:)=-dudx(1,:)*(1-w)-(1-u)*dudx(3,:)

11464
         END SELECT

11465


11466
         wBasis(i,:) = Base*du/n

11467
         RotWBasis(i,1)=(dBase(2)*du(3) - dBase(3)*du(2))/n

11468
         RotWBasis(i,2)=(dBase(3)*du(1) - dBase(1)*du(3))/n

11469
         RotWBasis(i,3) = (dBase(1)*du(2) - dBase(2)*du(1))/n

11470
       CASE(8)

11471
         SELECT CASE(i)

11472
          CASE(1)

11473
             du=dudx(1,:); Base=(1-v)*(1-w)

11474
             dBase(:)=-dudx(2,:)*(1-w)-(1-v)*dudx(3,:)

11475
          CASE(2)

11476
             du=dudx(2,:); Base=(1+u)*(1-w)

11477
             dBase(:)= dudx(1,:)*(1-w)-(1+u)*dudx(3,:)

11478
          CASE(3)

11479
             du=dudx(1,:); Base=(1+v)*(1-w)

11480
             dBase(:)= dudx(2,:)*(1-w)-(1+v)*dudx(3,:)

11481
          CASE(4)

11482
             du=dudx(2,:); Base=(1-u)*(1-w)

11483
             dBase(:)=-dudx(1,:)*(1-w)-(1-u)*dudx(3,:)

11484
          CASE(5)

11485
             du=dudx(1,:); Base=(1-v)*(1+w)

11486
             dBase(:)=-dudx(2,:)*(1+w)+(1-v)*dudx(3,:)

11487
          CASE(6)

11488
             du=dudx(2,:); Base=(1+u)*(1+w)

11489
             dBase(:)= dudx(1,:)*(1+w)+(1+u)*dudx(3,:)

11490
          CASE(7)

11491
             du=dudx(1,:); Base=(1+v)*(1+w)

11492
             dBase(:)= dudx(2,:)*(1+w)+(1+v)*dudx(3,:)

11493
          CASE(8)

11494
             du=dudx(2,:); Base=(1-u)*(1+w)

11495
             dBase(:)=-dudx(1,:)*(1+w)+(1-u)*dudx(3,:)

11496
          CASE(9)

11497
             du=dudx(3,:); Base=(1-u)*(1-v)

11498
             dBase(:)=-dudx(1,:)*(1-v)-(1-u)*dudx(2,:)

11499
          CASE(10)

11500
             du=dudx(3,:); Base=(1+u)*(1-v)

11501
             dBase(:)= dudx(1,:)*(1-v)-(1+u)*dudx(2,:)

11502
          CASE(11)

11503
             du=dudx(3,:); Base=(1+u)*(1+v)

11504
             dBase(:)= dudx(1,:)*(1+v)+(1+u)*dudx(2,:)

11505
          CASE(12)

11506
             du=dudx(3,:); Base=(1-u)*(1+v)

11507
             dBase(:)=-dudx(1,:)*(1+v)+(1-u)*dudx(2,:)

11508
         END SELECT

11509


11510
         wBasis(i,:)=Base*du/n

11511
         RotWBasis(i,1)=(dBase(2)*du(3) - dBase(3)*du(2))/n

11512
         RotWBasis(i,2)=(dBase(3)*du(1) - dBase(1)*du(3))/n

11513
         RotWBasis(i,3)=(dBase(1)*du(2) - dBase(2)*du(1))/n

11514
       CASE DEFAULT

11515
         CALL Fatal( 'Edge Basis', 'Not implemented for this element type.')

11516
       END SELECT

11517


11518
       IF( nk < nj ) THEN

11519
         WBasis(i,:) = -WBasis(i,:); RotWBasis(i,:) = -RotWBasis(i,:)

11520
       END IF

11521
     END DO

11522
!------------------------------------------------------------------------------

11523
   END SUBROUTINE GetEdgeBasis

11524
!------------------------------------------------------------------------------

11525


11526
!------------------------------------------------------------------------------

11527
!> Return the elementwise number of degrees of freedom and their indexes for

11528
!> a particular solver

11529
!------------------------------------------------------------------------------

11530
   FUNCTION mGetElementDOFs( Indexes, UElement, USolver, NotDG, UMesh ) RESULT(nd)

11531
!------------------------------------------------------------------------------

11532
     INTEGER :: Indexes(:)

11533
     TYPE(Element_t), OPTIONAL, TARGET :: UElement

11534
     TYPE(Solver_t),  OPTIONAL, TARGET :: USolver

11535
     LOGICAL, OPTIONAL :: NotDG

11536
     TYPE(Mesh_t), OPTIONAL, TARGET :: UMesh

11537
     INTEGER :: nd     

11538
!------------------------------------------------------------------------------

11539
     TYPE(Solver_t),  POINTER :: Solver

11540
     TYPE(Element_t), POINTER :: Element, Parent, Face

11541
     TYPE(Mesh_t), POINTER :: Mesh

11542


11543
     LOGICAL :: Found, GB, DGDisable, NeedEdges, Bubbles

11544
     INTEGER :: i,j,k,id, nb, p, NDOFs, MaxNDOFs, EDOFs, MaxEDOFs, FDOFs, MaxFDOFs, BDOFs

11545
     INTEGER :: Ind, ElemFamily, ParentFamily, face_type, face_id

11546
     INTEGER :: NodalIndexOffset, EdgeIndexOffset, FaceIndexOffset

11547
!------------------------------------------------------------------------------

11548
     IF ( PRESENT( USolver ) ) THEN

11549
       Solver => USolver

11550
     ELSE

11551
       Solver => CurrentModel % Solver

11552
     END IF

11553
     

11554
     nd = 0

11555


11556
     IF (.NOT. ASSOCIATED(Solver)) THEN

11557
       CALL Warn('mGetElementDOFS', 'Cannot return DOFs data without knowing solver')

11558
       RETURN

11559
     END IF

11560
     

11561
     IF( PRESENT( UMesh ) ) THEN

11562
       Mesh => UMesh

11563
     ELSE

11564
       Mesh => Solver % Mesh

11565
     END IF

11566
            

11567
     IF ( PRESENT( UElement ) ) THEN

11568
       Element => UElement

11569
     ELSE

11570
       Element => CurrentModel % CurrentElement

11571
     END IF

11572
     ElemFamily = Element % TYPE % ElementCode / 100

11573


11574
     DGDisable=.FALSE.

11575
     IF (PRESENT(NotDG)) DGDisable=NotDG

11576


11577
     IF ( .NOT. DGDisable .AND. Solver % DG ) THEN

11578
       DO i=1,Element % DGDOFs

11579
         nd = nd + 1

11580
         Indexes(nd) = Element % DGIndexes(i)

11581
       END DO

11582


11583
       IF ( ASSOCIATED( Element % BoundaryInfo ) ) THEN

11584
         IF ( ASSOCIATED( Element % BoundaryInfo % Left ) ) THEN

11585
           DO i=1,Element % BoundaryInfo % Left % DGDOFs

11586
             nd = nd + 1

11587
             Indexes(nd) = Element % BoundaryInfo % Left % DGIndexes(i)

11588
           END DO

11589
         END IF

11590
         IF ( ASSOCIATED( Element % BoundaryInfo % Right ) ) THEN

11591
           DO i=1,Element % BoundaryInfo % Right % DGDOFs

11592
             nd = nd + 1

11593
             Indexes(nd) = Element % BoundaryInfo % Right % DGIndexes(i)

11594
           END DO

11595
         END IF

11596
       END IF

11597


11598
       IF ( nd > 0 ) RETURN

11599
     END IF

11600


11601
     id = Element % BodyId

11602
     IF ( Id==0 .AND. ASSOCIATED(Element % BoundaryInfo) ) THEN

11603
       IF ( ASSOCIATED(Element % BoundaryInfo % Left) ) &

11604
           id = Element % BoundaryInfo % Left % BodyId

11605


11606
       IF (id == 0 .OR. id > CurrentModel % NumberOfBodies) THEN

11607
         IF ( ASSOCIATED(Element % BoundaryInfo % Right) ) &

11608
             id = Element % BoundaryInfo % Right % BodyId

11609
       END IF

11610
     END IF

11611
     !

11612
     ! In some cases it may happen that this function

11613
     ! is called although the BodyId of the element structure hasn't

11614
     ! been set. The following "guess" would be risky if the element

11615
     ! definition depended on body index. It's desirable that

11616
     ! the caller takes care of the creation of the body index so that

11617
     ! the following row need not be considered.

11618
     IF (id==0) id=1

11619


11620


11621
     IF (SIZE(Solver % Def_Dofs,2) < id) CALL Fatal('mGetElementDOFS', &

11622
         'Indexing outside array bounds: '//I2S(SIZE(Solver % Def_Dofs,2))//' vs. '//I2S(id))

11623
     

11624
     IF (.NOT.ASSOCIATED(Mesh)) THEN

11625
       IF ( Solver % Def_Dofs(ElemFamily,id,1)>0 ) THEN  

11626
         CALL Warn('mGetElementDOFS', &

11627
             'Solver mesh unknown, the node indices are returned')

11628
         MaxNDOFs = 1

11629
       ELSE

11630
         CALL Warn('mGetElementDOFS', &

11631
             'Solver mesh unknown, no indices returned')

11632
         RETURN

11633
       END IF

11634
     ELSE

11635
       MaxNDOFs = Mesh % MaxNDOFs

11636
     END IF

11637
     NodalIndexOffset = MaxNDOFs * Mesh % NumberOfNodes     

11638


11639
     NDOFs = Solver % Def_Dofs(ElemFamily,id,1)

11640
     IF (NDOFs > 0) THEN

11641
       DO i=1,Element % TYPE % NumberOfNodes

11642
         DO j=1,NDOFs

11643
           nd = nd + 1

11644
           Indexes(nd) = MaxNDOFs * (Element % NodeIndexes(i)-1) + j

11645
         END DO

11646
       END DO

11647
     END IF

11648


11649
     ! The DOFs of advanced elements cannot be returned without knowing mesh

11650
     ! ---------------------------------------------------------------------

11651
     IF (.NOT.ASSOCIATED(Mesh)) RETURN

11652


11653
     NeedEdges = .FALSE.

11654
     DO i=2,SIZE(Solver % Def_Dofs,3)

11655
       IF (Solver % Def_Dofs(ElemFamily, id, i)>=0) THEN

11656
         NeedEdges = .TRUE.

11657
         EXIT

11658
       END IF

11659
     END DO

11660


11661
     IF (.NOT. NeedEdges) THEN

11662
       !

11663
       ! Check whether face DOFs have been generated by "-quad_face b: ..." or

11664
       ! "-tri_face b: ..."

11665
       !

11666
       IF (ElemFamily == 3 .OR. ElemFamily == 4) THEN

11667
         IF (Solver % Def_Dofs(6+ElemFamily, id, 5)>=0) NeedEdges = .TRUE.

11668
       ELSE

11669
         !

11670
         ! Check finally if 3-D faces are associated with face bubbles

11671
         !

11672
         IF ( ASSOCIATED( Element % FaceIndexes ) ) THEN

11673
           DO j=1,Element % TYPE % NumberOfFaces

11674
             Face => Mesh % Faces(Element % FaceIndexes(j))

11675
             face_type = Face % TYPE % ElementCode/100

11676
             k = 0

11677
             IF (ASSOCIATED(Face % BoundaryInfo % Left)) THEN

11678
               face_id  = Face % BoundaryInfo % Left % BodyId

11679
               k = MAX(0,Solver % Def_Dofs(face_type+6,face_id,5))

11680
             END IF

11681
             IF (k == 0) THEN

11682
               IF (ASSOCIATED(Face % BoundaryInfo % Right)) THEN

11683
                 face_id = Face % BoundaryInfo % Right % BodyId

11684
                 k = MAX(k,Solver % Def_Dofs(face_type+6,face_id,5))

11685
               END IF

11686
             END IF

11687
             IF (k > 0) THEN

11688
               NeedEdges = .TRUE.

11689
               EXIT

11690
             END IF

11691
           END DO

11692
         END IF

11693
       END IF

11694
     END IF

11695


11696
     IF ( .NOT. NeedEdges ) RETURN

11697


11698
     MaxFDOFs = Mesh % MaxFaceDOFs

11699
     MaxEDOFs = Mesh % MaxEdgeDOFs

11700
     EdgeIndexOffset = MaxEDOFs * Mesh % NumberOfEdges

11701
     FaceIndexOffset = MaxFDOFs * Mesh % NumberOfFaces

11702


11703
BLOCK

11704
  LOGICAL  :: EdgesDone, FacesDone

11705
  TYPE(Element_t), POINTER :: Edge

11706


11707
       EdgesDone = .FALSE.

11708
       FacesDone = .FALSE.

11709


11710
       IF ( ASSOCIATED(Element % EdgeIndexes) ) THEN

11711
         EdgesDone = .TRUE.

11712
         DO j=1,Element % TYPE % NumberOfEdges

11713
           Edge => Mesh % Edges( Element % EdgeIndexes(j) )

11714
           IF( Edge % Type % ElementCode == Element % Type % ElementCode) THEN

11715
             IF ( .NOT. (Solver % GlobalBubbles .AND. &

11716
                   Element % BodyId>0.AND.ASSOCIATED(Element % BoundaryInfo)) ) THEN

11717
               EdgesDone = .FALSE.

11718
               CYCLE

11719
             END IF

11720
           END IF

11721


11722
           EDOFs = 0

11723
           IF (Solver % Def_Dofs(ElemFamily,id,2) >= 0) THEN

11724
             EDOFs = Solver % Def_Dofs(ElemFamily,id,2)

11725
           ELSE IF (Solver % Def_Dofs(ElemFamily,id,6) > 1) THEN

11726
! TO DO: This is not yet perfect when p varies over mesh; cf. what is done in InitialPermutation

11727
             EDOFs = getEdgeDOFs(Element, Solver % Def_Dofs(ElemFamily,id,6))

11728
           END IF

11729


11730
           DO i=1,EDOFs

11731
             nd = nd + 1

11732
             Indexes(nd) = MaxEDOFs*(Element % EdgeIndexes(j)-1) + &

11733
                 i + NodalIndexOffset

11734
           END DO

11735
         END DO

11736
       END IF

11737


11738
       IF ( ASSOCIATED(Element % FaceIndexes) ) THEN

11739
         FacesDone = .TRUE.

11740
         DO j=1,Element % TYPE % NumberOfFaces

11741
           Face => Mesh % Faces( Element % FaceIndexes(j) )

11742


11743
           IF (Face % Type % ElementCode == Element % Type % ElementCode) THEN

11744
             IF ( .NOT. (Solver % GlobalBubbles .AND. &

11745
                 Element % BodyId>0.AND.ASSOCIATED(Element % BoundaryInfo)) ) THEN

11746
               FacesDone = .FALSE.

11747
               CYCLE

11748
             END IF

11749
           END IF

11750


11751
           k = MAX(0,Solver % Def_Dofs(ElemFamily,id,3))

11752
           IF (k == 0) THEN

11753
             !

11754
             ! NOTE: This depends on what face dofs have been introduced

11755
             ! by using the construct "-quad_face b: ..." and

11756
             ! "-tri_face b: ..."

11757
             !

11758
             face_type = Face % TYPE % ElementCode/100

11759
             IF (ASSOCIATED(Face % BoundaryInfo % Left)) THEN

11760
               face_id  = Face % BoundaryInfo % Left % BodyId

11761
               k = MAX(0,Solver % Def_Dofs(face_type+6,face_id,5))

11762
             END IF

11763
             IF (k == 0) THEN

11764
               IF (ASSOCIATED(Face % BoundaryInfo % Right)) THEN

11765
                 face_id = Face % BoundaryInfo % Right % BodyId

11766
                 k = MAX(k,Solver % Def_Dofs(face_type+6,face_id,5))

11767
               END IF

11768
             END IF

11769
           END IF

11770


11771
           FDOFs = 0

11772
           IF (k > 0) THEN

11773
             FDOFs = k

11774
           ELSE IF (Solver % Def_Dofs(ElemFamily,id,6) > 1) THEN

11775
! TO DO: This is not yet perfect when p varies over mesh; cf. what is done in InitialPermutation

11776
             FDOFs = getFaceDOFs(Element,Solver % Def_Dofs(ElemFamily,id,6),j,Face)

11777
           END IF

11778


11779
           DO i=1,FDOFs

11780
             nd = nd + 1

11781
             Indexes(nd) = MaxFDOFs*(Element % FaceIndexes(j)-1) + i + &

11782
                 NodalIndexOffset + EdgeIndexOffset

11783
           END DO

11784
         END DO

11785
       END IF

11786


11787
     IF ( ASSOCIATED(Element % BoundaryInfo) ) THEN

11788


11789
       IF (isActivePelement(Element, Solver)) THEN

11790
         Parent => Element % pDefs % LocalParent

11791
       ELSE

11792
         Parent => Element % BoundaryInfo % Left

11793
         IF (.NOT.ASSOCIATED(Parent) ) &

11794
             Parent => Element % BoundaryInfo % Right

11795
       END IF

11796
       IF (.NOT.ASSOCIATED(Parent) ) RETURN

11797
       ParentFamily = Parent % TYPE % ElementCode / 100

11798


11799
       SELECT CASE(ElemFamily)

11800
       CASE(2)

11801
         IF ( .NOT. EdgesDone .AND. ASSOCIATED(Parent % EdgeIndexes) ) THEN

11802
           IF ( isActivePElement(Element, Solver) ) THEN

11803
             Ind=Element % PDefs % LocalNumber

11804
           ELSE

11805
             DO Ind=1,Parent % TYPE % NumberOfEdges

11806
               Edge => Mesh % Edges(Parent % EdgeIndexes(ind))

11807
               k = 0

11808
               DO i=1,Edge % TYPE % NumberOfNodes

11809
                 DO j=1,Element % TYPE % NumberOfNodes

11810
                   IF ( Edge % NodeIndexes(i)==Element % NodeIndexes(j) ) k=k+1

11811
                 END DO

11812
               END DO

11813
               IF ( k==Element % TYPE % NumberOfNodes) EXIT

11814
             END DO

11815
           END IF

11816


11817
           EDOFs = 0

11818
           IF (Solver % Def_Dofs(ElemFamily,id,2) >= 0) THEN

11819
             EDOFs = Solver % Def_Dofs(ElemFamily,id,2)

11820
           ELSE IF (Solver % Def_Dofs(ElemFamily,id,6) > 1) THEN

11821
             EDOFs = getEdgeDOFs(Parent, Solver % Def_Dofs(ParentFamily,id,6))

11822
           END IF

11823


11824
           DO i=1,EDOFs

11825
             nd = nd + 1

11826
             Indexes(nd) = MaxEDOFs*(Parent % EdgeIndexes(Ind)-1) + &

11827
                 i + NodalIndexOffset

11828
           END DO

11829
         END IF

11830


11831
       CASE(3,4)

11832
         IF ( .NOT. FacesDone .AND. ASSOCIATED( Parent % FaceIndexes ) ) THEN

11833


11834
           IF ( isActivePElement(Element, Solver) ) THEN

11835
             Ind=Element % PDefs % LocalNumber

11836
           ELSE

11837
             DO Ind=1,Parent % TYPE % NumberOfFaces

11838
               Face => Mesh % Faces(Parent % FaceIndexes(ind))

11839
               k = 0

11840
               DO i=1,Face % TYPE % NumberOfNodes

11841
                 DO j=1,Element % TYPE % NumberOfNodes

11842
                   IF ( Face % NodeIndexes(i)==Element % NodeIndexes(j)) k=k+1

11843
                 END DO

11844
               END DO

11845
               IF ( k==Face % TYPE % NumberOfNodes) EXIT

11846
             END DO

11847
           END IF

11848


11849
           IF (Ind >= 1 .AND. Ind <= Parent % Type % NumberOfFaces) THEN

11850


11851
             IF (ASSOCIATED(Element % FaceIndexes).AND. isActivePelement(Element, Solver) ) THEN

11852
               Face => Mesh % Faces(Element % PDefs % localParent % Faceindexes(Ind))

11853
             ELSE

11854
               Face => Element

11855
             END IF

11856


11857
             IF (.NOT.EdgesDone .AND. ASSOCIATED(Face % EdgeIndexes)) THEN

11858
               DO j=1,Face % TYPE % NumberOFEdges

11859
                 Edge => Mesh % Edges(Face % EdgeIndexes(j))

11860


11861
                 EDOFs = 0

11862
                 IF (Solver % Def_Dofs(ElemFamily,id,2) >= 0) THEN

11863
                   EDOFs = Solver % Def_Dofs(ElemFamily,id,2)

11864
                 ELSE IF (Solver % Def_Dofs(ElemFamily,id,6) > 1) THEN

11865
! TO DO: This is not yet perfect when p varies over mesh; cf. what is done in InitialPermutation

11866
                   EDOFs = getEdgeDOFs(Element, Solver % Def_Dofs(ElemFamily,id,6))

11867
                 END IF

11868


11869
                 DO i=1,EDOFs

11870
                   nd = nd + 1

11871
                   Indexes(nd) = MaxEDOFs*(Face % EdgeIndexes(j)-1) + &

11872
                       i + NodalIndexOffset                   

11873
                 END DO

11874
               END DO

11875
             END IF

11876
             

11877
             FDOFs = 0

11878
             IF (Solver % Def_Dofs(ParentFamily,id,6) > 1) THEN

11879
               FDOFs = getFaceDOFs(Parent,Solver % Def_Dofs(ParentFamily,id,6),Ind,Face)

11880
             ELSE

11881
               k = MAX(0,Solver % Def_Dofs(ElemFamily,id,3))

11882
               IF (k == 0) THEN

11883
                 !

11884
                 ! NOTE: This depends on what dofs have been introduced

11885
                 ! by using the construct "-quad_face b: ..." and

11886
                 ! "-tri_face b: ..."

11887
                 !

11888
                 face_type = Face % TYPE % ElementCode/100

11889
                 IF (ASSOCIATED(Face % BoundaryInfo % Left)) THEN

11890
                   face_id  = Face % BoundaryInfo % Left % BodyId

11891
                   k = MAX(0,Solver % Def_Dofs(face_type+6,face_id,5))

11892
                 END IF

11893
                 IF (k == 0) THEN

11894
                   IF (ASSOCIATED(Face % BoundaryInfo % Right)) THEN

11895
                     face_id = Face % BoundaryInfo % Right % BodyId

11896
                     k = MAX(k,Solver % Def_Dofs(face_type+6,face_id,5))

11897
                   END IF

11898
                 END IF

11899
               END IF

11900


11901
               IF (k > 0) THEN

11902
                 FDOFs = k

11903
               END IF

11904
             END IF

11905


11906
             DO i=1,FDOFs

11907
               nd = nd + 1

11908
               Indexes(nd) = MaxFDOFs*(Parent % FaceIndexes(Ind)-1) + i + &

11909
                   NodalIndexOffset + EdgeIndexOffset

11910
             END DO

11911
           END IF

11912
         END IF

11913
       END SELECT

11914
     ELSE

11915
       IF (ASSOCIATED(Element % BubbleIndexes) .AND. Solver % GlobalBubbles) THEN

11916
         BDOFs = 0

11917
         nb = Solver % Def_Dofs(ElemFamily,id,5)

11918
         p = Solver % Def_Dofs(ElemFamily,id,6)

11919
         IF (nb >= 0 .OR. p >= 1) THEN

11920
           IF (p > 1) BDOFs = GetBubbleDOFs(Element, p)

11921
           BDOFs = MAX(nb, BDOFs)

11922
         ELSE

11923
           IF (ASSOCIATED(Solver % Values)) THEN

11924
             Bubbles = ListGetLogical(Solver % Values, 'Bubbles', Found )

11925
             ! The following is not a right way to obtain the bubble count

11926
             ! in order to support solverwise definitions

11927
             IF (Bubbles) BDOFs = SIZE(Element % BubbleIndexes)

11928
           END IF

11929
         END IF

11930
         DO i=1,BDOFs

11931
           nd = nd + 1

11932
           Indexes(nd) = NodalIndexOffset + EdgeIndexOffset + FaceIndexOffset + &

11933
               Element % BubbleIndexes(i)

11934
         END DO

11935
       END IF

11936
     END IF

11937
   END BLOCK

11938


11939
!------------------------------------------------------------------------------

11940
  END FUNCTION mGetElementDOFs

11941
!------------------------------------------------------------------------------

11942


11943
#ifdef HAVE_QP

11944
!------------------------------------------------------------------------------

11945
!>    Check element by comparing determinants of the metric tensor computed

11946
!>    in double and quad precision.

11947
!------------------------------------------------------------------------------

11948
   FUNCTION CheckMetric(nDOFs,Elm,Nodes,dLBasisdx) RESULT(Success)

11949
!------------------------------------------------------------------------------

11950
     INTEGER :: nDOFs                !< Number of active nodes in element

11951
     TYPE(Element_t)  :: Elm         !< Element structure

11952
     TYPE(Nodes_t)    :: Nodes       !< Element nodal coordinates

11953
     REAL(KIND=dp) :: dLBasisdx(:,:) !< Derivatives of element basis function with respect to local coordinates

11954
     LOGICAL :: Success              !< Returns .FALSE. if element is degenerate

11955
!------------------------------------------------------------------------------

11956
!    Local variables

11957
!------------------------------------------------------------------------------

11958
     INTEGER :: GeomId     

11959
     INTEGER :: cdim,dim,i,j,k,n,imin,jmin

11960
     REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z

11961


11962
     INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(24)     

11963


11964
     REAL(KIND=dp) :: dp_dx(3,3),dp_G(3,3),dp_GI(3,3),dp_s, dp_DetG

11965
     REAL(KIND=qp) :: qp_dx(3,3),qp_G(3,3),qp_GI(3,3),qp_s, qp_DetG, eps

11966
!------------------------------------------------------------------------------

11967
     success = .TRUE.

11968


11969
     x => Nodes % x

11970
     y => Nodes % y

11971
     z => Nodes % z

11972


11973
     cdim = CoordinateSystemDimension()

11974
     n = MIN( SIZE(x), nDOFs )

11975
     dim  = elm % TYPE % DIMENSION

11976


11977
     eps = 1.0d-6

11978
!------------------------------------------------------------------------------

11979
!    Partial derivatives of global coordinates with respect to local coordinates

11980
!------------------------------------------------------------------------------

11981
     DO i=1,dim

11982
       dp_dx(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) )

11983
       dp_dx(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) )

11984
       dp_dx(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) )

11985


11986
       qp_dx(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) )

11987
       qp_dx(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) )

11988
       qp_dx(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) )

11989
     END DO

11990
!------------------------------------------------------------------------------

11991
!    Compute the covariant metric tensor of the element coordinate system

11992
!------------------------------------------------------------------------------

11993
     DO i=1,dim

11994
       DO j=1,dim

11995
         dp_s = 0.0_dp

11996
         qp_s = 0.0_dp

11997
         DO k=1,cdim

11998
           dp_s = dp_s + dp_dx(k,i)*dp_dx(k,j)

11999
           qp_s = qp_s + qp_dx(k,i)*qp_dx(k,j)

12000
         END DO

12001
         dp_G(i,j) = dp_s

12002
         qp_G(i,j) = qp_s

12003
       END DO

12004
     END DO

12005


12006
!------------------------------------------------------------------------------

12007
!    Convert the metric to contravariant base, and compute the SQRT(DetG)

12008
!------------------------------------------------------------------------------

12009
     SELECT CASE( dim )

12010
!------------------------------------------------------------------------------

12011
!      Line elements

12012
!------------------------------------------------------------------------------

12013
     CASE (1)

12014
       dp_DetG  = dp_G(1,1)

12015
       qp_DetG  = qp_G(1,1)

12016


12017
!------------------------------------------------------------------------------

12018
!      Surface elements

12019
!------------------------------------------------------------------------------

12020
     CASE (2)

12021
       dp_DetG = ( dp_G(1,1)*dp_G(2,2) - dp_G(1,2)*dp_G(2,1) )

12022
       qp_DetG = ( qp_G(1,1)*qp_G(2,2) - qp_G(1,2)*qp_G(2,1) )

12023


12024
!------------------------------------------------------------------------------

12025
!      Volume elements

12026
!------------------------------------------------------------------------------

12027
     CASE (3)

12028
       dp_DetG = dp_G(1,1) * ( dp_G(2,2)*dp_G(3,3) - dp_G(2,3)*dp_G(3,2) ) + &

12029
           dp_G(1,2) * ( dp_G(2,3)*dp_G(3,1) - dp_G(2,1)*dp_G(3,3) ) + &

12030
           dp_G(1,3) * ( dp_G(2,1)*dp_G(3,2) - dp_G(2,2)*dp_G(3,1) )

12031


12032
       qp_DetG = qp_G(1,1) * ( qp_G(2,2)*qp_G(3,3) - qp_G(2,3)*qp_G(3,2) ) + &

12033
           qp_G(1,2) * ( qp_G(2,3)*qp_G(3,1) - qp_G(2,1)*qp_G(3,3) ) + &

12034
           qp_G(1,3) * ( qp_G(2,1)*qp_G(3,2) - qp_G(2,2)*qp_G(3,1) )

12035
     END SELECT

12036
     

12037
     Success = ABS(dp_detG-qp_detG) <= eps*ABS(qp_DetG)

12038
!------------------------------------------------------------------------------

12039
   END FUNCTION CheckMetric

12040
!------------------------------------------------------------------------------

12041
#endif

12042
   

12043
!------------------------------------------------------------------------------

12044
!>    Compute contravariant metric tensor (=J^TJ)^-1 of element coordinate

12045
!>    system, and square root of determinant of covariant metric tensor

12046
!>    (=sqrt(det(J^TJ)))

12047
!------------------------------------------------------------------------------

12048
   FUNCTION ElementMetric(nDOFs,Elm,Nodes,Metric,DetG,dLBasisdx,LtoGMap) RESULT(Success)

12049
!------------------------------------------------------------------------------

12050
     INTEGER :: nDOFs                !< Number of active nodes in element

12051
     TYPE(Element_t)  :: Elm         !< Element structure

12052
     TYPE(Nodes_t)    :: Nodes       !< Element nodal coordinates

12053
     REAL(KIND=dp) :: Metric(:,:)    !< Contravariant metric tensor

12054
     REAL(KIND=dp) :: dLBasisdx(:,:) !< Derivatives of element basis function with respect to local coordinates

12055
     REAL(KIND=dp) :: DetG           !< SQRT of determinant of metric tensor

12056
     REAL(KIND=dp) :: LtoGMap(3,3)   !< Transformation to obtain the referential description of the spatial gradient

12057
     LOGICAL :: Success              !< Returns .FALSE. if element is degenerate

12058
!------------------------------------------------------------------------------

12059
!    Local variables

12060
!------------------------------------------------------------------------------

12061
     REAL(KIND=dp) :: dx(3,3),G(3,3),GI(3,3),s,smin,eps=0

12062
     REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z

12063
     INTEGER :: GeomId     

12064
     INTEGER :: cdim,dim,i,j,k,n,imin,jmin

12065
!------------------------------------------------------------------------------

12066
     success = .TRUE.

12067


12068
     x => Nodes % x

12069
     y => Nodes % y

12070
     z => Nodes % z

12071


12072
     cdim = CoordinateSystemDimension()

12073
     n = MIN( SIZE(x), nDOFs )

12074
     dim  = elm % TYPE % DIMENSION

12075


12076
#ifdef HAVE_QP

12077
     IF(Elm % Status == 2) THEN

12078
       IF (ElementMetricQP(nDOFs,Elm,Nodes,Metric,DetG,dLBasisdx,LtoGMap)) RETURN

12079
       GOTO 100

12080
     END IF

12081
#endif

12082


12083
     eps = (EPSILON(eps))**dim

12084
!------------------------------------------------------------------------------

12085
!    Partial derivatives of global coordinates with respect to local coordinates

12086
!------------------------------------------------------------------------------

12087
     DO i=1,dim

12088
       dx(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) )

12089
       dx(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) )

12090
       dx(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) )

12091
     END DO

12092
!------------------------------------------------------------------------------

12093
!    Compute the covariant metric tensor of the element coordinate system

12094
!------------------------------------------------------------------------------

12095
     DO i=1,dim

12096
       DO j=1,dim

12097
         s = 0.0_dp

12098
         DO k=1,cdim

12099
           s = s + dx(k,i)*dx(k,j)

12100
         END DO

12101
         G(i,j) = s

12102
       END DO

12103
     END DO

12104
!------------------------------------------------------------------------------

12105
!    Convert the metric to contravariant base, and compute the SQRT(DetG)

12106
!------------------------------------------------------------------------------

12107
     SELECT CASE( dim )

12108
!------------------------------------------------------------------------------

12109
!      Line elements

12110
!------------------------------------------------------------------------------

12111
     CASE (1)

12112
       DetG  = G(1,1)

12113


12114
       IF ( DetG <= eps ) GOTO 100

12115


12116
       Metric(1,1) = 1.0d0 / DetG

12117
       DetG  = SQRT( DetG )

12118


12119
!------------------------------------------------------------------------------

12120
!      Surface elements

12121
!------------------------------------------------------------------------------

12122
     CASE (2)

12123
       DetG = ( G(1,1)*G(2,2) - G(1,2)*G(2,1) )

12124


12125
       IF ( DetG <= eps ) GOTO 100

12126


12127
       Metric(1,1) =  G(2,2) / DetG

12128
       Metric(1,2) = -G(1,2) / DetG

12129
       Metric(2,1) = -G(2,1) / DetG

12130
       Metric(2,2) =  G(1,1) / DetG

12131
       DetG = SQRT(DetG)

12132


12133
!------------------------------------------------------------------------------

12134
!      Volume elements

12135
!------------------------------------------------------------------------------

12136
     CASE (3)

12137
       DetG = G(1,1) * ( G(2,2)*G(3,3) - G(2,3)*G(3,2) ) + &

12138
           G(1,2) * ( G(2,3)*G(3,1) - G(2,1)*G(3,3) ) + &

12139
           G(1,3) * ( G(2,1)*G(3,2) - G(2,2)*G(3,1) )

12140


12141
       IF ( DetG <= eps ) GOTO 100

12142


12143
       CALL InvertMatrix3x3( G,GI,detG )

12144
       Metric = GI

12145
       DetG = SQRT(DetG)

12146
     END SELECT

12147
     

12148
!--------------------------------------------------------------------------------------

12149
!    Construct a transformation X = LtoGMap such that (grad B)(f(p)) = X(p) Grad b(p),

12150
!    with Grad the gradient with respect to the reference element coordinates p and 

12151
!    the referential description of the spatial field B(x) satisfying B(f(p)) = b(p).

12152
!    If cdim > dim (e.g. a surface embedded in the 3-dimensional space), X is

12153
!    the transpose of the pseudo-inverse of Grad f.

12154
!-------------------------------------------------------------------------------

12155
     DO i=1,cdim

12156
       DO j=1,dim

12157
         s = 0.0d0

12158
         DO k=1,dim

12159
           s = s + dx(i,k) * Metric(k,j)

12160
         END DO

12161
         LtoGMap(i,j) = s

12162
       END DO

12163
     END DO

12164


12165
     ! Return here also implies success = .TRUE.

12166
     RETURN

12167


12168
100  CONTINUE

12169


12170
#ifdef HAVE_QP

12171
     ! Try recursively with quadratic precision.

12172
     ! With just double precision for very flat elements the DetJ may be poorly evaluated. 

12173
     IF( Elm % Status /= 2) THEN

12174
       Success = ElementMetricQP(nDOFs,Elm,Nodes,Metric,DetG,dLBasisdx,LtoGMap) 

12175
       IF( Success ) RETURN

12176
     END IF

12177
#endif

12178
     

12179
     WRITE( Message,'(A,I0,A,I0)') 'Degenerate ',dim,'D element: ',Elm % ElementIndex

12180
     CALL Error( 'ElementMetric', Message )

12181
     

12182
     IF( ASSOCIATED( Elm % BoundaryInfo ) ) THEN

12183
       WRITE( Message,'(A,I0,A,ES14.6)') 'Boundary Id: ',Elm % BoundaryInfo % Constraint,' DetG:',DetG

12184
     ELSE

12185
       WRITE( Message,'(A,I0,A,ES14.6)') 'Body Id: ',Elm % BodyId,' DetG:',DetG

12186
     END IF

12187
     CALL Info( 'ElementMetric', Message, Level=3 )

12188


12189
     DO i=1,n

12190
       WRITE( Message,'(A,I0,A,3ES14.6)') 'Node: ',i,' Coord:',x(i),y(i),z(i)       

12191
       CALL Info( 'ElementMetric', Message, Level=3 )

12192
     END DO

12193


12194
     ! Find the two nodes closest to each other:

12195
     smin = HUGE(smin)

12196
     DO i=1,n

12197
       DO j=i+1,n

12198
         s = (x(i)-x(j))**2 + (y(i)-y(j))**2 + (z(i)-z(j))**2

12199
         IF( s < smin ) THEN

12200
           imin = i

12201
           jmin = j

12202
           smin = s           

12203
         END IF

12204
       END DO

12205
     END DO

12206
     smin = SQRT(smin)

12207


12208
     WRITE( Message,'(A,I0,A,I0,A,I0,A,I0,A,ES14.6)') 'Closest distance: ',imin,'-',jmin,&

12209
         ' (',Elm % NodeIndexes(imin),'-',Elm % NodeIndexes(jmin),') |dCoord|:',smin

12210
     CALL Info( 'ElementMetric', Message, Level=3 )

12211


12212
     IF ( cdim < dim ) THEN

12213
       WRITE( Message,'(A,I0,A,I0)') 'Element dim larger than meshdim: ',dim,' vs. ',cdim

12214
       CALL Info( 'ElementMetric', Message, Level=3 )

12215
     END IF

12216


12217
!------------------------------------------------------------------------------

12218
   END FUNCTION ElementMetric

12219
!------------------------------------------------------------------------------

12220


12221
#ifdef HAVE_QP

12222
!------------------------------------------------------------------------------

12223
! Quadratic precision version of the previous that is called when the DetJ appear

12224
! to be close to zero or negative. 

12225
!------------------------------------------------------------------------------

12226
   FUNCTION ElementMetricQP(nDOFs,Elm,Nodes,Metric,DetG,dLBasisdx,LtoGMap) RESULT(Success)

12227
!------------------------------------------------------------------------------

12228
     INTEGER :: nDOFs                !< Number of active nodes in element

12229
     TYPE(Element_t)  :: Elm         !< Element structure

12230
     TYPE(Nodes_t)    :: Nodes       !< Element nodal coordinates

12231
     REAL(KIND=dp) :: Metric(:,:)    !< Contravariant metric tensor

12232
     REAL(KIND=dp) :: dLBasisdx(:,:) !< Derivatives of element basis function with respect to local coordinates

12233
     REAL(KIND=dp) :: DetG           !< SQRT of determinant of metric tensor

12234
     REAL(KIND=dp) :: LtoGMap(3,3)   !< Transformation to obtain the referential description of the spatial gradient

12235
     LOGICAL :: Success              !< Returns .FALSE. if element is degenerate

12236
!------------------------------------------------------------------------------

12237
!    Local variables

12238
!------------------------------------------------------------------------------

12239
     REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z

12240
     INTEGER :: GeomId     

12241
     INTEGER :: cdim,dim,i,j,k,n

12242


12243
! Local Quadratic precision variables     

12244
     INTEGER, PARAMETER :: qp = SELECTED_REAL_KIND(24)     

12245
     REAL(KIND=qp) :: dx(3,3),G(3,3),GI(3,3),s,DetGqp

12246
!------------------------------------------------------------------------------

12247
     success = .FALSE.

12248


12249
     x => Nodes % x

12250
     y => Nodes % y

12251
     z => Nodes % z

12252


12253
     cdim = CoordinateSystemDimension()

12254
     n = MIN( SIZE(x), nDOFs )

12255
     dim  = elm % TYPE % DIMENSION

12256
     DetG = 0.0_dp

12257


12258
!------------------------------------------------------------------------------

12259
!    Partial derivatives of global coordinates with respect to local coordinates

12260
!------------------------------------------------------------------------------

12261
     DO i=1,dim

12262
       dx(1,i) = SUM( x(1:n) * dLBasisdx(1:n,i) )

12263
       dx(2,i) = SUM( y(1:n) * dLBasisdx(1:n,i) )

12264
       dx(3,i) = SUM( z(1:n) * dLBasisdx(1:n,i) )

12265
     END DO

12266
!------------------------------------------------------------------------------

12267
!    Compute the covariant metric tensor of the element coordinate system

12268
!------------------------------------------------------------------------------

12269
     DO i=1,dim

12270
       DO j=1,dim

12271
         s = 0.0d0

12272
         DO k=1,cdim

12273
           s = s + dx(k,i)*dx(k,j)

12274
         END DO

12275
         G(i,j) = s

12276
       END DO

12277
     END DO

12278
!------------------------------------------------------------------------------

12279
!    Convert the metric to contravariant base, and compute the SQRT(DetG)

12280
!------------------------------------------------------------------------------

12281
     SELECT CASE( dim )

12282
!------------------------------------------------------------------------------

12283
!      Line elements

12284
!------------------------------------------------------------------------------

12285
     CASE (1)

12286
       DetGqp  = G(1,1)

12287


12288
       IF ( DetGqp <= TINY( DetG ) ) RETURN

12289


12290
       Metric(1,1) = 1.0d0 / DetGqp

12291


12292
!------------------------------------------------------------------------------

12293
!      Surface elements

12294
!------------------------------------------------------------------------------

12295
     CASE (2)

12296
       DetGqp = ( G(1,1)*G(2,2) - G(1,2)*G(2,1) )

12297


12298
       IF ( DetGqp <= TINY( DetG ) ) RETURN

12299


12300
       Metric(1,1) =  G(2,2) / DetGqp

12301
       Metric(1,2) = -G(1,2) / DetGqp

12302
       Metric(2,1) = -G(2,1) / DetGqp

12303
       Metric(2,2) =  G(1,1) / DetGqp

12304


12305
!------------------------------------------------------------------------------

12306
!      Volume elements

12307
!------------------------------------------------------------------------------

12308
     CASE (3)

12309
       DetGqp = G(1,1) * ( G(2,2)*G(3,3) - G(2,3)*G(3,2) ) + &

12310
           G(1,2) * ( G(2,3)*G(3,1) - G(2,1)*G(3,3) ) + &

12311
           G(1,3) * ( G(2,1)*G(3,2) - G(2,2)*G(3,1) )

12312


12313
       IF ( DetGqp <= TINY( DetG ) ) RETURN

12314


12315
       CALL InvertMatrix3x3QP( G,GI,detGqp )

12316
       Metric = GI

12317
     END SELECT

12318


12319
     DetG = SQRT(DetGqp)     

12320
     Success = .TRUE.

12321
     

12322
!--------------------------------------------------------------------------------------

12323
     DO i=1,cdim

12324
       DO j=1,dim

12325
         s = 0.0d0

12326
         DO k=1,dim

12327
           s = s + dx(i,k) * Metric(k,j)

12328
         END DO

12329
         LtoGMap(i,j) = s

12330
       END DO

12331
     END DO

12332
     

12333
!------------------------------------------------------------------------------

12334
   END FUNCTION ElementMetricQP

12335
!------------------------------------------------------------------------------

12336
#endif

12337
   

12338
!------------------------------------------------------------------------------

12339
   FUNCTION ElementMetricVec( Elm, Nodes, nc, ndof, DetJ, nbmax, dLBasisdx, LtoGMap) RESULT(AllSuccess)

12340
!------------------------------------------------------------------------------

12341
     TYPE(Element_t)  :: Elm                                 !< Element structure

12342
     TYPE(Nodes_t)    :: Nodes                               !< element nodal coordinates

12343
     INTEGER, INTENT(IN) :: nc                               !< Number of points to map

12344
     INTEGER :: ndof                                         !< Number of active nodes in element

12345
     REAL(KIND=dp) :: DetJ(VECTOR_BLOCK_LENGTH)              !< SQRT of determinant of element coordinate metric at each point

12346
     INTEGER, INTENT(IN) :: nbmax                            !< Maximum total number of basis functions in local basis

12347
     REAL(KIND=dp) :: dLBasisdx(VECTOR_BLOCK_LENGTH,nbmax,3) !< Derivatives of element basis function with 

12348
                                                             !<  respect to local coordinates at each point

12349
     REAL(KIND=dp) :: LtoGMap(VECTOR_BLOCK_LENGTH,3,3)       !< Mapping between local and global coordinates

12350
     LOGICAL :: AllSuccess                  !< Returns .FALSE. if some point in element is degenerate

12351
!------------------------------------------------------------------------------

12352
!       Local variables

12353
!------------------------------------------------------------------------------

12354
     REAL(KIND=dp) :: dx(VECTOR_BLOCK_LENGTH,3,3)

12355
     REAL(KIND=dp) :: Metric(VECTOR_BLOCK_LENGTH,6), &

12356
             G(VECTOR_BLOCK_LENGTH,6)       ! Symmetric Metric(nc,3,3) and G(nc,3,3)

12357


12358
     REAL(KIND=dp) :: s

12359
     INTEGER :: cdim,dim,i,j,k,l,n,ip, jj, kk

12360
     INTEGER :: ldbasis, ldxyz, utind

12361
!DIR$ ATTRIBUTES ALIGN:64::Metric

12362
!DIR$ ATTRIBUTES ALIGN:64::dx

12363
!DIR$ ATTRIBUTES ALIGN:64::G

12364
!DIR$ ASSUME_ALIGNED dLBasisdx:64, LtoGMap:64, DetJ:64

12365
     !------------------------------------------------------------------------------

12366
     AllSuccess = .TRUE.

12367


12368
     ! Coordinates (single array)

12369
     n = MIN( SIZE(Nodes % x, 1), ndof )

12370


12371
     ! Dimensions (coordinate system and element)

12372
     cdim = CoordinateSystemDimension()

12373
     dim  = elm % TYPE % DIMENSION

12374


12375
     ! Leading dimensions for local basis and coordinate arrays

12376
     ldbasis = SIZE(dLBasisdx, 1)

12377
     ldxyz = SIZE(Nodes % xyz, 1)

12378


12379
     ! For linear, extruded and otherwise regular elements mapping has to be computed

12380
     ! only once, the problem is to identify these cases...

12381
     !------------------------------------------------------------------------------

12382
     !       Partial derivatives of global coordinates with respect to local coordinates

12383
     !------------------------------------------------------------------------------

12384
     ! Avoid DGEMM calls for nc small

12385
     IF (nc < VECTOR_SMALL_THRESH) THEN

12386
       DO l=1,dim

12387
         DO j=1,3

12388
           dx(1:nc,j,l)=REAL(0,dp)

12389
           DO k=1,n

12390
!DIR$ UNROLL

12391
             DO i=1,nc

12392
               dx(i,j,l)=dx(i,j,l)+dLBasisdx(i,k,l)*Nodes % xyz(k,j)

12393
             END DO

12394
           END DO

12395
         END DO

12396
       END DO

12397
     ELSE

12398
       DO i=1,dim

12399
         CALL DGEMM('N','N',nc, 3, n, &

12400
                 REAL(1,dp), dLbasisdx(1,1,i), ldbasis, &

12401
                 Nodes % xyz, ldxyz, REAL(0, dp), dx(1,1,i), VECTOR_BLOCK_LENGTH)

12402
       END DO

12403
     END IF

12404
     !------------------------------------------------------------------------------

12405
     !       Compute the covariant metric tensor of the element coordinate system (symmetric)

12406
     !------------------------------------------------------------------------------

12407
     ! Linearized upper triangular indices for accesses to G

12408
     ! | (1,1) (1,2) (1,3) | = | 1 2 4 |

12409
     ! |       (2,2) (2,3) |   |   3 5 |

12410
     ! |             (3,3) |   |     6 |

12411
     ! G is symmetric, compute only the upper triangular part of G=dx^Tdx

12412
!DIR$ LOOP COUNT MAX=3

12413
     DO j=1,dim

12414
!DIR$ LOOP COUNT MAX=3

12415
       DO i=1,j

12416
!DIR$ INLINE

12417
         utind = GetSymmetricIndex(i,j)

12418
         SELECT CASE (cdim)

12419
         CASE(1)

12420
           !_ELMER_OMP_SIMD

12421
           DO l=1,nc

12422
             G(l,utind)=dx(l,1,i)*dx(l,1,j)

12423
           END DO

12424
         CASE(2)

12425
           !_ELMER_OMP_SIMD

12426
           DO l=1,nc

12427
             G(l,utind)=dx(l,1,i)*dx(l,1,j)+dx(l,2,i)*dx(l,2,j)

12428
           END DO

12429
         CASE(3)

12430
           !_ELMER_OMP_SIMD

12431
           DO l=1,nc

12432
             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)

12433
           END DO

12434
         END SELECT

12435
       END DO

12436
     END DO

12437


12438
     !------------------------------------------------------------------------------

12439
     !       Convert the metric to contravariant base, and compute the SQRT(DetG)

12440
     !------------------------------------------------------------------------------

12441
     SELECT CASE( dim )

12442
       !------------------------------------------------------------------------------

12443
       !       Line elements

12444
       !------------------------------------------------------------------------------

12445
     CASE (1)

12446
       ! Determinants

12447
       ! DetJ(1:nc)  = G(1:nc,1,1)

12448
       DetJ(1:nc)  = G(1:nc,1)

12449


12450
       DO i=1,nc

12451
         IF (DetJ(i) <= TINY(REAL(1,dp))) THEN

12452
           AllSuccess = .FALSE.

12453
           EXIT

12454
         END IF

12455
       END DO

12456


12457
       IF (AllSuccess) THEN

12458
         !_ELMER_OMP_SIMD

12459
         DO i=1,nc

12460
           ! Metric(i,1,1) = REAL(1,dp)/DetJ(i)

12461
           Metric(i,1) = REAL(1,dp)/DetJ(i)

12462
         END DO

12463
         !_ELMER_OMP_SIMD

12464
         DO i=1,nc

12465
           DetJ(i) = SQRT( DetJ(i))

12466
         END DO

12467
       END IF

12468


12469


12470
       !------------------------------------------------------------------------------

12471
       !       Surface elements

12472
       !------------------------------------------------------------------------------

12473
     CASE (2)

12474
       ! Determinants

12475
       !_ELMER_OMP_SIMD

12476
       DO i=1,nc

12477
         ! DetJ(i) = ( G(i,1,1)*G(i,2,2) - G(i,1,2)*G(i,2,1) )

12478
         ! G is symmetric

12479
         DetJ(i) = G(i,1)*G(i,3)-G(i,2)*G(i,2)

12480
       END DO

12481


12482
       DO i=1,nc

12483
         IF (DetJ(i) <= TINY(REAL(1,dp))) THEN

12484
           AllSuccess = .FALSE.

12485
           EXIT

12486
         END IF

12487
       END DO

12488


12489
       IF (AllSuccess) THEN

12490
         ! Since G=G^T, it holds G^{-1}=(G^T)^{-1}

12491
         !_ELMER_OMP_SIMD

12492
         DO i=1,nc

12493
           s = REAL(1,dp)/DetJ(i)

12494
           ! G is symmetric

12495
           ! All in one go, with redundancies eliminated

12496
           Metric(i,1) =  s*G(i,3)

12497
           Metric(i,2) = -s*G(i,2)

12498
           Metric(i,3) =  s*G(i,1)

12499
         END DO

12500
         !_ELMER_OMP_SIMD

12501
         DO i=1,nc

12502
           DetJ(i) = SQRT(DetJ(i))

12503
         END DO

12504


12505
       END IF

12506
       !------------------------------------------------------------------------------

12507
       !       Volume elements

12508
       !------------------------------------------------------------------------------

12509
     CASE (3)

12510
       ! Determinants

12511
       !_ELMER_OMP_SIMD

12512
       DO i=1,nc

12513
         ! DetJ(i) = G(i,1,1) * ( G(i,2,2)*G(i,3,3) - G(i,2,3)*G(i,3,2) ) + &

12514
         !           G(i,1,2) * ( G(i,2,3)*G(i,3,1) - G(i,2,1)*G(i,3,3) ) + &

12515
         !           G(i,1,3) * ( G(i,2,1)*G(i,3,2) - G(i,2,2)*G(i,3,1) )

12516
         ! G is symmetric

12517
         DetJ(i) = G(i,1)*(G(i,3)*G(i,6)-G(i,5)*G(i,5)) + &

12518
                 G(i,2)*(G(i,5)*G(i,4)-G(i,2)*G(i,6)) + &

12519
                 G(i,4)*(G(i,2)*G(i,5)-G(i,3)*G(i,4))

12520
       END DO

12521


12522
       DO i=1,nc

12523
         IF (DetJ(i) <= TINY(REAL(1,dp))) THEN

12524
           AllSuccess = .FALSE.

12525
           EXIT

12526
         END IF

12527
       END DO

12528


12529
       IF (AllSuccess) THEN

12530
         ! Since G=G^T, it holds G^{-1}=(G^T)^{-1}

12531
         !_ELMER_OMP_SIMD

12532
         DO i=1,nc

12533
           s = REAL(1,dp) / DetJ(i)

12534
           ! Metric(i,1,1) =  s * (G(i,2,2)*G(i,3,3) - G(i,3,2)*G(i,2,3))

12535
           ! Metric(i,2,1) = -s * (G(i,2,1)*G(i,3,3) - G(i,3,1)*G(i,2,3))

12536
           ! Metric(i,3,1) =  s * (G(i,2,1)*G(i,3,2) - G(i,3,1)*G(i,2,2))

12537
           ! G is symmetric

12538


12539
           ! All in one go, with redundancies eliminated

12540
           Metric(i,1)= s*(G(i,3)*G(i,6)-G(i,5)*G(i,5))

12541
           Metric(i,2)=-s*(G(i,2)*G(i,6)-G(i,4)*G(i,5))

12542
           Metric(i,3)= s*(G(i,1)*G(i,6)-G(i,4)*G(i,4))

12543
           Metric(i,4)= s*(G(i,2)*G(i,5)-G(i,3)*G(i,4))

12544
           Metric(i,5)=-s*(G(i,1)*G(i,5)-G(i,2)*G(i,4))

12545
           Metric(i,6)= s*(G(i,1)*G(i,3)-G(i,2)*G(i,2))

12546
         END DO

12547


12548
         !_ELMER_OMP_SIMD

12549
         DO i=1,nc

12550
           DetJ(i) = SQRT(DetJ(i))

12551
         END DO

12552


12553
       END IF

12554
     END SELECT

12555


12556
     IF (AllSuccess) THEN

12557
       SELECT CASE(dim)

12558
       CASE(1)

12559
!DIR$ LOOP COUNT MAX=3

12560
         DO i=1,cdim

12561
           !_ELMER_OMP_SIMD

12562
           DO l=1,nc

12563
             LtoGMap(l,i,1) = dx(l,i,1)*Metric(l,1)

12564
           END DO

12565
         END DO

12566
       CASE(2)

12567
!DIR$ LOOP COUNT MAX=3

12568
         DO i=1,cdim

12569
           !_ELMER_OMP_SIMD

12570
           DO l=1,nc

12571
             LtoGMap(l,i,1) = dx(l,i,1)*Metric(l,1) + dx(l,i,2)*Metric(l,2)

12572
             LtoGMap(l,i,2) = dx(l,i,1)*Metric(l,2) + dx(l,i,2)*Metric(l,3)

12573
           END DO

12574
         END DO

12575
       CASE(3)

12576
!DIR$ LOOP COUNT MAX=3

12577
         DO i=1,cdim

12578
           !_ELMER_OMP_SIMD

12579
           DO l=1,nc

12580
             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)

12581
             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)

12582
             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)

12583
           END DO

12584
         END DO

12585
       END SELECT

12586
     ELSE

12587


12588
       ! Degenerate element!

12589
       WRITE( Message,'(A,I0,A,I0,A,I0)') 'Degenerate ',dim,'D element: ',Elm % ElementIndex, ', pt=', i

12590
       CALL Error( 'ElementMetricVec', Message )

12591
       WRITE( Message,'(A,G10.3)') 'DetG:',DetJ(i)

12592
       CALL Info( 'ElementMetricVec', Message, Level=3 )

12593
       DO i=1,cdim

12594
         WRITE( Message,'(A,I0,A,3G10.3)') 'Dir: ',i,' Coord:',Nodes % xyz(i,1),&

12595
                 Nodes % xyz(i,2), Nodes % xyz(i,3)

12596
         CALL Info( 'ElementMetricVec', Message, Level=3 )

12597
       END DO

12598
       IF (cdim < dim) THEN

12599
         WRITE( Message,'(A,I0,A,I0)') 'Element dim larger than meshdim: ',dim,' vs. ',cdim

12600
         CALL Info( 'ElementMetricVec', Message, Level=3 )

12601
       END IF

12602
     END IF

12603


12604
   CONTAINS

12605


12606
     FUNCTION GetSymmetricIndex(i,j) RESULT(utind)

12607
       IMPLICIT NONE

12608
       INTEGER, INTENT(IN) :: i, j

12609
       INTEGER :: utind

12610


12611
       IF (i>j) THEN

12612
         utind = i*(i-1)/2+j

12613
       ELSE

12614
         utind = j*(j-1)/2+i

12615
       END IF

12616
     END FUNCTION GetSymmetricIndex

12617
!------------------------------------------------------------------------------

12618
   END FUNCTION ElementMetricVec

12619
!------------------------------------------------------------------------------

12620


12621


12622


12623
!------------------------------------------------------------------------------

12624
!>    Given element structure return value of the first partial derivatives with

12625
!>    respect to global coordinates of a quantity x given at element nodes at

12626
!>    local coordinate point u,v,w inside the element. Element basis functions

12627
!>    are used to compute the value. This is internal version, and shouldn't

12628
!>    usually be called directly by the user, but through the wrapper routine

12629
!>    GlobalFirstDerivatives.

12630
!------------------------------------------------------------------------------

12631
   SUBROUTINE GlobalFirstDerivativesInternal( elm,nodes,df,gx,gy,gz, &

12632
                       Metric,dLBasisdx )

12633
!------------------------------------------------------------------------------

12634
!

12635
!  ARGUMENTS:

12636
!    Type(Element_t) :: element

12637
!      INPUT: element structure

12638
!

12639
!    Type(Nodes_t) :: nodes

12640
!      INPUT: element nodal coordinate arrays

12641
!     

12642
!     REAL(KIND=dp) :: f(:)

12643
!      INPUT: Nodal values of the quantity whose partial derivative we want to know

12644
!

12645
!     REAL(KIND=dp) :: gx = @f(u,v)/@x, gy = @f(u,v)/@y, gz = @f(u,v)/@z

12646
!      OUTPUT: Values of the partial derivatives

12647
!

12648
!     REAL(KIND=dp) :: Metric(:,:)

12649
!      INPUT: Contravariant metric tensor of the element coordinate system

12650
!

12651
!     REAL(KIND=dp), OPTIONAL :: dLBasisdx(:,:)

12652
!      INPUT: Values of partial derivatives with respect to local coordinates

12653
!

12654
!   FUNCTION VALUE:

12655
!      .TRUE. if element is ok, .FALSE. if degenerated

12656
!

12657
!------------------------------------------------------------------------------

12658
   !

12659
   ! Return value of first derivatives of a quantity f in global

12660
   ! coordinates at point (u,v) in gx,gy and gz.

12661
   !

12662
     TYPE(Element_t) :: elm

12663
     TYPE(Nodes_t) :: nodes

12664
 

12665
     REAL(KIND=dp) :: df(:),Metric(:,:)

12666
     REAL(KIND=dp) :: gx,gy,gz

12667
     REAL(KIND=dp) :: dLBasisdx(:,:)

12668


12669
!------------------------------------------------------------------------------

12670
!    Local variables

12671
!------------------------------------------------------------------------------

12672


12673
     REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z

12674
     REAL(KIND=dp) :: dx(3,3),dfc(3),s

12675


12676
     INTEGER :: cdim,dim,i,j,n,NB

12677
!------------------------------------------------------------------------------

12678


12679
     n    = elm % TYPE % NumberOfNodes

12680
     dim  = elm % TYPE % DIMENSION

12681
     cdim = CoordinateSystemDimension()

12682


12683
     x => nodes % x

12684
     y => nodes % y

12685
     z => nodes % z

12686
!------------------------------------------------------------------------------

12687
!    Partial derivatives of global coordinates with respect to local, and

12688
!    partial derivatives of the quantity given, also with respect to local

12689
!    coordinates

12690
!------------------------------------------------------------------------------

12691
     SELECT CASE(cdim)

12692
       CASE(1)

12693
         DO i=1,dim

12694
            dx(1,i) = SUM( x(1:n)*dLBasisdx(1:n,i) )

12695
         END DO

12696


12697
       CASE(2)

12698
         DO i=1,dim

12699
            dx(1,i) = SUM( x(1:n)*dLBasisdx(1:n,i) )

12700
            dx(2,i) = SUM( y(1:n)*dLBasisdx(1:n,i) )

12701
         END DO

12702


12703
       CASE(3)

12704
         DO i=1,dim

12705
            dx(1,i) = SUM( x(1:n)*dLBasisdx(1:n,i) )

12706
            dx(2,i) = SUM( y(1:n)*dLBasisdx(1:n,i) )

12707
            dx(3,i) = SUM( z(1:n)*dLBasisdx(1:n,i) )

12708
         END DO

12709
     END SELECT

12710
!------------------------------------------------------------------------------

12711
!    Contravariant components of partials in element coordinates

12712
!------------------------------------------------------------------------------

12713
     DO i=1,dim

12714
       s = 0.0d0

12715
       DO j=1,dim

12716
         s = s + Metric(i,j) * df(j)

12717
       END DO

12718
       dfc(i) = s

12719
     END DO

12720
!------------------------------------------------------------------------------

12721
!    Transform partials to space coordinates

12722
!------------------------------------------------------------------------------

12723
     gx = 0.0d0

12724
     gy = 0.0d0

12725
     gz = 0.0d0

12726
     SELECT CASE(cdim)

12727
       CASE(1)

12728
         gx = SUM( dx(1,1:dim) * dfc(1:dim) )

12729


12730
       CASE(2)

12731
         gx = SUM( dx(1,1:dim) * dfc(1:dim) )

12732
         gy = SUM( dx(2,1:dim) * dfc(1:dim) )

12733


12734
       CASE(3)

12735
         gx = SUM( dx(1,1:dim) * dfc(1:dim) )

12736
         gy = SUM( dx(2,1:dim) * dfc(1:dim) )

12737
         gz = SUM( dx(3,1:dim) * dfc(1:dim) )

12738
     END SELECT

12739


12740
   END SUBROUTINE GlobalFirstDerivativesInternal

12741
!------------------------------------------------------------------------------

12742


12743


12744


12745
!------------------------------------------------------------------------------

12746
!>   Given element structure return value of the first partial derivative with

12747
!>   respect to global coordinates of a quantity f given at element nodes at

12748
!>   local coordinate point u,v,w inside the element. Element basis functions

12749
!>   are used to compute the value.

12750
!------------------------------------------------------------------------------

12751
   SUBROUTINE GlobalFirstDerivatives( Elm, Nodes, df, gx, gy, gz, &

12752
                    Metric, dLBasisdx )

12753
!------------------------------------------------------------------------------

12754
!

12755
!  ARGUMENTS:

12756
!   Type(Element_t) :: element

12757
!     INPUT: element structure

12758
!

12759
!   Type(Nodes_t) :: nodes

12760
!     INPUT: element nodal coordinate arrays

12761
!     

12762
!   REAL(KIND=dp) :: f(:)

12763
!     INPUT: Nodal values of the quantity whose partial derivatives we want

12764
!            to know

12765
!

12766
!   REAL(KIND=dp) :: gx=@f(u,v,w)/@x, gy=@f(u,v,w)/@y, gz=@f(u,v,w)/@z

12767
!     OUTPUT: Values of the partial derivatives

12768
!

12769
!   REAL(KIND=dp) :: u,v,w

12770
!     INPUT: Point at which to evaluate the partial derivative

12771
!

12772
!   REAL(KIND=dp)L :: dLBasisdx(:,:)

12773
!     INPUT: Values of partial derivatives of basis functions with respect to

12774
!            local coordinates

12775
!

12776
!   REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:)

12777
!     INPUT: Values of partial derivatives of basis functions with respect to

12778
!            global coordinates can be given here, if known, otherwise they

12779
!            will be computed from the element basis functions.

12780
!

12781
!------------------------------------------------------------------------------

12782


12783
     TYPE(Element_t) :: elm

12784
     TYPE(Nodes_t) :: nodes

12785


12786
     REAL(KIND=dp) :: gx,gy,gz

12787
     REAL(KIND=dp) :: dLBasisdx(:,:),Metric(:,:),df(:)

12788


12789
!    Local variables

12790
!------------------------------------------------------------------------------

12791
     INTEGER :: n

12792
!------------------------------------------------------------------------------

12793


12794
    CALL GlobalFirstDerivativesInternal( Elm, Nodes, df, &

12795
              gx, gy, gz, Metric, dLBasisdx )

12796


12797
   END SUBROUTINE GlobalFirstDerivatives

12798
!------------------------------------------------------------------------------

12799


12800


12801


12802
!------------------------------------------------------------------------------

12803
!>   Given element structure return value of a quantity x given at element nodes

12804
!>   at local coordinate point u inside the element. Element basis functions are

12805
!>   used to compute the value. This is just a wrapper routine and will call the

12806
!>   real function according to element dimension.   

12807
!------------------------------------------------------------------------------

12808
   FUNCTION InterpolateInElement( elm,f,u,v,w,Basis ) RESULT(val)

12809
!------------------------------------------------------------------------------

12810
!

12811
!  DESCRIPTION:

12812
!

12813
!  ARGUMENTS:

12814
!   Type(Element_t) :: element

12815
!     INPUT: element structure

12816
!     

12817
!    REAL(KIND=dp) :: f(:)

12818
!     INPUT: Nodal values of the quantity whose value we want to know

12819
!

12820
!    REAL(KIND=dp) :: u,v,w

12821
!     INPUT: Point at which to evaluate the value

12822
!

12823
!    REAL(KIND=dp), OPTIONAL :: Basis(:)

12824
!      INPUT: Values of the basis functions at the point u,v,w can be given here,

12825
!      if known, otherwise the will be computed from the definition

12826
!                 

12827
!  FUNCTION VALUE:

12828
!     REAL(KIND=dp) :: y

12829
!       value of the quantity y = x(u,v,w)

12830
!    

12831
!------------------------------------------------------------------------------

12832


12833
     TYPE(Element_t) :: elm

12834
     REAL(KIND=dp) :: u,v,w

12835
     REAL(KIND=dp) :: f(:)

12836
     REAL(KIND=dp), OPTIONAL :: Basis(:)

12837


12838
!------------------------------------------------------------------------------

12839
!    Local variables

12840
!------------------------------------------------------------------------------

12841
     REAL(KIND=dp) :: val

12842
     INTEGER :: n

12843


12844
     IF ( PRESENT( Basis ) ) THEN

12845
!------------------------------------------------------------------------------

12846
!      Basis function values given, just sum the result ...

12847
!------------------------------------------------------------------------------

12848
       n = elm % TYPE % NumberOfNodes

12849
       val = SUM( f(1:n)*Basis(1:n) )

12850
     ELSE

12851
!------------------------------------------------------------------------------

12852
!      ... otherwise compute from the definition.

12853
!------------------------------------------------------------------------------

12854
       SELECT CASE (elm % TYPE % DIMENSION)

12855
         CASE (0)

12856
           val = f(1)

12857
         CASE (1)

12858
           val = InterpolateInElement1D( elm,f,u )

12859
         CASE (2)

12860
           val = InterpolateInElement2D( elm,f,u,v )

12861
         CASE (3)

12862
           val = InterpolateInElement3D( elm,f,u,v,w )

12863
       END SELECT

12864
     END IF

12865
  

12866
   END FUNCTION InterpolateInElement

12867
!------------------------------------------------------------------------------

12868


12869


12870


12871
!------------------------------------------------------------------------------

12872
!>          Compute elementwise matrix of second partial derivatives

12873
!>          at given point u,v,w in global coordinates.

12874
!------------------------------------------------------------------------------

12875
   SUBROUTINE GlobalSecondDerivatives(elm,nodes,values,u,v,w,Metric,&

12876
                     dBasisdx,ddLBasisddx,nd)

12877
!------------------------------------------------------------------------------

12878
!  

12879
!       Parameters:

12880
!  

12881
!           Input:   (Element_t) structure describing the element

12882
!                    (Nodes_t)   element nodal coordinates

12883
!                    (double precision) F nodal values of the quantity

12884
!                    (double precision) u,v point at which to evaluate

12885
!  

12886
!           Output:   3x3 matrix (values) of partial derivatives

12887
!  

12888
!------------------------------------------------------------------------------

12889


12890
     TYPE(Nodes_t)   :: nodes

12891
     TYPE(Element_t) :: elm

12892


12893
     INTEGER :: nd

12894
 

12895
     REAL(KIND=dp) :: u,v,w

12896
     REAL(KIND=dp) ::  Metric(:,:)

12897
     REAL(KIND=dp) ::  values(:,:,:)

12898
     REAL(KIND=dp) :: dBasisdx(:,:), ddLBasisddx(:,:,:)

12899
!------------------------------------------------------------------------------

12900
!    Local variables

12901
!------------------------------------------------------------------------------

12902
     INTEGER :: i,j,k,l,n,q,dim,cdim

12903


12904
     REAL(KIND=dp), DIMENSION(3,3,3) :: C1,C2,ddx

12905
     REAL(KIND=dp) :: df(3), cddf(3,3),ddf(3,3),dx(3,3)

12906


12907
     REAL(KIND=dp) :: s

12908
     REAL(KIND=dp), DIMENSION(:), POINTER :: x,y,z

12909
!------------------------------------------------------------------------------

12910
#if 0

12911
#if 1

12912
!

12913
! This is actually not quite correct...

12914
!

12915
     IF ( elm % TYPE % BasisFunctionDegree <= 1 ) RETURN

12916
#else

12917
!

12918
! this is ...

12919
!

12920
     IF ( elm % TYPE % ElementCode <= 202 .OR. &

12921
          elm % TYPE % ElementCode == 303 .OR. &

12922
          elm % TYPE % ElementCode == 504 ) RETURN

12923
#endif

12924
#endif

12925


12926
     n  = elm % TYPE % NumberOfNodes

12927
     x => nodes % x

12928
     y => nodes % y

12929
     z => nodes % z

12930


12931
     dim  = elm % TYPE % DIMENSION

12932
     cdim = CoordinateSystemDimension()

12933


12934


12935
!------------------------------------------------------------------------------

12936
!    Partial derivatives of the basis functions are given, just

12937
!    sum for the first partial derivatives...

12938
!------------------------------------------------------------------------------

12939
     dx = 0.0d0

12940
     SELECT CASE( cdim )

12941
       CASE(1)

12942
         DO i=1,dim

12943
           dx(1,i) = SUM( x(1:nd)*dBasisdx(1:nd,i) )

12944
         END DO

12945


12946
       CASE(2)

12947
         DO i=1,dim

12948
           dx(1,i) = SUM( x(1:nd)*dBasisdx(1:nd,i) )

12949
           dx(2,i) = SUM( y(1:nd)*dBasisdx(1:nd,i) )

12950
         END DO

12951


12952
       CASE(3)

12953
         DO i=1,dim

12954
           dx(1,i) = SUM( x(1:nd)*dBasisdx(1:nd,i) )

12955
           dx(2,i) = SUM( y(1:nd)*dBasisdx(1:nd,i) )

12956
           dx(3,i) = SUM( z(1:nd)*dBasisdx(1:nd,i) )

12957
         END DO

12958
     END SELECT

12959
!------------------------------------------------------------------------------

12960
!     Get second partial derivatives with respect to local coordinates

12961
!------------------------------------------------------------------------------

12962
     DO i=1,dim

12963
       DO j=1,dim

12964
         ddx(1,i,j) = SUM(ddLBasisddx(1:nd,i,j)*x(1:nd) )

12965
         ddx(2,i,j) = SUM(ddLBasisddx(1:nd,i,j)*y(1:nd) )

12966
         ddx(3,i,j) = SUM(ddLBasisddx(1:nd,i,j)*z(1:nd) )

12967
       END DO

12968
     END DO

12969
!

12970
!------------------------------------------------------------------------------

12971
!    Christoffel symbols of the second kind of the element coordinate system

12972
!------------------------------------------------------------------------------

12973
      DO i=1,dim

12974
        DO j=1,dim

12975
          DO k=1,dim

12976
            s = 0.0d0

12977
            DO l=1,cdim

12978
              s = s + ddx(l,i,j)*dx(l,k)

12979
            END DO

12980
            C2(i,j,k) = s

12981
          END DO

12982
        END DO

12983
      END DO

12984
!------------------------------------------------------------------------------

12985
!    Christoffel symbols of the first kind

12986
!------------------------------------------------------------------------------

12987
      DO i=1,dim

12988
        DO j=1,dim

12989
          DO k=1,dim

12990
            s = 0.0d0

12991
            DO l=1,dim

12992
              s = s + Metric(k,l)*C2(i,j,l)

12993
            END DO

12994
            C1(i,j,k) = s

12995
          END DO

12996
        END DO

12997
      END DO

12998
!------------------------------------------------------------------------------

12999
!     First add ordinary partials (change of the quantity with coordinates)...

13000
!------------------------------------------------------------------------------

13001
     Values = 0.0d0

13002
     DO q=1,nd

13003
       df  = dBasisdx(q,:)

13004
       ddf = ddLBasisddx(q,:,:)

13005


13006
!------------------------------------------------------------------------------

13007
!     ... then add change of coordinates

13008
!------------------------------------------------------------------------------

13009
        DO i=1,dim

13010
          DO j=1,dim

13011
            s = 0.0d0

13012
            DO k=1,dim

13013
              s = s - C1(i,j,k)*df(k)

13014
            END DO

13015
            ddf(i,j) = ddf(i,j) + s

13016
          END DO

13017
        END DO

13018
!------------------------------------------------------------------------------

13019
!       Convert to contravariant base

13020
!------------------------------------------------------------------------------

13021
        DO i=1,dim

13022
          DO j=1,dim

13023
            s = 0.0d0

13024
            DO k=1,dim

13025
              DO l=1,dim

13026
                s = s + Metric(i,k)*Metric(j,l)*ddf(k,l)

13027
              END DO

13028
            END DO

13029
            cddf(i,j) = s

13030
          END DO

13031
        END DO

13032
!------------------------------------------------------------------------------

13033
!      And finally transform to global coordinates 

13034
!------------------------------------------------------------------------------

13035
        DO i=1,cdim

13036
          DO j=1,cdim

13037
            s = 0.0d0

13038
            DO k=1,dim

13039
              DO l=1,dim

13040
                s = s + dx(i,k)*dx(j,l)*cddf(k,l)    

13041
              END DO

13042
            END DO

13043
            Values(q,i,j) = s

13044
          END DO

13045
        END DO

13046
      END DO

13047
!------------------------------------------------------------------------------

13048
   END SUBROUTINE GlobalSecondDerivatives

13049
!------------------------------------------------------------------------------

13050


13051


13052


13053
!------------------------------------------------------------------------------

13054
 FUNCTION GetEdgeMap( ElementFamily ) RESULT(EdgeMap)

13055
!------------------------------------------------------------------------------

13056
    INTEGER :: ElementFamily

13057
    INTEGER, POINTER :: EdgeMap(:,:)

13058


13059
    INTEGER, TARGET :: Point(1,1)

13060
    INTEGER, TARGET :: Line(1,2)

13061
    INTEGER, TARGET :: Triangle(3,2)

13062
    INTEGER, TARGET :: Quad(4,2)

13063
    INTEGER, TARGET :: Tetra(6,2)

13064
    INTEGER, TARGET :: Pyramid(8,2)

13065
    INTEGER, TARGET :: Wedge(9,2)

13066
    INTEGER, TARGET :: Brick(12,2)

13067


13068
    LOGICAL :: Initialized(8) = .FALSE.

13069
  

13070
    SAVE Line, Triangle, Wedge, Brick, Tetra, Quad, Pyramid, Initialized

13071


13072
    SELECT CASE(ElementFamily)

13073
    CASE(1)

13074
      EdgeMap => Point

13075
    CASE(2)

13076
      EdgeMap => Line

13077
    CASE(3)

13078
      EdgeMap => Triangle

13079
    CASE(4) 

13080
      EdgeMap => Quad

13081
    CASE(5) 

13082
      EdgeMap => Tetra

13083
    CASE(6) 

13084
      EdgeMap => Pyramid

13085
    CASE(7) 

13086
      EdgeMap => Wedge

13087
    CASE(8) 

13088
      EdgeMap => Brick

13089
    CASE DEFAULT

13090
      WRITE( Message,'(A,I0,A)') 'Element family ',ElementFamily,' is not known!'

13091
      CALL Fatal( 'GetEdgeMap', Message )

13092
    END SELECT

13093
 

13094
    IF ( .NOT. Initialized(ElementFamily) ) THEN

13095
       Initialized(ElementFamily) = .TRUE.

13096
       SELECT CASE(ElementFamily)

13097
       CASE(1)

13098
         EdgeMap(1,1) = 1

13099


13100
       CASE(2)

13101
         EdgeMap(1,:) = [ 1,2 ]

13102


13103
       CASE(3)

13104
         EdgeMap(1,:) = [ 1,2 ]

13105
         EdgeMap(2,:) = [ 2,3 ]

13106
         EdgeMap(3,:) = [ 3,1 ]

13107


13108
       CASE(4)

13109
         EdgeMap(1,:) = [ 1,2 ]

13110
         EdgeMap(2,:) = [ 2,3 ]

13111
         EdgeMap(3,:) = [ 3,4 ]

13112
         EdgeMap(4,:) = [ 4,1 ]

13113


13114
       CASE(5)

13115
         EdgeMap(1,:) = [ 1,2 ]

13116
         EdgeMap(2,:) = [ 2,3 ]

13117
         EdgeMap(3,:) = [ 3,1 ]

13118
         EdgeMap(4,:) = [ 1,4 ]

13119
         EdgeMap(5,:) = [ 2,4 ]

13120
         EdgeMap(6,:) = [ 3,4 ]

13121


13122
       CASE(6)

13123
         EdgeMap(1,:) = [ 1,2 ]

13124
         EdgeMap(2,:) = [ 2,3 ]

13125
         EdgeMap(3,:) = [ 4,3 ]

13126
         EdgeMap(4,:) = [ 1,4 ]

13127
         EdgeMap(5,:) = [ 1,5 ]

13128
         EdgeMap(6,:) = [ 2,5 ]

13129
         EdgeMap(7,:) = [ 3,5 ]

13130
         EdgeMap(8,:) = [ 4,5 ]

13131
 

13132
       CASE(7)

13133
         EdgeMap(1,:) = [ 1,2 ]

13134
         EdgeMap(2,:) = [ 2,3 ]

13135
         EdgeMap(3,:) = [ 3,1 ]

13136
         EdgeMap(4,:) = [ 4,5 ]

13137
         EdgeMap(5,:) = [ 5,6 ]

13138
         EdgeMap(6,:) = [ 6,4 ]

13139
         EdgeMap(7,:) = [ 1,4 ]

13140
         EdgeMap(8,:) = [ 2,5 ]

13141
         EdgeMap(9,:) = [ 3,6 ]

13142


13143
       CASE(8)

13144
         EdgeMap(1,:)  = [ 1,2 ]

13145
         EdgeMap(2,:)  = [ 2,3 ]

13146
         EdgeMap(3,:)  = [ 4,3 ]

13147
         EdgeMap(4,:)  = [ 1,4 ]

13148
         EdgeMap(5,:)  = [ 5,6 ]

13149
         EdgeMap(6,:)  = [ 6,7 ]

13150
         EdgeMap(7,:)  = [ 8,7 ]

13151
         EdgeMap(8,:)  = [ 5,8 ]

13152
         EdgeMap(9,:)  = [ 1,5 ]

13153
         EdgeMap(10,:) = [ 2,6 ]

13154
         EdgeMap(11,:) = [ 3,7 ]

13155
         EdgeMap(12,:) = [ 4,8 ]

13156
       END SELECT

13157
     END IF

13158
!------------------------------------------------------------------------------

13159
  END FUNCTION GetEdgeMap

13160
!------------------------------------------------------------------------------

13161


13162


13163


13164
!------------------------------------------------------------------------------

13165
!>    Figure out element diameter parameter for stabilization.

13166
!------------------------------------------------------------------------------

13167
   FUNCTION ElementDiameter( elm, nodes, UseLongEdge ) RESULT(hK)

13168
!------------------------------------------------------------------------------

13169
     TYPE(Element_t) :: elm  !< element structure

13170
     TYPE(Nodes_t) :: nodes  !< Nodal coordinate arrays of the element

13171
     LOGICAL, OPTIONAL :: UseLongEdge  !< Use the longest edge to determine the diameter.

13172
     REAL(KIND=dp) :: hK     !< hK

13173
!------------------------------------------------------------------------------

13174
!    Local variables

13175
!------------------------------------------------------------------------------

13176
     REAL(KIND=dp), DIMENSION(:), POINTER :: X,Y,Z

13177
     INTEGER :: i,j,k,Family

13178
     INTEGER, POINTER :: EdgeMap(:,:)

13179
     REAL(KIND=dp) :: x0,y0,z0,A,S,CX,CY,CZ

13180
     REAL(KIND=dp) :: J11,J12,J13,J21,J22,J23,G11,G12,G21,G22

13181
     LOGICAL :: LongEdge=.FALSE.

13182
!------------------------------------------------------------------------------

13183


13184
     IF(PRESENT(UseLongEdge)) LongEdge = UseLongEdge

13185


13186
     X => Nodes % x

13187
     Y => Nodes % y

13188
     Z => Nodes % z

13189


13190
     Family = Elm % TYPE % ElementCode / 100

13191
     SELECT CASE( Family )

13192


13193
       CASE(1)

13194
         hK = 0.0d0

13195


13196
!------------------------------------------------------------------------------

13197
!       Triangular element

13198
!------------------------------------------------------------------------------

13199
       CASE(3) 

13200
         J11 = X(2) - X(1)

13201
         J12 = Y(2) - Y(1)

13202
         J13 = Z(2) - Z(1)

13203
         J21 = X(3) - X(1)

13204
         J22 = Y(3) - Y(1)

13205
         J23 = Z(3) - Z(1)

13206
         G11 = J11**2  + J12**2  + J13**2

13207
         G12 = J11*J21 + J12*J22 + J13*J23

13208
         G22 = J21**2  + J22**2  + J23**2

13209
         A = SQRT(G11*G22 - G12**2) / 2.0d0

13210


13211
         CX = ( X(1) + X(2) + X(3) ) / 3.0d0

13212
         CY = ( Y(1) + Y(2) + Y(3) ) / 3.0d0

13213
         CZ = ( Z(1) + Z(2) + Z(3) ) / 3.0d0

13214


13215
         s =     (X(1)-CX)**2 + (Y(1)-CY)**2 + (Z(1)-CZ)**2

13216
         s = s + (X(2)-CX)**2 + (Y(2)-CY)**2 + (Z(2)-CZ)**2

13217
         s = s + (X(3)-CX)**2 + (Y(3)-CY)**2 + (Z(3)-CZ)**2

13218


13219
         hK = 16.0d0*A*A / ( 3.0d0 * s )

13220


13221
!------------------------------------------------------------------------------

13222
!      Quadrilateral

13223
!------------------------------------------------------------------------------

13224
       CASE(4)

13225
          CX = (X(2)-X(1))**2 + (Y(2)-Y(1))**2 + (Z(2)-Z(1))**2

13226
          CY = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 + (Z(4)-Z(1))**2

13227
          hk = 2*CX*CY/(CX+CY)

13228


13229
       CASE DEFAULT

13230
         EdgeMap => GetEdgeMap(Family)

13231


13232
         IF(LongEdge) THEN

13233
           hK = -1.0 * HUGE(1.0_dp)

13234
         ELSE

13235
           hK = HUGE(1.0_dp)

13236
         END IF

13237


13238
         DO i=1,SIZE(EdgeMap,1)

13239
           j=EdgeMap(i,1)

13240
           k=EdgeMap(i,2)

13241
           x0 = X(j) - X(k)

13242
           y0 = Y(j) - Y(k)

13243
           z0 = Z(j) - Z(k)

13244
           IF(LongEdge) THEN

13245
             hk = MAX(hK, x0**2 + y0**2 + z0**2)

13246
           ELSE

13247
             hk = MIN(hK, x0**2 + y0**2 + z0**2)

13248
           END IF

13249
         END DO

13250
     END SELECT

13251


13252
     hK = SQRT( hK )

13253
!------------------------------------------------------------------------------

13254
  END FUNCTION ElementDiameter

13255
!------------------------------------------------------------------------------

13256


13257


13258
  

13259


13260
!------------------------------------------------------------------------------

13261
!>     Figure out if given point x,y,z is inside a triangle, whose node

13262
!>     coordinates are given in nx,ny,nz. Method: Invert the basis

13263
!>     functions....

13264
!------------------------------------------------------------------------------

13265
  FUNCTION TriangleInside( nx,ny,nz,x,y,z ) RESULT(inside)

13266
!------------------------------------------------------------------------------

13267
    REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays

13268
    REAL(KIND=dp) :: x,y,z             !< point which to consider

13269
    LOGICAL :: inside                  !< result of the in/out test

13270
!------------------------------------------------------------------------------

13271
!   Local variables

13272
!------------------------------------------------------------------------------

13273
    REAL(KIND=dp) :: a00,a01,a10,a11,b00,b01,b10,b11,detA,px,py,u,v

13274
!------------------------------------------------------------------------------

13275


13276
    inside = .FALSE.

13277


13278
    IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y ) RETURN

13279
    IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y ) RETURN

13280


13281
    A00 = nx(2) - nx(1)

13282
    A01 = nx(3) - nx(1)

13283
    A10 = ny(2) - ny(1)

13284
    A11 = ny(3) - ny(1)

13285


13286
    detA = A00*A11 - A01*A10

13287
    IF ( ABS(detA) < AEPS ) RETURN

13288


13289
    detA = 1 / detA

13290


13291
    B00 =  A11*detA

13292
    B01 = -A01*detA

13293
    B10 = -A10*detA

13294
    B11 =  A00*detA

13295


13296
    px = x - nx(1)

13297
    py = y - ny(1)

13298
    u = 0.0d0

13299
    v = 0.0d0

13300


13301
    u = B00*px + B01*py

13302
    IF ( u < 0.0d0 .OR. u > 1.0d0 ) RETURN

13303


13304
    v = B10*px + B11*py

13305
    IF ( v < 0.0d0 .OR. v > 1.0d0 ) RETURN

13306


13307
    inside = (u + v <=  1.0d0)

13308
!------------------------------------------------------------------------------

13309
   END FUNCTION TriangleInside

13310
!------------------------------------------------------------------------------

13311


13312


13313


13314
!------------------------------------------------------------------------------

13315
!>     Figure out if given point x,y,z is inside a quadrilateral, whose

13316
!>     node coordinates are given in nx,ny,nz. Method: Invert the

13317
!>     basis functions....

13318
!------------------------------------------------------------------------------

13319
   FUNCTION QuadInside( nx,ny,nz,x,y,z ) RESULT(inside)

13320
!------------------------------------------------------------------------------

13321
    REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays

13322
    REAL(KIND=dp) :: x,y,z             !< point which to consider

13323
    LOGICAL :: inside                  !< result of the in/out test

13324
!------------------------------------------------------------------------------

13325
!   Local variables

13326
!------------------------------------------------------------------------------

13327
    REAL(KIND=dp) :: r,a,b,c,d,ax,bx,cx,dx,ay,by,cy,dy,px,py,u,v

13328
!------------------------------------------------------------------------------

13329
    inside = .FALSE.

13330


13331
    IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y ) RETURN

13332
    IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y ) RETURN

13333


13334
    ax = 0.25*(  nx(1) + nx(2) + nx(3) + nx(4) )

13335
    bx = 0.25*( -nx(1) + nx(2) + nx(3) - nx(4) )

13336
    cx = 0.25*( -nx(1) - nx(2) + nx(3) + nx(4) )

13337
    dx = 0.25*(  nx(1) - nx(2) + nx(3) - nx(4) )

13338


13339
    ay = 0.25*(  ny(1) + ny(2) + ny(3) + ny(4) )

13340
    by = 0.25*( -ny(1) + ny(2) + ny(3) - ny(4) )

13341
    cy = 0.25*( -ny(1) - ny(2) + ny(3) + ny(4) )

13342
    dy = 0.25*(  ny(1) - ny(2) + ny(3) - ny(4) )

13343


13344
    px = x - ax

13345
    py = y - ay

13346


13347
    a = cy*dx - cx*dy

13348
    b = bx*cy - by*cx + dy*px - dx*py

13349
    c = by*px - bx*py

13350


13351
    u = 0.0d0

13352
    v = 0.0d0

13353


13354
    IF ( ABS(a) < AEPS ) THEN

13355
      r = -c / b

13356
      IF ( r < -1.0d0 .OR. r > 1.0d0 ) RETURN

13357


13358
      v = r

13359
      u = (px - cx*r)/(bx + dx*r)

13360
      inside = (u >= -1.0d0 .AND. u <= 1.0d0)

13361
      RETURN

13362
    END IF

13363


13364
    d = b*b - 4*a*c

13365
    IF ( d < 0.0d0 ) RETURN

13366


13367
    d = SQRT(d)

13368
    IF ( b>0 ) THEN

13369
      r = -2*c/(b+d)

13370
    ELSE

13371
      r = (-b+d)/(2*a)

13372
    END IF

13373
    IF ( r >= -1.0d0 .AND. r <= 1.0d0 ) THEN

13374
      v = r

13375
      u = (px - cx*r)/(bx + dx*r)

13376
        

13377
      IF ( u >= -1.0d0 .AND. u <= 1.0d0 ) THEN

13378
        inside = .TRUE.

13379
        RETURN

13380
      END IF

13381
    END IF

13382


13383
    IF ( b>0 ) THEN

13384
      r = -(b+d)/(2*a)

13385
    ELSE

13386
      r = 2*c/(-b+d)

13387
    END IF

13388
    IF ( r >= -1.0d0 .AND. r <= 1.0d0 ) THEN

13389
      v = r

13390
      u = (px - cx*r)/(bx + dx*r)

13391
      inside = u >= -1.0d0 .AND. u <= 1.0d0

13392
      RETURN

13393
    END IF

13394
!------------------------------------------------------------------------------

13395
  END FUNCTION QuadInside

13396
!------------------------------------------------------------------------------

13397


13398


13399


13400
!------------------------------------------------------------------------------

13401
!>     Figure out if given point x,y,z is inside a tetrahedron, whose

13402
!>     node coordinates are given in nx,ny,nz. Method: Invert the

13403
!>     basis functions....

13404
!------------------------------------------------------------------------------

13405
  FUNCTION TetraInside( nx,ny,nz,x,y,z ) RESULT(inside)

13406
!------------------------------------------------------------------------------

13407
    REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays

13408
    REAL(KIND=dp) :: x,y,z             !< point which to consider

13409
    LOGICAL :: inside                  !< result of the in/out test

13410
!------------------------------------------------------------------------------

13411
!   Local variables

13412
!------------------------------------------------------------------------------

13413
    REAL(KIND=dp) :: A00,A01,A02,A10,A11,A12,A20,A21,A22,detA

13414
    REAL(KIND=dp) :: B00,B01,B02,B10,B11,B12,B20,B21,B22

13415
    REAL(KIND=dp) :: px,py,pz,u,v,w

13416
!------------------------------------------------------------------------------

13417
    inside = .FALSE.

13418


13419
    IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y .OR. MAXVAL(nz) < z ) RETURN

13420
    IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y .OR. MINVAL(nz) > z ) RETURN

13421


13422
    A00 = nx(2) - nx(1)

13423
    A01 = nx(3) - nx(1)

13424
    A02 = nx(4) - nx(1)

13425


13426
    A10 = ny(2) - ny(1)

13427
    A11 = ny(3) - ny(1)

13428
    A12 = ny(4) - ny(1)

13429


13430
    A20 = nz(2) - nz(1)

13431
    A21 = nz(3) - nz(1)

13432
    A22 = nz(4) - nz(1)

13433


13434
    detA =        A00*(A11*A22 - A12*A21)

13435
    detA = detA + A01*(A12*A20 - A10*A22)

13436
    detA = detA + A02*(A10*A21 - A11*A20)

13437
    IF ( ABS(detA) < AEPS ) RETURN

13438


13439
    detA = 1 / detA

13440


13441
    px = x - nx(1)

13442
    py = y - ny(1)

13443
    pz = z - nz(1)

13444


13445
    B00 = (A11*A22 - A12*A21)*detA

13446
    B01 = (A21*A02 - A01*A22)*detA

13447
    B02 = (A01*A12 - A11*A02)*detA

13448


13449
    u = B00*px + B01*py + B02*pz

13450
    IF ( u < 0.0d0 .OR. u > 1.0d0 ) RETURN

13451


13452


13453
    B10 = (A12*A20 - A10*A22)*detA

13454
    B11 = (A00*A22 - A20*A02)*detA

13455
    B12 = (A10*A02 - A00*A12)*detA

13456


13457
    v = B10*px + B11*py + B12*pz

13458
    IF ( v < 0.0d0 .OR. v > 1.0d0 ) RETURN

13459


13460


13461
    B20 = (A10*A21 - A11*A20)*detA

13462
    B21 = (A01*A20 - A00*A21)*detA

13463
    B22 = (A00*A11 - A10*A01)*detA

13464


13465
    w = B20*px + B21*py + B22*pz

13466
    IF ( w < 0.0d0 .OR. w > 1.0d0 ) RETURN

13467


13468
    inside = (u + v + w) <= 1.0d0

13469
!------------------------------------------------------------------------------

13470
  END FUNCTION TetraInside

13471
!------------------------------------------------------------------------------

13472


13473


13474


13475
!------------------------------------------------------------------------------

13476
!>     Figure out if given point x,y,z is inside a brick, whose node coordinates

13477
!>     are given in nx,ny,nz. Method: Divide to tetrahedrons.

13478
!------------------------------------------------------------------------------

13479
  FUNCTION BrickInside( nx,ny,nz,x,y,z ) RESULT(inside)

13480
!------------------------------------------------------------------------------

13481
    REAL(KIND=dp) :: nx(:),ny(:),nz(:) !< Node coordinate arrays

13482
    REAL(KIND=dp) :: x,y,z             !< point which to consider

13483
    LOGICAL :: inside                  !< result of the in/out test

13484
!------------------------------------------------------------------------------

13485
!   Local variables

13486
!------------------------------------------------------------------------------

13487
    INTEGER :: i,j

13488
    REAL(KIND=dp) :: px(4),py(4),pz(4),r,s,t,maxx,minx,maxy,miny,maxz,minz

13489
    INTEGER :: map(3,12)

13490
!------------------------------------------------------------------------------

13491
    map = RESHAPE( [ 0,1,2,   0,2,3,   4,5,6,   4,6,7,   3,2,6,   3,6,7,  &

13492
     1,5,6,   1,6,2,   0,4,7,   0,7,3,   0,1,5,   0,5,4 ], [ 3,12 ] ) + 1

13493
    

13494
    inside = .FALSE.

13495


13496
    IF ( MAXVAL(nx) < x .OR. MAXVAL(ny) < y .OR. MAXVAL(nz) < z ) RETURN

13497
    IF ( MINVAL(nx) > x .OR. MINVAL(ny) > y .OR. MINVAL(nz) > z ) RETURN

13498


13499
    px(1) = 0.125d0 * SUM(nx)

13500
    py(1) = 0.125d0 * SUM(ny)

13501
    pz(1) = 0.125d0 * SUM(nz)

13502


13503
    DO i=1,12

13504
      px(2:4) = nx(map(1:3,i))

13505
      py(2:4) = ny(map(1:3,i))

13506
      pz(2:4) = nz(map(1:3,i))

13507


13508
      IF ( TetraInside( px,py,pz,x,y,z ) ) THEN

13509
        inside = .TRUE.

13510
        RETURN

13511
      END IF

13512
    END DO

13513
!------------------------------------------------------------------------------

13514
  END FUNCTION BrickInside

13515
!------------------------------------------------------------------------------

13516


13517
!------------------------------------------------------------------------------

13518
!> Check if the current element has been defined passive.

13519
!> This is done by inspecting a looking an the values of "varname Passive"

13520
!> in the Body Force section. It is determined to be passive if it has 

13521
!> more positive than negative hits in an element.

13522
!------------------------------------------------------------------------------

13523
  FUNCTION CheckPassiveElement( UElement )  RESULT( IsPassive )

13524
    !------------------------------------------------------------------------------

13525
    TYPE(Element_t), OPTIONAL, TARGET :: UElement

13526
    LOGICAL :: IsPassive

13527
    !------------------------------------------------------------------------------

13528
    TYPE(Element_t), POINTER :: Element,tmp

13529
    REAL(KIND=dp), ALLOCATABLE :: Passive(:)

13530
    INTEGER :: body_id, bf_id, nlen, NbrNodes, PassNodes

13531
    LOGICAL :: Found

13532
    CHARACTER(:), ALLOCATABLE :: PassName

13533
    LOGICAL :: NoPassiveElements = .FALSE.    

13534
    TYPE(Solver_t), POINTER :: pSolver, PrevSolver => NULL()

13535
    TYPE(ValueList_t), POINTER :: BodyForce => NULL()

13536
    INTEGER :: ActiveMin = -1, PassiveMin = -1, prev_body_id = -1

13537
    LOGICAL :: DoCheck = .FALSE.

13538
    

13539
    SAVE Passive, NoPassiveElements, PrevSolver, PassName, prev_body_id, &

13540
        BodyForce, ActiveMin, PassiveMin, DoCheck

13541
    !$OMP THREADPRIVATE(Passive, NoPassiveElements, PrevSolver, PassName, prev_body_id, &

13542
    !$OMP               BodyForce, ActiveMin, PassiveMin, DoCheck ) 

13543
    !------------------------------------------------------------------------------

13544
    IsPassive = .FALSE.

13545
    pSolver => CurrentModel % Solver

13546
    

13547
    IF( .NOT. ASSOCIATED( pSolver, PrevSolver ) ) THEN

13548
      PrevSolver => pSolver          

13549
      nlen = CurrentModel % Solver % Variable % NameLen

13550
      PassName = GetVarName(CurrentModel % Solver % Variable) // ' Passive'     

13551
      NoPassiveElements = .NOT. ListCheckPresentAnyBodyForce(CurrentModel, PassName)

13552


13553
      ! Nullify the BodyForce memories also if we have new solver.

13554
      prev_body_id = -1

13555
    END IF

13556
    

13557
    IF( NoPassiveElements ) RETURN       

13558


13559
    IF (PRESENT(UElement)) THEN

13560
      tmp => CurrentModel % CurrentElement

13561
      Element => UElement

13562
      CurrentModel % CurrentElement => Element

13563
    ELSE

13564
#ifdef _OPENMP

13565
      IF (omp_in_parallel()) THEN

13566
        CALL Fatal('CheckPassiveElement', &

13567
             'Need an element to update inside a threaded region')

13568
      END IF

13569
#endif

13570
      Element => CurrentModel % CurrentElement

13571
    END IF

13572


13573
    body_id = Element % BodyId 

13574
    IF ( body_id <= 0 )  RETURN   ! body_id == 0 for boundary elements

13575


13576
    ! Do some mundane list operations if we have different body than previously. 

13577
    IF(body_id /= prev_body_id ) THEN

13578
      prev_body_id = body_id

13579
      

13580
      bf_id = ListGetInteger( CurrentModel % Bodies(body_id) % Values, &

13581
          'Body Force', DoCheck , minv=1,maxv=CurrentModel % NumberOfBodyForces )

13582
      IF(DoCheck) THEN

13583
        BodyForce => CurrentModel % BodyForces(bf_id) % Values

13584
        DoCheck = ListCheckPresent( BodyForce, PassName)

13585
      END IF

13586
      IF(DoCheck) THEN

13587
        PassiveMin = ListGetInteger( pSolver % Values,'Passive Element Min Nodes',Found )      

13588
        IF(.NOT. Found) PassiveMin = ListGetInteger( BodyForce,'Passive Element Min Nodes',Found )              

13589
        ActiveMin = ListGetInteger( pSolver % Values,'Active Element Min Nodes',Found )               

13590
        IF(.NOT. Found) ActiveMin = ListGetInteger( BodyForce,'Active Element Min Nodes',Found )

13591
      END IF

13592
    END IF

13593
    

13594
    IF(DoCheck) THEN 

13595
      NbrNodes = Element % TYPE % NumberOfNodes

13596
      IF ( ALLOCATED(Passive) ) THEN

13597
        IF ( SIZE(Passive) < NbrNodes ) THEN

13598
          DEALLOCATE(Passive)

13599
          ALLOCATE( Passive(NbrNodes) )

13600
        END IF

13601
      ELSE

13602
        ALLOCATE( Passive(NbrNodes) )

13603
      END IF

13604
      Passive(1:NbrNodes) = ListGetReal( BodyForce, PassName, NbrNodes, Element % NodeIndexes )

13605
      PassNodes = COUNT(Passive(1:NbrNodes)>0)

13606


13607
      ! Go through the extremum cases first, and if the element is not either fully 

13608
      ! active or passive, then check for some possible given criteria for determining 

13609
      ! the element active / passive. 

13610
      !------------------------------------------------------------------------------

13611
      IF( PassNodes == 0 ) THEN

13612
        CONTINUE

13613
      ELSE IF( PassNodes == NbrNodes ) THEN

13614
        IsPassive = .TRUE.

13615
      ELSE

13616
        IF( PassiveMin > 0 ) THEN

13617
          IsPassive = ( PassNodes >= PassiveMin )

13618
        ELSE IF( ActiveMin > 0 ) THEN

13619
          IsPassive = ( PassNodes > NbrNodes - ActiveMin )

13620
        ELSE

13621
          IsPassive = ( 2*PassNodes > NbrNodes )

13622
        END IF

13623
      END IF

13624
    END IF

13625


13626
    IF (PRESENT(UElement)) THEN

13627
       CurrentModel % CurrentElement => tmp

13628
    END IF

13629
!------------------------------------------------------------------------------

13630
  END FUNCTION CheckPassiveElement

13631
!------------------------------------------------------------------------------

13632


13633
!------------------------------------------------------------------------------

13634
!> Normal will point into body with lower body ID.

13635
!> or outwards, if no elements on the other side.

13636
!------------------------------------------------------------------------------

13637
  SUBROUTINE CheckNormalDirection( Boundary,Normal,x,y,z,turn )

13638
!------------------------------------------------------------------------------

13639


13640
    TYPE(Element_t), POINTER :: Boundary

13641
    TYPE(Nodes_t) :: Nodes

13642
    REAL(KIND=dp) :: Normal(3),x,y,z

13643
    LOGICAL, OPTIONAL :: turn

13644
!------------------------------------------------------------------------------

13645


13646
    TYPE (Element_t), POINTER :: Element,LeftElement,RightElement

13647


13648
    INTEGER :: LMat,RMat,n,k

13649


13650
    REAL(KIND=dp) :: u,v,w,dCoord(3)

13651
    REAL(KIND=dp), ALLOCATABLE :: nx(:),ny(:),nz(:)

13652
    LOGICAL :: LPassive

13653
!------------------------------------------------------------------------------

13654
    

13655
    IF(.NOT. ASSOCIATED( Boundary % BoundaryInfo ) )  RETURN

13656
    

13657
    k = Boundary % BoundaryInfo % OutBody

13658


13659
    LeftElement => Boundary % BoundaryInfo % Left

13660


13661
    Element => Null()

13662
    IF ( ASSOCIATED(LeftELement) ) THEN

13663
       RightElement => Boundary % BoundaryInfo % Right

13664
       IF ( ASSOCIATED( RightElement ) ) THEN ! we have a body-body boundary        

13665
         IF ( k > 0 ) THEN ! declared outbody 

13666
           IF ( LeftElement % BodyId == k ) THEN

13667
             Element => RightElement

13668
           ELSE

13669
             Element => LeftElement

13670
           END IF

13671
         ELSE IF (LeftElement % BodyId > RightElement % BodyId) THEN ! normal pointing into body with lower body ID

13672
             Element => LeftElement

13673
         ELSE IF (LeftElement % BodyId < RightElement % BodyId) THEN! normal pointing into body with lower body ID

13674
           Element => RightElement

13675
         ELSE ! active/passive boundary

13676
           LPassive = CheckPassiveElement( LeftElement )

13677
           IF (LPassive .NEQV. CheckPassiveElement( RightElement )) THEN 

13678
             IF(LPassive) THEN

13679
               Element => RightElement

13680
             ELSE

13681
               Element => LeftElement

13682
             END IF

13683
           END IF

13684
         END IF

13685
       ELSE ! body-vacuum boundary from left->right

13686
         Element => LeftElement

13687
       END IF

13688
    ELSE! body-vacuum boundary from right->left

13689
       Element => Boundary % BoundaryInfo % Right

13690
    END IF

13691


13692
    IF ( .NOT. ASSOCIATED(Element) ) RETURN

13693


13694
    n = Element % TYPE % NumberOfNodes

13695


13696
    ALLOCATE( nx(n), ny(n), nz(n) )

13697


13698
    nx(1:n) = CurrentModel % Nodes % x(Element % NodeIndexes)

13699
    ny(1:n) = CurrentModel % Nodes % y(Element % NodeIndexes)

13700
    nz(1:n) = CurrentModel % Nodes % z(Element % NodeIndexes)

13701


13702
    SELECT CASE( Element % TYPE % ElementCode / 100 )

13703


13704
    CASE(2,4,8)

13705
      u = 0.0_dp

13706
      v = 0.0_dp

13707
      w = 0.0_dp

13708
    CASE(3)

13709
      u = 1.0d0/3

13710
      v = 1.0d0/3

13711
      w = 0.0d0

13712
    CASE(5)

13713
      u = 1.0d0/4

13714
      v = 1.0d0/4

13715
      w = 1.0d0/4

13716
    CASE(6)

13717
      u = 0.0

13718
      v = 0.0

13719
      w = 1.0d0/3

13720
    CASE(7)

13721
      u = 1.0d0/3

13722
      v = 1.0d0/3

13723
      w = 0.0d0

13724
    CASE DEFAULT

13725
      CALL Fatal('CheckNormalDirection','Invalid elementcode for parent element!')   

13726
      

13727
    END SELECT

13728


13729
    dCoord(1) = InterpolateInElement( Element, nx, u, v, w ) - x

13730
    dCoord(2) = InterpolateInElement( Element, ny, u, v, w ) - y

13731
    dCoord(3) = InterpolateInElement( Element, nz, u, v, w ) - z

13732
  

13733
    IF ( PRESENT(turn) ) turn = .FALSE.

13734
    IF ( SUM( dCoord * Normal ) > 0 ) THEN

13735
       IF ( Element % BodyId /= k ) THEN

13736
          Normal = -Normal

13737
          IF ( PRESENT(turn) ) turn = .TRUE.

13738
       END IF

13739
    ELSE IF (  Element % BodyId == k ) THEN

13740
       Normal = -Normal

13741
       IF ( PRESENT(turn) ) turn = .TRUE.

13742
    END IF

13743
    DEALLOCATE( nx,ny,nz )

13744
!------------------------------------------------------------------------------

13745
  END SUBROUTINE CheckNormalDirection

13746
!------------------------------------------------------------------------------

13747


13748


13749
!------------------------------------------------------------------------------

13750
!>   Normal will point out from the parent.

13751
!------------------------------------------------------------------------------

13752
  SUBROUTINE CheckNormalDirectionParent( Boundary,Normal,x,y,z,Element,turn )

13753
!------------------------------------------------------------------------------

13754


13755
    TYPE(Element_t), POINTER :: Boundary

13756
    TYPE(Nodes_t) :: Nodes

13757
    REAL(KIND=dp) :: Normal(3),x,y,z

13758
    TYPE(Element_t), POINTER :: Element

13759
    LOGICAL, OPTIONAL :: turn

13760
!------------------------------------------------------------------------------

13761
    INTEGER :: n,k

13762
    REAL(KIND=dp) :: x1,y1,z1

13763
    REAL(KIND=dp), ALLOCATABLE :: nx(:),ny(:),nz(:)

13764
    LOGICAL :: LPassive

13765
!------------------------------------------------------------------------------

13766


13767
    IF( PRESENT( turn ) ) turn = .FALSE.

13768
    

13769
    IF ( .NOT. ASSOCIATED(Element) ) RETURN

13770


13771
    n = Element % TYPE % NumberOfNodes

13772


13773
    ALLOCATE( nx(n), ny(n), nz(n) )

13774
    

13775
    nx(1:n) = CurrentModel % Nodes % x(Element % NodeIndexes)

13776
    ny(1:n) = CurrentModel % Nodes % y(Element % NodeIndexes)

13777
    nz(1:n) = CurrentModel % Nodes % z(Element % NodeIndexes)

13778


13779
    SELECT CASE( Element % TYPE % ElementCode / 100 )

13780


13781
    CASE(2,4,8)

13782
      x1 = InterpolateInElement( Element, nx, 0.0d0, 0.0d0, 0.0d0 )

13783
      y1 = InterpolateInElement( Element, ny, 0.0d0, 0.0d0, 0.0d0 )

13784
      z1 = InterpolateInElement( Element, nz, 0.0d0, 0.0d0, 0.0d0 )

13785
    CASE(3)

13786
      x1 = InterpolateInElement( Element, nx, 1.0d0/3, 1.0d0/3, 0.0d0 )

13787
      y1 = InterpolateInElement( Element, ny, 1.0d0/3, 1.0d0/3, 0.0d0 )

13788
      z1 = InterpolateInElement( Element, nz, 1.0d0/3, 1.0d0/3, 0.0d0 )

13789
    CASE(5)

13790
      x1 = InterpolateInElement( Element, nx, 1.0d0/4, 1.0d0/4, 1.0d0/4 )

13791
      y1 = InterpolateInElement( Element, ny, 1.0d0/4, 1.0d0/4, 1.0d0/4 )

13792
      z1 = InterpolateInElement( Element, nz, 1.0d0/4, 1.0d0/4, 1.0d0/4 )

13793
    CASE(6)

13794
      x1 = InterpolateInElement( Element, nx, 0.0d0, 0.0d0, 1.0d0/3 )

13795
      y1 = InterpolateInElement( Element, ny, 0.0d0, 0.0d0, 1.0d0/3 )

13796
      z1 = InterpolateInElement( Element, nz, 0.0d0, 0.0d0, 1.0d0/3 )

13797
    CASE(7)

13798
      x1 = InterpolateInElement( Element, nx, 1.0d0/3, 1.0d0/3, 0.0d0 )

13799
      y1 = InterpolateInElement( Element, ny, 1.0d0/3, 1.0d0/3, 0.0d0 )

13800
      z1 = InterpolateInElement( Element, nz, 1.0d0/3, 1.0d0/3, 0.0d0 )

13801
    CASE DEFAULT

13802
      CALL Fatal('CheckNormalDirection','Invalid elementcode for parent element!')   

13803
      

13804
    END SELECT

13805


13806
    ! Test vector points from surface to center of parent

13807
    x1 = x1 - x

13808
    y1 = y1 - y

13809
    z1 = z1 - z

13810
    

13811
    ! Swap the sign if the tentative normal points to the center, it should point outward

13812
    IF ( x1*Normal(1) + y1*Normal(2) + z1*Normal(3) > 0 ) THEN

13813
      Normal = -Normal

13814
      IF ( PRESENT(turn) ) turn = .TRUE.

13815
    END IF

13816


13817
    DEALLOCATE( nx,ny,nz )

13818
!------------------------------------------------------------------------------

13819
  END SUBROUTINE CheckNormalDirectionParent

13820
!------------------------------------------------------------------------------

13821


13822
  

13823
!------------------------------------------------------------------------------

13824
!> Gives the normal vector of a boundary element.

13825
!> For noncurved elements the normal vector does not depend on the local coordinate

13826
!> while otherwise it does. There are different uses of the function where some

13827
!> do not have the luxury of knowing the local coordinates and hence the center

13828
!> point is used as default.

13829
!------------------------------------------------------------------------------

13830
  RECURSIVE FUNCTION NormalVector( Boundary,BoundaryNodes,u0,v0,Check,Parent,Turn) RESULT(Normal)

13831
!------------------------------------------------------------------------------

13832
    TYPE(Element_t), POINTER :: Boundary

13833
    TYPE(Nodes_t)   :: BoundaryNodes

13834
    REAL(KIND=dp), OPTIONAL :: u0,v0

13835
    LOGICAL, OPTIONAL :: Check

13836
    TYPE(Element_t), POINTER, OPTIONAL :: Parent

13837
    LOGICAL, OPTIONAL :: Turn

13838
    REAL(KIND=dp) :: Normal(3)

13839
!------------------------------------------------------------------------------

13840
    LOGICAL :: CheckBody, CheckParent

13841
    TYPE(ElementType_t),POINTER :: elt

13842
    REAL(KIND=dp) :: u,v,Auu,Auv,Avu,Avv,detA,x,y,z

13843
    REAL(KIND=dp) :: dxdu,dxdv,dydu,dydv,dzdu,dzdv

13844
    REAL(KIND=dp), DIMENSION(:), POINTER :: nx,ny,nz

13845
    REAL(KIND=dp) :: Tangent1(3), Tangent2(3)

13846
    TYPE(Nodes_t) :: ParentNodes

13847
    TYPE(Element_t), POINTER :: pParent

13848
    INTEGER :: n, meshDim, elemDim

13849
    

13850
!------------------------------------------------------------------------------

13851


13852
    nx => BoundaryNodes % x

13853
    ny => BoundaryNodes % y

13854
    nz => BoundaryNodes % z   

13855


13856
    elemDim = Boundary % TYPE % DIMENSION

13857


13858
    IF(ASSOCIATED( CurrentModel % Mesh ) ) THEN

13859
      meshDim = CurrentModel % Mesh % MeshDim

13860
    ELSE

13861
      meshDim = CurrentModel % dimension

13862
    END IF

13863
      

13864
    SELECT CASE ( elemDim )

13865


13866
    CASE ( 0 ) 

13867
      Normal(1) = 1.0_dp

13868
      Normal(2:3) = 0.0_dp

13869


13870
    CASE ( 1 )

13871
      IF( meshDim == 3 ) THEN

13872
        ! We have 1D element but 3D mesh

13873
        ! Define the normal in the plane defined by the 2D parent element.

13874
        IF( PRESENT( u0 ) ) THEN

13875
          u = u0

13876
        ELSE

13877
          u = 0.0_dp

13878
        END IF

13879


13880
        ! 1st tangent vector is defined by the edge direction

13881
        dxdu = FirstDerivative1D( Boundary,nx,u )

13882
        dydu = FirstDerivative1D( Boundary,ny,u )

13883
        dzdu = FirstDerivative1D( Boundary,nz,u )

13884
        

13885
        detA = dxdu*dxdu + dydu*dydu + dzdu*dzdu

13886
        IF ( detA <= 0._dp ) THEN

13887
          Normal = 0._dp

13888
          RETURN

13889
        END IF

13890
        detA = 1.0_dp / SQRT(detA)

13891
        Tangent1(1) = dxdu * detA

13892
        Tangent1(2) = dydu * detA

13893
        Tangent1(3) = dzdu * detA

13894


13895
        ! The 2nd tangent element is the normal vector of the parent element

13896
        IF( PRESENT( Parent ) ) THEN

13897
          pParent => Parent

13898
        ELSE

13899
          pParent => Boundary % BoundaryInfo % Left

13900
          IF(.NOT. ASSOCIATED(pParent) ) THEN

13901
            pParent => Boundary % BoundaryInfo % Right

13902
          END IF          

13903
        END IF

13904


13905
        n = pParent % TYPE % NumberOfNodes

13906
        ALLOCATE( ParentNodes % x(n), ParentNodes % y(n), ParentNodes % z(n) )        

13907
        ParentNodes % x(1:n) = CurrentModel % Nodes % x(pParent % NodeIndexes)

13908
        ParentNodes % y(1:n) = CurrentModel % Nodes % y(pParent % NodeIndexes)

13909
        ParentNodes % z(1:n) = CurrentModel % Nodes % z(pParent % NodeIndexes)

13910
        Tangent2 = NormalVector( pParent, ParentNodes) 

13911
        DEALLOCATE( ParentNodes % x, ParentNodes % y, ParentNodes % z)

13912
        

13913
        Normal = CrossProduct( Tangent1, Tangent2 )         

13914
      ELSE        

13915
        IF( PRESENT( u0 ) ) THEN

13916
          u = u0

13917
        ELSE

13918
          u = 0.0_dp

13919
        END IF

13920


13921
        dxdu = FirstDerivative1D( Boundary,nx,u )

13922
        dydu = FirstDerivative1D( Boundary,ny,u )

13923


13924
        detA = dxdu*dxdu + dydu*dydu

13925
        IF ( detA <= 0._dp ) THEN

13926
          Normal = 0._dp

13927
          RETURN

13928
        END IF

13929
        detA = 1.0_dp / SQRT(detA)

13930
        Normal(1) = -dydu * detA

13931
        Normal(2) =  dxdu * detA

13932
        Normal(3) =  0.0d0

13933
      END IF

13934
        

13935
    CASE ( 2 ) 

13936
      IF( PRESENT( u0 ) ) THEN

13937
        u = u0

13938
        v = v0

13939
      ELSE

13940
        IF( Boundary % TYPE % ElementCode / 100 == 3 ) THEN

13941
          u = 1.0_dp/3

13942
          v = 1.0_dp/3

13943
        ELSE

13944
          u = 0.0_dp

13945
          v = 0.0_dp

13946
        END IF

13947
      END IF

13948


13949
      dxdu = FirstDerivativeInU2D( Boundary,nx,u,v )

13950
      dydu = FirstDerivativeInU2D( Boundary,ny,u,v )

13951
      dzdu = FirstDerivativeInU2D( Boundary,nz,u,v )

13952


13953
      dxdv = FirstDerivativeInV2D( Boundary,nx,u,v )

13954
      dydv = FirstDerivativeInV2D( Boundary,ny,u,v )

13955
      dzdv = FirstDerivativeInV2D( Boundary,nz,u,v )

13956


13957
      Auu = dxdu*dxdu + dydu*dydu + dzdu*dzdu

13958
      Auv = dxdu*dxdv + dydu*dydv + dzdu*dzdv

13959
      Avv = dxdv*dxdv + dydv*dydv + dzdv*dzdv

13960


13961
      detA = 1.0d0 / SQRT(Auu*Avv - Auv*Auv)

13962


13963
      Normal(1) = (dydu * dzdv - dydv * dzdu) * detA

13964
      Normal(2) = (dxdv * dzdu - dxdu * dzdv) * detA

13965
      Normal(3) = (dxdu * dydv - dxdv * dydu) * detA

13966
    

13967
    CASE DEFAULT

13968
      CALL Fatal('NormalVector','No normal for '&

13969
          //I2S(Boundary % TYPE % ElementCode)//' in '//I2S(meshDim)//'dim mesh!')

13970
      

13971
    END SELECT

13972


13973


13974
    CheckParent = .FALSE.

13975
    IF( PRESENT( Parent ) ) CheckParent = ASSOCIATED( Parent ) 

13976
    

13977
    CheckBody = .FALSE.

13978
    IF ( PRESENT(Check) ) CheckBody = Check

13979


13980
    IF ( .NOT. ( CheckBody .OR. CheckParent ) ) RETURN

13981
   

13982
    SELECT CASE( Boundary % TYPE % ElementCode / 100 ) 

13983


13984
    CASE(1)

13985
      x = nx(1)

13986
      y = nx(1)

13987
      z = nz(1)

13988


13989
    CASE(2,4)

13990
      x = InterpolateInElement( Boundary,nx,0.0d0,0.0d0,0.0d0 )

13991
      y = InterpolateInElement( Boundary,ny,0.0d0,0.0d0,0.0d0 )

13992
      z = InterpolateInElement( Boundary,nz,0.0d0,0.0d0,0.0d0 )

13993


13994
    CASE(3)

13995
      x = InterpolateInElement( Boundary,nx,1.0d0/3,1.0d0/3,0.0d0)

13996
      y = InterpolateInElement( Boundary,ny,1.0d0/3,1.0d0/3,0.0d0)

13997
      z = InterpolateInElement( Boundary,nz,1.0d0/3,1.0d0/3,0.0d0)

13998
    END SELECT

13999


14000
    IF( CheckParent ) THEN

14001
      CALL CheckNormalDirectionParent( Boundary, Normal, x, y, z, Parent,Turn )   

14002
    ELSE

14003
      CALL CheckNormalDirection( Boundary,Normal,x,y,z,Turn )

14004
    END IF

14005


14006
!------------------------------------------------------------------------------

14007
  END FUNCTION NormalVector

14008
!------------------------------------------------------------------------------

14009


14010
#if 0

14011
!------------------------------------------------------------------------------

14012
!> More economical normal vector computation assuming linear geometry description.

14013
!------------------------------------------------------------------------------

14014
  RECURSIVE FUNCTION NormalVectorLinear( Boundary,BoundaryNodes,Parent) RESULT(Normal)

14015
!------------------------------------------------------------------------------

14016
    TYPE(Element_t), POINTER :: Boundary

14017
    TYPE(Nodes_t) :: BoundaryNodes

14018
    TYPE(Element_t), POINTER, OPTIONAL :: Parent

14019
    REAL(KIND=dp) :: Normal(3)

14020
!------------------------------------------------------------------------------

14021
    REAL(KIND=dp), POINTER :: x(:),y(:),z(:)

14022
    REAL(KIND=dp) :: vec0(3), vec1(3), vec2(3), vec3(3) 

14023
    TYPE(Element_t), POINTER :: pParent

14024
    INTEGER :: i,i1,i2,i3,i4,n,m,ElemDim,MeshDim

14025
    

14026
!------------------------------------------------------------------------------

14027


14028
    x => CurrentModel % Nodes % x

14029
    y => CurrentModel % Nodes % y

14030
    z => CurrentModel % Nodes % z

14031


14032
    IF( PRESENT( Parent ) ) THEN

14033
      pParent => Parent

14034
    ELSE IF( ASSOCIATED( Boundary % BoundaryInfo ) ) THEN

14035
      pParent => Boundary % BoundaryInfo % Left

14036
      IF(.NOT. ASSOCIATED(pParent) ) THEN

14037
        pParent => Boundary % BoundaryInfo % Right

14038
      END IF

14039
    END IF

14040


14041
    ElemDim = Boundary % Type % Dimension 

14042
    MeshDim = CurrentModel % Mesh % MeshDim 

14043
    

14044
    IF(ElemDim <= MeshDim-1 .OR. .NOT. (ASSOCIATED(pParent)) ) THEN

14045
      SELECT CASE ( ElemDim ) 

14046
        

14047
      CASE ( 0 ) 

14048
        Normal(1) = 1.0_dp

14049
        Normal(2:3) = 0.0_dp

14050


14051
      CASE ( 1 )

14052
        i1 = Boundary % NodeIndexes(1)

14053
        i2 = Boundary % NodeIndexes(2)

14054


14055
        vec1(1) = x(i2) - x(i1)

14056
        vec1(2) = y(i2) - y(i1)

14057
        vec1(3) = 0.0_dp

14058


14059
        Normal(1) = -vec1(2)

14060
        Normal(2) = vec1(1)

14061
        Normal(3) = 0.0_dp

14062


14063
        Normal = Normal / SQRT(SUM(Normal**2))

14064


14065
      CASE( 2 ) 

14066
        n = Boundary % TYPE % ElementCode / 100 

14067


14068
        i1 = Boundary % NodeIndexes(1)

14069
        IF(n==4) THEN

14070
          i2 = Boundary % NodeIndexes(2)

14071
          i3 = Boundary % NodeIndexes(3)

14072
          i4 = Boundary % NodeIndexes(4)

14073
        ELSE

14074
          i2 = Boundary % NodeIndexes(2)

14075
          i3 = Boundary % NodeIndexes(3)

14076
          i4 = i1

14077
        END IF

14078
        

14079
        vec1(1) = x(i3) - x(i1)

14080
        vec1(2) = y(i3) - y(i1)

14081
        vec1(3) = z(i3) - z(i1)

14082
        

14083
        vec2(1) = x(i4) - x(i2)

14084
        vec2(2) = y(i4) - y(i2)

14085
        vec2(3) = z(i4) - z(i2)

14086
          

14087
        Normal = CrossProduct( vec1, vec2 )

14088
        Normal = Normal / SQRT(SUM(Normal**2))

14089


14090
      CASE DEFAULT

14091
        CALL Fatal('NormalVector','Invalid dimension for determining normal!')

14092


14093
      END SELECT

14094
      

14095
    ELSE 

14096


14097
      SELECT CASE ( ElemDim ) 

14098
        

14099
      CASE ( 0 )                

14100
        i1 = pParent % NodeIndexes(1)

14101
        i2 = pParent % NodeIndexes(2)

14102
        

14103
        Normal(1) = x(i2) - x(i1)

14104
        Normal(2) = y(i2) - y(i1)

14105
        Normal(3) = 0.0_dp

14106


14107
        Normal = Normal / SQRT(SUM(Normal**2))

14108
        IF( i1 == Boundary % NodeIndexes(1) ) THEN

14109
          Normal = -Normal

14110
        END IF

14111
                       

14112
      CASE ( 1 )

14113
        i1 = Boundary % NodeIndexes(1)

14114
        i2 = Boundary % NodeIndexes(2)

14115


14116
        vec1(1) = x(i1)

14117
        vec1(2) = y(i1)

14118
        vec1(3) = z(i1)

14119


14120
        vec2(1) = x(i2)

14121
        vec2(2) = y(i2)

14122
        vec2(3) = z(i2)

14123
               

14124
        vec0 = vec1-vec2

14125
        vec0 = vec0 / SQRT(SUM(vec0**2))

14126
        

14127
        n = pParent % TYPE % ElementCode / 100 

14128


14129
        vec2 = 0.0_dp

14130
        DO i=1,n

14131
          i3 = pParent % NodeIndexes(i)

14132
          IF(i3 == i1 .OR. i3 == i2 ) CYCLE

14133


14134
          ! Vector stretching from edge center to the other nodes

14135
          ! of the parent element. 

14136
          vec2(1) = vec3(1) + x(i3) 

14137
          vec3(1) = vec3(1) + x(i3) 

14138
          vec3(1) = vec3(1) + x(i3) 

14139
        END DO

14140
        ! Subtract the average 

14141
        vec3 = vec3 - (n-2)*(vec1+vec2)/2 

14142
        

14143
        ! Remove projection in the direction of the line

14144
        Normal = vec3 - SUM(vec0*vec3)*vec0

14145
        Normal = -Normal / SQRT(SUM(Normal**2))

14146


14147
      CASE( 2 ) 

14148
        n = Boundary % TYPE % ElementCode / 100 

14149
        

14150
        i1 = Boundary % NodeIndexes(1)

14151
        IF(n==4) THEN

14152
          i2 = Boundary % NodeIndexes(2)

14153
          i3 = Boundary % NodeIndexes(3)

14154
          i4 = Boundary % NodeIndexes(4)

14155
        ELSE

14156
          i2 = Boundary % NodeIndexes(2)

14157
          i3 = Boundary % NodeIndexes(3)

14158
          i4 = i1

14159
        END IF

14160
          

14161
        vec1(1) = x(i3) - x(i1)

14162
        vec1(2) = y(i3) - y(i1)

14163
        vec1(3) = z(i3) - z(i1)

14164
        

14165
        vec2(1) = x(i4) - x(i2)

14166
        vec2(2) = y(i4) - y(i2)

14167
        vec2(3) = z(i4) - z(i2)

14168
          

14169
        Normal = CrossProduct( vec1, vec2 )

14170
        Normal = Normal / SQRT(SUM(Normal**2))

14171


14172
        m = pParent % TYPE % ElementCode / 100 

14173
        vec1 = 0.0_dp

14174
        vec2 = 0.0_dp

14175
        DO i=1,m

14176
          i1 = pParent % NodeIndexes(i)

14177
          IF( ANY( Boundary % NodeIndexes == i1 ) ) THEN

14178
            vec1(1) = vec1(1) + x(i1)

14179
            vec1(2) = vec1(2) + y(i1)

14180
            vec1(3) = vec1(3) + z(i1)            

14181
          ELSE

14182
            vec2(1) = vec2(1) + x(i1)

14183
            vec2(2) = vec2(2) + y(i1)

14184
            vec2(3) = vec2(3) + z(i1)

14185
          END IF

14186
        END DO

14187


14188
        vec1 = vec1 / n

14189
        vec2 = vec2 / (m-n)

14190


14191
        IF( SUM( (vec1-vec2)*Normal ) < 0.0_dp ) THEN

14192
          Normal = -Normal

14193
        END IF

14194
        

14195
      CASE DEFAULT

14196
        CALL Fatal('NormalVector','Invalid dimension for determining normal!')

14197
        

14198
      END SELECT

14199
    END IF

14200
      

14201
!------------------------------------------------------------------------------

14202
  END FUNCTION NormalVectorLinear

14203
!------------------------------------------------------------------------------

14204
#endif

14205


14206


14207
  

14208
!------------------------------------------------------------------------------

14209
!> Returns a point that is most importantly supposed to be on the surface

14210
!> For noncurved elements this may simply be the mean while otherwise

14211
!> there may be a need to find the surface node using the local coordinates.

14212
!> Hence the optional parameters. Typically the NormalVector and SurfaceVector

14213
!> should be defined at the same position.

14214
!------------------------------------------------------------------------------

14215
  FUNCTION SurfaceVector( Boundary,BoundaryNodes,u,v ) RESULT(Surface)

14216
!------------------------------------------------------------------------------

14217
    TYPE(Element_t), POINTER :: Boundary

14218
    TYPE(Nodes_t)   :: BoundaryNodes

14219
    REAL(KIND=dp),OPTIONAL :: u,v

14220
    REAL(KIND=dp) :: Surface(3)

14221
!------------------------------------------------------------------------------

14222
    REAL(KIND=dp), DIMENSION(:), POINTER :: nx,ny,nz

14223
    INTEGER :: i,n

14224
!------------------------------------------------------------------------------

14225


14226
    nx => BoundaryNodes % x

14227
    ny => BoundaryNodes % y

14228
    nz => BoundaryNodes % z

14229
    n = Boundary % TYPE % NumberOfNodes

14230


14231
    IF( .NOT. PRESENT( u ) ) THEN

14232
      Surface(1) = SUM( nx ) / n

14233
      Surface(2) = SUM( ny ) / n

14234
      Surface(3) = SUM( nz ) / n

14235
    ELSE

14236
      IF( Boundary % TYPE % DIMENSION == 1 ) THEN

14237
        Surface(1) = InterpolateInElement( Boundary,nx,u,0.0_dp,0.0_dp)

14238
        Surface(2) = InterpolateInElement( Boundary,ny,u,0.0_dp,0.0_dp)

14239
        Surface(3) = InterpolateInElement( Boundary,nz,u,0.0_dp,0.0_dp)

14240
      ELSE 

14241
        Surface(1) = InterpolateInElement( Boundary,nx,u,v,0.0_dp)

14242
        Surface(2) = InterpolateInElement( Boundary,ny,u,v,0.0_dp)

14243
        Surface(3) = InterpolateInElement( Boundary,nz,u,v,0.0_dp)        

14244
      END IF

14245
    END IF

14246


14247
!------------------------------------------------------------------------------

14248
  END FUNCTION SurfaceVector

14249
!------------------------------------------------------------------------------

14250


14251


14252
!---------------------------------------------------------------------------

14253
!> This subroutine tests where the intersection between the line defined by two 

14254
!> points and a plane (or line) defined by a boundary element meet. There is

14255
!> an intersection if ( 0 < Lambda < 1 ). Of all intersections the first one is 

14256
!> that with the smallest positive lambda. 

14257
!---------------------------------------------------------------------------

14258
  FUNCTION LineFaceIntersection(FaceElement,FaceNodes,&

14259
      Rinit,Rfin,u,v) RESULT ( Lambda )

14260
!---------------------------------------------------------------------------

14261
    TYPE(Nodes_t) :: FaceNodes

14262
    TYPE(Element_t), POINTER   :: FaceElement

14263
    REAL(KIND=dp) :: Rinit(3),Rfin(3)

14264
    REAL(KIND=dp),OPTIONAL :: u,v

14265
    REAL(KIND=dp) :: Lambda

14266


14267
    REAL (KIND=dp) :: Surface(3),t1(3),t2(3),Normal(3),Rproj

14268
    REAL (KIND=dp) :: Lambda0

14269
    INTEGER :: third

14270


14271
    third = 3

14272


14273
100 CONTINUE

14274


14275
    ! For higher order elements this may be a necessity

14276
    IF( PRESENT( u ) .AND. PRESENT(v) ) THEN

14277
      Surface = SurfaceVector( FaceElement, FaceNodes, u, v )

14278
      Normal = NormalVector( FaceElement, FaceNodes, u, v )

14279


14280
    ELSE IF( FaceElement % TYPE % DIMENSION == 2 ) THEN

14281
      ! Any point known to be at the surface, even corner node

14282
      Surface(1) = FaceNodes % x(1)

14283
      Surface(2) = FaceNodes % y(1)

14284
      Surface(3) = FaceNodes % z(1)

14285


14286
      ! Tangent vector, nor normalized to unity!

14287
      t1(1) = FaceNodes % x(2) - Surface(1)

14288
      t1(2) = FaceNodes % y(2) - Surface(2)

14289
      t1(3) = FaceNodes % z(2) - Surface(3)

14290


14291
      t2(1) = FaceNodes % x(third) - Surface(1)

14292
      t2(2) = FaceNodes % y(third) - Surface(2)

14293
      t2(3) = FaceNodes % z(third) - Surface(3)

14294


14295
      ! Normal vector obtained from the cross product of tangent vectoes

14296
      ! This is not normalized to unity as value of lambda does not depend on its magnitude

14297
      Normal(1) = t1(2)*t2(3) - t1(3)*t2(2)

14298
      Normal(2) = t1(3)*t2(1) - t1(1)*t2(3)

14299
      Normal(3) = t1(1)*t2(2) - t1(2)*t2(1)

14300
    ELSE

14301
      Surface(1) = FaceNodes % x(1)

14302
      Surface(2) = FaceNodes % y(1)

14303
      Surface(3) = 0.0_dp

14304


14305
      Normal(1) = Surface(2) - FaceNodes % y(2)

14306
      Normal(2) = FaceNodes % x(2) - Surface(1)

14307
      Normal(3) = 0.0_dp      

14308
    END IF

14309


14310
    ! Project of the line to the face normal

14311
    Rproj = SUM( (Rfin - Rinit) * Normal )

14312
    

14313
    IF( ABS( Rproj ) < TINY( Rproj ) ) THEN

14314
      ! if the intersection cannot be defined make it an impossible one

14315
      Lambda = -HUGE( Lambda ) 

14316
    ELSE

14317
      Lambda = SUM( ( Surface - Rinit ) * Normal ) / Rproj

14318
    END IF

14319


14320
    IF( FaceElement % Type % NumberOfNodes == 4 ) THEN

14321
      IF( third == 3 ) THEN

14322
        third = 4

14323
	Lambda0 = Lambda

14324
        GOTO 100

14325
      END IF

14326
      IF( ABS( Lambda0 ) < ABS( Lambda) ) THEN

14327
        Lambda = Lambda0 

14328
      END IF

14329
   END IF

14330


14331


14332
  END FUNCTION LineFaceIntersection

14333
  

14334


14335
!---------------------------------------------------------------------------

14336
!> This subroutine performs a similar test as above using slightly different 

14337
!> strategy.

14338
!---------------------------------------------------------------------------

14339
  FUNCTION LineFaceIntersection2(FaceElement,FaceNodes,Rinit,Rfin,Intersect) RESULT ( Lambda ) 

14340


14341
    TYPE(Nodes_t) :: FaceNodes

14342
    TYPE(Element_t), POINTER   :: FaceElement

14343
    REAL(KIND=dp) :: Rinit(3), Rfin(3),Lambda

14344
    LOGICAL :: Intersect

14345
!----------------------------------------------------------------------------

14346
    REAL (KIND=dp) :: A(3,3),B(3),C(3),Eps,Eps2,Eps3,detA,absA,ds

14347
    INTEGER :: split, i, n, notriangles, triangle, ElemDim

14348


14349
    Eps = EPSILON( Eps )

14350
    Eps2 = SQRT(TINY(Eps2))    

14351
    Eps3 = 1.0d-12

14352
    Lambda = -HUGE( Lambda )

14353
    Intersect = .FALSE.

14354
    ElemDim = FaceElement % TYPE % DIMENSION 

14355


14356
    ! Then solve the exact points of intersection from a 3x3 or 2x2 linear system

14357
    !--------------------------------------------------------------------------

14358
    IF( ElemDim == 2 ) THEN

14359
      n = FaceElement % Type % NumberOfNodes

14360
      ! In 3D rectangular faces are treated as two triangles

14361
      IF( n == 4 .OR. n == 8 .OR. n == 9 ) THEN

14362
        notriangles = 2

14363
      ELSE

14364
        notriangles = 1

14365
      END IF

14366


14367
      DO triangle=1,notriangles

14368
          

14369
        A(1:3,1) = Rfin(1:3) - Rinit(1:3)

14370
        

14371
        IF(triangle == 1) THEN

14372
          A(1,2) = FaceNodes % x(1) - FaceNodes % x(2)

14373
          A(2,2) = FaceNodes % y(1) - FaceNodes % y(2)

14374
          A(3,2) = FaceNodes % z(1) - FaceNodes % z(2)

14375
        ELSE 

14376
          A(1,2) = FaceNodes % x(1) - FaceNodes % x(4)

14377
          A(2,2) = FaceNodes % y(1) - FaceNodes % y(4)

14378
          A(3,2) = FaceNodes % z(1) - FaceNodes % z(4)

14379
        END IF

14380


14381
        A(1,3) = FaceNodes % x(1) - FaceNodes % x(3)

14382
        A(2,3) = FaceNodes % y(1) - FaceNodes % y(3)

14383
        A(3,3) = FaceNodes % z(1) - FaceNodes % z(3)

14384
        

14385
        ! Check for linearly dependent vectors

14386
        detA = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) &

14387
             - A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)) &

14388
             + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1))

14389
        absA = SUM(ABS(A(1,1:3))) * SUM(ABS(A(2,1:3))) * SUM(ABS(A(3,1:3))) 

14390


14391
        IF(ABS(detA) <= eps * absA + Eps2) CYCLE

14392
!        print *,'detA',detA

14393


14394
        B(1) = FaceNodes % x(1) - Rinit(1)

14395
        B(2) = FaceNodes % y(1) - Rinit(2)

14396
        B(3) = FaceNodes % z(1) - Rinit(3)

14397
        

14398
        CALL InvertMatrix( A,3 )

14399
        C(1:3) = MATMUL( A(1:3,1:3),B(1:3) )

14400
        

14401
        IF( ANY(C(2:3) < -Eps3) .OR. ANY(C(2:3) > 1.0_dp + Eps3 ) ) CYCLE

14402
        IF( C(2)+C(3) > 1.0_dp + Eps3 ) CYCLE

14403


14404
        ! Relate the point of intersection to local coordinates

14405
        !IF(corners < 4) THEN

14406
        !  u = C(2)

14407
        !  v = C(3)

14408
        !ELSE IF(corners == 4 .AND. split == 0) THEN

14409
        !  u = 2*(C(2)+C(3))-1

14410
        !  v = 2*C(3)-1

14411
        !ELSE 

14412
        !  ! For the 2nd split of the rectangle the local coordinates switched

14413
        !  v = 2*(C(2)+C(3))-1

14414
        !  u = 2*C(3)-1        

14415
        !END IF

14416
        

14417
        Intersect = .TRUE.

14418
        Lambda = C(1)

14419
        EXIT

14420
 

14421
      END DO

14422
    ELSE

14423
      ! In 2D the intersection is between two lines

14424
      

14425
      A(1:2,1) = Rfin(1:2) - Rinit(1:2)

14426
      A(1,2) = FaceNodes % x(1) - FaceNodes % x(2)

14427
      A(2,2) = FaceNodes % y(1) - FaceNodes % y(2)

14428


14429
      detA = A(1,1)*A(2,2)-A(1,2)*A(2,1)

14430
      absA = SUM(ABS(A(1,1:2))) * SUM(ABS(A(2,1:2)))

14431


14432
      ! Lines are almost parallel => no intersection possible

14433
      IF(ABS(detA) <= eps * absA + Eps2) RETURN

14434


14435
      B(1) = FaceNodes % x(1) - Rinit(1)

14436
      B(2) = FaceNodes % y(1) - Rinit(2)

14437


14438
      CALL InvertMatrix( A,2 )

14439
      C(1:2) = MATMUL(A(1:2,1:2),B(1:2))

14440
     

14441
      IF(C(2) < -Eps3 .OR. C(2) > 1.0_dp + Eps3 ) RETURN

14442


14443
      Intersect = .TRUE.

14444
      Lambda = C(1)

14445


14446
!      u = -1.0d0 + 2.0d0 * C(2)

14447


14448
    END IF

14449


14450
!    IF(.NOT. Inside) RETURN

14451


14452
!    stat = ElementInfo( Element, FaceNodes, U, V, W, SqrtElementMetric, &

14453
!        Basis, dBasisdx )

14454
    

14455
!    Weights(1:n) = Basis(1:n)

14456
!    MaxInd = 1

14457
!    DO i=2,n

14458
!      IF(Weights(MaxInd) < Weights(i)) MaxInd = i

14459
!    END DO

14460


14461
  END FUNCTION LineFaceIntersection2

14462
  

14463
 

14464


14465
!---------------------------------------------------------------------------

14466
!> This subroutine computes the signed distance of a point from a surface.

14467
!---------------------------------------------------------------------------

14468
  FUNCTION PointFaceDistance(BoundaryElement,BoundaryNodes,&

14469
      Coord,Normal,u0,v0) RESULT ( Dist )

14470
!---------------------------------------------------------------------------

14471
    TYPE(Nodes_t) :: BoundaryNodes

14472
    TYPE(Element_t), POINTER   :: BoundaryElement

14473
    REAL(KIND=dp) :: Coord(3),Normal(3)

14474
    REAL(KIND=dp),OPTIONAL :: u0,v0

14475
    REAL(KIND=dp) :: Dist

14476


14477
    REAL (KIND=dp) :: Surface(3),t1(3),t2(3),u,v

14478


14479
    ! For higher order elements this may be a necessity

14480
    IF( PRESENT( u0 ) .AND. PRESENT(v0) ) THEN

14481
      u = u0

14482
      v = v0

14483
      Surface = SurfaceVector( BoundaryElement, BoundaryNodes, u, v )

14484
    ELSE

14485
      u = 0.0_dp

14486
      v = 0.0_dp

14487


14488
      ! Any point known to be at the surface, even corner node

14489
      Surface(1) = BoundaryNodes % x(1)

14490
      Surface(2) = BoundaryNodes % y(1)

14491
      Surface(3) = BoundaryNodes % z(1)

14492
    END IF

14493


14494
    Normal = NormalVector( BoundaryElement, BoundaryNodes, u, v, .TRUE. )

14495


14496
    ! Project of the line to the face normal

14497
    Dist = SUM( (Surface - Coord ) * Normal ) 

14498
END FUNCTION PointFaceDistance

14499


14500


14501


14502
!------------------------------------------------------------------------------

14503
!> Convert global coordinates x,y,z inside element to local coordinates

14504
!> u,v,w of the element.

14505
!> @todo Change to support p elements

14506
!------------------------------------------------------------------------------

14507
  SUBROUTINE GlobalToLocal( u,v,w,x,y,z,Element,ElementNodes )

14508
!------------------------------------------------------------------------------

14509
    TYPE(Nodes_t) :: ElementNodes

14510
    REAL(KIND=dp) :: x,y,z,u,v,w

14511
    TYPE(Element_t), POINTER :: Element

14512
!------------------------------------------------------------------------------

14513
    INTEGER, PARAMETER :: MaxIter = 50

14514
    INTEGER :: i,n

14515
    REAL(KIND=dp) :: r,s,t,delta(3),prevdelta(3),J(3,3),J1(3,2),det,swap,acc,err,scl,eps

14516
    LOGICAL :: Converged

14517
!------------------------------------------------------------------------------

14518


14519
    u = 0._dp

14520
    v = 0._dp

14521
    w = 0._dp

14522
    IF (Element % TYPE % DIMENSION==0) RETURN

14523


14524
    n = Element % TYPE % NumberOfNodes

14525
    scl = MAXVAL(ElementNodes % x(1:n)) - MINVAL(ElementNodes % x(1:n)) + &

14526
        MAXVAL(ElementNodes % y(1:n)) - MINVAL(ElementNodes % y(1:n)) + &

14527
        MAXVAL(ElementNodes % z(1:n)) - MINVAL(ElementNodes % z(1:n))

14528
        

14529
    

14530
    ! @todo Not supported yet

14531
!   IF (ASSOCIATED(Element % PDefs)) THEN

14532
!      CALL Fatal('GlobalToLocal','P elements not supported yet!')

14533
!   END IF

14534


14535
    eps = EPSILON(eps)

14536
    acc = eps * scl**2

14537
    Converged = .FALSE.

14538


14539
     delta = 0._dp

14540


14541
!------------------------------------------------------------------------------

14542
    DO i=1,Maxiter

14543
!------------------------------------------------------------------------------

14544
      r = InterpolateInElement(Element,ElementNodes % x(1:n),u,v,w) - x

14545
      s = InterpolateInElement(Element,ElementNodes % y(1:n),u,v,w) - y

14546
      t = InterpolateInElement(Element,ElementNodes % z(1:n),u,v,w) - z

14547


14548
      err = r**2 + s**2 + t**2 

14549


14550
      IF ( err < acc ) THEN

14551
        Converged = .TRUE.

14552
        EXIT

14553
      END IF

14554


14555
      prevdelta = delta

14556
      delta = 0.d0

14557


14558
      SELECT CASE( Element % TYPE % DIMENSION )

14559
      CASE(1)

14560


14561
        J(1,1) = FirstDerivative1D( Element, ElementNodes % x, u )

14562
        J(2,1) = FirstDerivative1D( Element, ElementNodes % y, u )

14563
        J(3,1) = FirstDerivative1D( Element, ElementNodes % z, u )

14564


14565
        det = SUM( J(1:3,1)**2 )

14566
        delta(1) = (r*J(1,1)+s*J(2,1)+t*J(3,1))/det

14567


14568
      CASE(2)

14569


14570
         J(1,1) = FirstDerivativeInU2D( Element, ElementNodes % x,u,v )

14571
         J(1,2) = FirstDerivativeInV2D( Element, ElementNodes % x,u,v )

14572
         J(2,1) = FirstDerivativeInU2D( Element, ElementNodes % y,u,v )

14573
         J(2,2) = FirstDerivativeInV2D( Element, ElementNodes % y,u,v )

14574


14575
        SELECT CASE( CoordinateSystemDimension() )

14576
           CASE(3)

14577
              J(3,1) = FirstDerivativeInU2D( Element, ElementNodes % z, u, v )

14578
              J(3,2) = FirstDerivativeInV2D( Element, ElementNodes % z, u, v )

14579


14580
              delta(1) = r

14581
              delta(2) = s

14582
              delta(3) = t

14583
              delta(1:2) = MATMUL( TRANSPOSE(J(1:3,1:2)), delta )

14584
              r = delta(1)

14585
              s = delta(2)

14586


14587
              J(1:2,1:2) = MATMUL( TRANSPOSE(J(1:3,1:2)), J(1:3,1:2) )

14588
              delta(3)   = 0.0d0

14589
         END SELECT

14590


14591
         CALL SolveLinSys2x2( J(1:2,1:2), delta(1:2), [ r, s] )

14592


14593
      CASE(3)

14594
        J(1,1) = FirstDerivativeInU3D( Element, ElementNodes % x, u, v, w )

14595
        J(1,2) = FirstDerivativeInV3D( Element, ElementNodes % x, u, v, w )

14596
        J(1,3) = FirstDerivativeInW3D( Element, ElementNodes % x, u, v, w )

14597


14598
        J(2,1) = FirstDerivativeInU3D( Element, ElementNodes % y, u, v, w )

14599
        J(2,2) = FirstDerivativeInV3D( Element, ElementNodes % y, u, v, w )

14600
        J(2,3) = FirstDerivativeInW3D( Element, ElementNodes % y, u, v, w )

14601


14602
        J(3,1) = FirstDerivativeInU3D( Element, ElementNodes % z, u, v, w )

14603
        J(3,2) = FirstDerivativeInV3D( Element, ElementNodes % z, u, v, w )

14604
        J(3,3) = FirstDerivativeInW3D( Element, ElementNodes % z, u, v, w )

14605


14606
        CALL SolveLinSys3x3( J, delta, [ r, s, t ] )

14607


14608
      END SELECT

14609


14610
      IF( i > 10 ) THEN

14611
        ! If the same values is suggested over and over again, then exit

14612
        ! This may be a sign that the node is off-plane and cannot be 

14613
        ! described within the element.

14614
        IF( SUM( ABS( delta - prevdelta ) ) < eps ) EXIT

14615


14616
        ! Use sloppier criteria when iteration still unsuccessful

14617
        IF( i > 20 ) THEN

14618
          IF( SUM( ABS( delta - prevdelta ) ) < 1.0e-8 ) EXIT

14619
        END IF

14620


14621
        ! If the iteration does not proceed try with some relaxation

14622
        delta = 0.5_dp * delta 

14623
      END IF

14624


14625
      u = u - delta(1)

14626
      v = v - delta(2)

14627
      w = w - delta(3)

14628


14629


14630
!------------------------------------------------------------------------------

14631
    END DO

14632
!------------------------------------------------------------------------------

14633


14634
    IF ( .NOT. Converged ) THEN        

14635
      IF( err > 1.0e-8 ) THEN

14636
        IF( i > MaxIter ) THEN	

14637
          CALL Warn( 'GlobalToLocal', 'did not converge.')

14638
          PRINT *,'rst',i,r,s,t

14639
          PRINT *,'err',err,acc,eps

14640
          PRINT *,'delta',delta,prevdelta

14641
          PRINT *,'uvw',u,v,w

14642
          PRINT *,'code',Element % TYPE % ElementCode

14643
          PRINT *,'x:',x,ElementNodes % x(1:n)

14644
          PRINT *,'y:',y,ElementNodes % y(1:n)

14645
          PRINT *,'z:',z,ElementNodes % z(1:n)

14646
        ELSE

14647
!          CALL Warn( 'GlobalToLocal', 'Node may be out of element')

14648
!          PRINT *,'rst',i,r,s,t,acc

14649
        END IF

14650
      END IF

14651
    END IF

14652
!------------------------------------------------------------------------------

14653
  END SUBROUTINE GlobalToLocal

14654
!------------------------------------------------------------------------------

14655


14656
  

14657
!------------------------------------------------------------------------------

14658
!>     Given element and its face map (for some triangular face of element ), 

14659
!>     this routine returns global direction of triangle face so that 

14660
!>     functions are continuous over element boundaries

14661
!------------------------------------------------------------------------------

14662
  FUNCTION getTriangleFaceDirection( Element, FaceMap, Indexes ) RESULT(globalDir)

14663
!------------------------------------------------------------------------------

14664
    IMPLICIT NONE

14665


14666
    TYPE(Element_t) :: Element   !< Element to get direction to

14667
    INTEGER :: FaceMap(3)        !< Element triangular face map

14668
    INTEGER :: Indexes(:)

14669
    INTEGER :: globalDir(3)      !< Global direction of triangular face as local node numbers.

14670
!------------------------------------------------------------------------------

14671
    INTEGER :: i, nodes(3)  

14672
    

14673
    ! Put global nodes of face into sorted order

14674
    nodes(1:3) = Indexes( FaceMap )

14675
    CALL sort(3, nodes)

14676
    

14677
    globalDir = 0

14678
    ! Find local numbers of sorted nodes. These local nodes 

14679
    ! span continuous functions over element boundaries

14680
    DO i=1,Element % TYPE % NumberOfNodes

14681
       IF (nodes(1) == Indexes(i)) THEN

14682
          globalDir(1) = i

14683
       ELSE IF (nodes(2) == Indexes(i)) THEN

14684
          globalDir(2) = i

14685
       ELSE IF (nodes(3) == Indexes(i)) THEN

14686
          globalDir(3) = i

14687
       END IF

14688
    END DO

14689
  END FUNCTION getTriangleFaceDirection

14690


14691


14692
!------------------------------------------------------------------------------

14693
!>     Given element and its face map (for some square face of element ), 

14694
!>     this routine returns global direction of square face so that 

14695
!>     functions are continuous over element boundaries

14696
!------------------------------------------------------------------------------

14697
  FUNCTION getSquareFaceDirection( Element, FaceMap, Indexes ) RESULT(globalDir)

14698
!------------------------------------------------------------------------------

14699
    IMPLICIT NONE

14700
    TYPE(Element_t) :: Element   !< Element to get direction to

14701
    INTEGER :: FaceMap(:)        !< Element square face map

14702
    INTEGER :: Indexes(:)

14703
    INTEGER :: globalDir(4)      !< Global direction of square face as local node numbers.

14704
!------------------------------------------------------------------------------

14705
    INTEGER :: i, A,B,C,D, nodes(4), minGlobal

14706


14707
    ! Get global nodes 

14708
    nodes(1:4) = Indexes( FaceMap )

14709


14710
    ! Find min global node

14711
    minGlobal = nodes(1)

14712
    A = 1

14713
    DO i=2,4

14714
       IF (nodes(i) < minGlobal) THEN

14715
          A = i

14716
          minGlobal = nodes(i)

14717
       END IF

14718
    END DO

14719


14720
    ! Now choose node B as the smallest node NEXT to min node

14721
    B = MOD(A,4)+1

14722
    C = MOD(A+3,4)

14723
    IF (C == 0) C = 4

14724
    D = MOD(A+2,4)

14725
    IF (D == 0) D = 4

14726
    IF (nodes(B) > nodes(C)) THEN

14727
       i = B

14728
       B = C

14729
       C = i

14730
    END IF

14731


14732
    ! Finally find local numbers of nodes A,B and C. They uniquely

14733
    ! define a global face so that basis functions are continuous 

14734
    ! over element boundaries

14735
    globalDir = 0

14736
    DO i=1,Element % TYPE % NumberOfNodes

14737
       IF (nodes(A) == Indexes(i)) THEN

14738
          globalDir(1) = i

14739
       ELSE IF (nodes(B) == Indexes(i)) THEN

14740
          globalDir(2) = i

14741
       ELSE IF (nodes(C) == Indexes(i)) THEN

14742
          globalDir(4) = i

14743
       ELSE IF (nodes(D) == Indexes(i)) THEN

14744
          globalDir(3) = i

14745
       END IF

14746
    END DO

14747
  END FUNCTION getSquareFaceDirection

14748


14749


14750
!------------------------------------------------------------------------------

14751
!>     Function checks if given local numbering of a square face

14752
!>     is legal for wedge element

14753
!------------------------------------------------------------------------------

14754
  FUNCTION wedgeOrdering( ordering ) RESULT(retVal)

14755
!------------------------------------------------------------------------------

14756
    IMPLICIT NONE

14757
    

14758
    INTEGER, DIMENSION(4), INTENT(IN) :: ordering  !< Local ordering of a wedge square face

14759
    LOGICAL :: retVal                              !< .TRUE. iff given ordering is legal for wedge square face.

14760


14761
    retVal = .FALSE.

14762
    IF ((ordering(1) >= 1 .AND. ordering(1) <= 3 .AND.&

14763
         ordering(2) >= 1 .AND. ordering(2) <= 3) .OR. &

14764
       (ordering(1) >= 4 .AND. ordering(1) <= 6 .AND.&

14765
       ordering(2) >= 4 .AND. ordering(2) <= 6)) THEN

14766
       retVal = .TRUE.

14767
    END IF

14768
  END FUNCTION wedgeOrdering

14769


14770
  !---------------------------------------------------------

14771
  !> Computes the 3D rotation matrix for a given 

14772
  !> surface normal vector

14773
  !---------------------------------------------------------

14774
  FUNCTION ComputeRotationMatrix(PlaneVector) RESULT ( RotMat )

14775


14776
    REAL(KIND=dp) :: PlaneVector(3), RotMat(3,3), ex(3), ey(3), ez(3)

14777
    INTEGER :: i, MinIndex, MidIndex, MaxIndex

14778


14779
    !Ensure PlaneVector is the unit normal

14780
    PlaneVector = PlaneVector / SQRT( SUM(PlaneVector ** 2) )

14781
    

14782
    !The new z-axis is normal to the defined surface

14783
    ez = PlaneVector

14784


14785
    MaxIndex = MAXLOC(ABS(ez),1)

14786
    MinIndex = MINLOC(ABS(ez),1)

14787


14788
    !Special case when calving front perfectly aligned to either

14789
    ! x or y axis. In this case, make minindex = 3 (ex points upwards)

14790
    IF(ABS(ez(3)) == ABS(ez(2)) .OR. ABS(ez(3)) == ABS(ez(1))) &

14791
         MinIndex = 3

14792


14793
    DO i=1,3

14794
       IF(i == MaxIndex .OR. i == MinIndex) CYCLE

14795
       MidIndex = i

14796
    END DO

14797


14798
    ex(MinIndex) = 1.0

14799
    ex(MidIndex) = 0.0

14800
    

14801
    ex(MaxIndex) = -ez(MinIndex)/ez(MaxIndex)

14802
    ex = ex / SQRT( SUM(ex ** 2) )

14803


14804
    !The new y-axis is orthogonal to new x and z axes

14805
    ey = CrossProduct(ez, ex)

14806
    ey = ey / SQRT( SUM(ey ** 2) ) !just in case...

14807


14808
    RotMat(1,:) = ex

14809
    RotMat(2,:) = ey

14810
    RotMat(3,:) = ez

14811


14812
  END FUNCTION ComputeRotationMatrix

14813


14814


14815


14816
  ! Observe the cuts on one single element.

14817
  ! This could be used to improve on the integration rules if we know where the

14818
  ! element should be split.

14819
  !-----------------------------------------------------------------------------

14820
  SUBROUTINE CutSingleElement(Element, ElemNodes, ElemPhi, ElemCut )

14821


14822
    TYPE(Element_t) :: Element

14823
    TYPE(Nodes_t) :: ElemNodes

14824
    REAL(KIND=dp) :: ElemPhi(:)

14825
    LOGICAL :: ElemCut(:)

14826


14827
    INTEGER :: i,i2,n

14828
    REAL(KIND=dp) :: h1,h2,hprod,r

14829
    REAL(KIND=dp), PARAMETER :: Eps=1.0e-3

14830
    

14831
    n = Element % TYPE % ElementCode / 100

14832
    ElemCut(1:2*n) = .FALSE.

14833
    

14834
    h1 = MINVAL(ElemPhi(1:n))

14835
    h2 = MAXVAL(ElemPhi(1:n))

14836
    IF(h1*h2 >= 0.0_dp) RETURN

14837


14838
    IF( (SIZE(ElemNodes % x) < 2*n) ) THEN

14839
      CALL Fatal('CutSingleElement','ElemNodes too small!')

14840
    END IF

14841
    

14842
    DO i=1, n

14843
      i2 = MODULO(i,n)+1

14844
      h1 = ElemPhi(i)

14845
      h2 = ElemPhi(i2)

14846
      hprod = h1*h2            

14847


14848
      ! First mark the cut nodes.        

14849
      IF( hprod < 0.0_dp ) THEN

14850
        r = ABS(h2)/(ABS(h1)+ABS(h2))        

14851
        IF( r <= Eps ) THEN

14852
          ElemCut(i2) = .TRUE.

14853
        ELSE IF((1.0-r < Eps) ) THEN

14854
          ElemCut(i) = .TRUE.

14855
        ELSE

14856
          ElemCut(n+i) = .TRUE.

14857


14858
          ! We update nodes so that the element on-the-fly can point to then using NodeIndexes. 

14859
          ElemNodes % x(n+i) = (1-r) * ElemNodes % x(i2) + r * ElemNodes % x(i)

14860
          ElemNodes % y(n+i) = (1-r) * ElemNodes % y(i2) + r * ElemNodes % y(i)

14861
          ElemNodes % z(n+i) = (1-r) * ElemNodes % z(i2) + r * ElemNodes % z(i)

14862
        END IF

14863
      ELSE IF( ABS(hprod) < 1.0d-20 ) THEN

14864
        IF(ABS(h1) < 1.0e-20) ElemCut(i) = .TRUE. 

14865
        IF(ABS(h2) < 1.0e-20) ElemCut(i2) = .TRUE.

14866
      END IF

14867
    END DO

14868


14869
  END SUBROUTINE CutSingleElement

14870


14871


14872
  ! Given a single element and a list of node and edge cuts create a list of

14873
  ! pieces coming from the split.

14874
  !---------------------------------------------------------------------------

14875
  SUBROUTINE SplitSingleElement(Element, ElemCut, ElemNodes, m, &

14876
      IsCut, IsMore, LocalInds, SgnNode )

14877


14878
    TYPE(Element_t) :: Element

14879
    LOGICAL :: ElemCut(:)

14880
    TYPE(Nodes_t) :: ElemNodes

14881
    INTEGER :: m

14882
    LOGICAL :: IsCut, IsMore

14883
    INTEGER :: LocalInds(:)

14884
    INTEGER :: SgnNode

14885
    

14886
    

14887
    INTEGER :: n,n_split,n_cut,ElemType,SplitCase,iCase,subcase

14888
    INTEGER :: j,j2,j3,j4,mmax

14889
    REAL(KIND=dp) :: s1,s2

14890
    

14891
    SAVE :: subcase, j, j2, j3, j4, mmax, s1, s2

14892


14893
    ElemType = Element % TYPE % ElementCode

14894
    n = ElemType / 100

14895
        

14896
    n_split = COUNT( ElemCut(n+1:2*n) )

14897
    n_cut = COUNT( ElemCut(1:n) )

14898
    

14899
    IsMore = .FALSE.   

14900
    IsCut = (n_split > 0)

14901


14902
    ! Nothing to do, use original element.

14903
    IF(.NOT. IsCut) RETURN

14904


14905
    ! This allows use case to deal with element types, edge splits and node splits at the same time. 

14906
    ! It is a matter of taste if this is ok or not...

14907
    SplitCase = 100 * ElemType + 10 * n_split + n_cut

14908
    iCase = 0

14909
    LocalInds = 0

14910
    

14911
    SELECT CASE( SplitCase ) 

14912


14913
      

14914
    CASE( 30320, 30321 ) 

14915
      ! Triangle being cut on two edges.

14916
      IF( m == 1 ) THEN

14917
        ! Find the only edge that is not cut

14918
        DO j=1,3

14919
          IF( .NOT. ElemCut( n + j ) ) EXIT

14920
        END DO

14921
        j2 = MODULO(j,3)+1

14922
        j3 = MODULO(j+1,3)+1

14923
        mmax = 3

14924
        

14925
        ! There are two ways to split the triangle.

14926
        ! Choose the one with shorter diameter.

14927
        s1 = (ElemNodes % x(j) - ElemNodes % x(n + j2))**2 + &

14928
            (ElemNodes % y(j) - ElemNodes % y(n + j2))**2 + &

14929
            (ElemNodes % z(j) - ElemNodes % z(n + j2))**2 

14930
        s2 = (ElemNodes % x(j2) - ElemNodes % x(n + j3))**2 + &

14931
            (ElemNodes % y(j2) - ElemNodes % y(n + j3))**2 + &

14932
            (ElemNodes % z(j2) - ElemNodes % z(n + j3))**2 

14933


14934
        LocalInds(1) = j

14935
        LocalInds(2) = j2                 

14936
        IF( s1 < s2 ) THEN

14937
          LocalInds(3) = n + j2

14938
        ELSE

14939
          LocalInds(3) = n + j3

14940
        END IF

14941
        SgnNode = 1

14942
        iCase = 1

14943
      ELSE IF(m==2) THEN

14944
        IF( s1 < s2 ) THEN

14945
          LocalInds(1) = j

14946
        ELSE

14947
          LocalInds(1) = j2       

14948
        END IF

14949
        LocalInds(2) = n + j2

14950
        LocalInds(3) = n + j3

14951


14952
        SgnNode = 1

14953
        iCase = 2

14954
      ELSE IF(m==3) THEN

14955
        LocalInds(1) = n + j3

14956
        LocalInds(2) = n + j2

14957
        LocalInds(3) = j3

14958


14959
        SgnNode = 3

14960
        iCase = 3

14961
      END IF

14962


14963
    CASE( 30311 ) 

14964
      ! Triangle being cut on one edge and one node. 

14965
      IF( m == 1 ) THEN

14966
        ! Find the only edge that is cut

14967
        DO j=1,3

14968
          IF( ElemCut( n + j ) ) EXIT

14969
        END DO

14970
        j2 = MODULO(j,3)+1

14971
        j3 = MODULO(j+1,3)+1

14972
      END IF

14973
      

14974
      ! One cut result to splitted elements only if the opposing node is cut through

14975
      IF( ElemCut(j3) ) THEN

14976
        IF(m==1) THEN

14977
          LocalInds(1) = n + j

14978
          LocalInds(2) = j2

14979
          LocalInds(3) = j3

14980
          

14981
          SgnNode = 2

14982
          iCase = 4

14983
          mmax = 2

14984
        ELSE IF(m==2) THEN

14985
          LocalInds(1) = n + j

14986
          LocalInds(2) = j3

14987
          LocalInds(3) = j

14988
          

14989
          sgnNode = 3

14990
          iCase = 5

14991
        END IF

14992
      ELSE IF(ElemCut(j) .OR. ElemCut(j2)) THEN

14993
        LocalInds(1:3) = [1,2,3]          

14994
        

14995
        iCase = 6

14996
        SgnNode = j3          

14997
        mmax = 1

14998
      END IF

14999


15000
    CASE( 40420, 40421 ) 

15001
      ! Quadrilateral being cut on two edges. 

15002
      

15003
      IF( m == 1 ) THEN

15004
        subcase = 0

15005
        IF( ElemCut(n+1) .AND. ElemCut(n+3) ) THEN

15006
          subcase = 1

15007
          j = 1

15008
          mmax = 2

15009
        ELSE IF( ElemCut(n+2) .AND. ElemCut(n+4) ) THEN

15010
          subcase = 1

15011
          j = 2

15012
          mmax = 2

15013
        ELSE

15014
          DO j=1,4

15015
            j2 = MODULO(j,4)+1

15016
            IF( ElemCut(n+j) .AND. ElemCut(n+j2) ) THEN

15017
              subcase = 2 

15018
              mmax = 3

15019
              EXIT

15020
            END IF

15021
          END DO

15022
        END IF

15023
        IF( subcase == 0 ) THEN

15024
          CALL Fatal('SplitSingleElement','This case not treated yet for 404!')

15025
        END IF

15026
      END IF

15027


15028
      

15029
      IF( subcase == 1 ) THEN        

15030
        mmax = 2

15031
        

15032
        IF( m == 1 ) THEN

15033
          j2 = MODULO(j,4)+1

15034
          j3 = MODULO(j+1,4)+1

15035
          j4 = MODULO(j+2,4)+1

15036
          

15037
          LocalInds(1) = j

15038
          LocalInds(2) = n + j

15039
          LocalInds(3) = n + j3

15040
          LocalInds(4) = j4          

15041
          

15042
          SgnNode = 1

15043
          iCase = 7

15044
        ELSE IF(m==2) THEN

15045
          LocalInds(1) = j2

15046
          LocalInds(2) = j3

15047
          LocalInds(3) = n + j3

15048
          LocalInds(4) = n + j

15049
          

15050
          SgnNode = 1

15051
          iCase = 8

15052
        END IF

15053


15054
      ELSE IF( subcase == 2 ) THEN

15055
        mmax = 4

15056


15057
        IF( m == 1 ) THEN

15058
          j2 = MODULO(j,4)+1

15059
          j3 = MODULO(j+1,4)+1

15060
          j4 = MODULO(j+2,4)+1

15061


15062
          LocalInds(1) = n + j

15063
          LocalInds(2) = j2

15064
          LocalInds(3) = n + j2

15065


15066
          SgnNode = 2

15067
          iCase = 9

15068
        ELSE IF(m==2) THEN

15069
          LocalInds(1) = j

15070
          LocalInds(2) = n + j

15071
          LocalInds(3) = j4

15072


15073
          SgnNode = 3

15074
          iCase = 10

15075
        ELSE IF(m==3) THEN

15076
          LocalInds(1) = n + j

15077
          LocalInds(2) = n + j2

15078
          LocalInds(3) = j4

15079


15080
          SgnNode = 3

15081
          iCase = 11

15082
        ELSE IF(m==4) THEN

15083
          LocalInds(1) = n + j2

15084
          LocalInds(2) = j3

15085
          LocalInds(3) = j4

15086


15087
          SgnNode = 3

15088
          iCase = 12

15089
        END IF

15090


15091
      END IF

15092


15093
    CASE( 40411 ) 

15094
      ! Quadrilateral being cut on one edge and one node.  

15095


15096
      ! Find the only edge that is cut

15097
      DO j=1,4

15098
        IF( ElemCut( n + j ) ) EXIT

15099
      END DO

15100
      j2 = MODULO(j,4)+1

15101
      j3 = MODULO(j+1,4)+1

15102
      j4 = MODULO(j+2,4)+1

15103


15104
      ! IF we cut node associated to the same edge, we don't really have a split element,

15105
      IF(ElemCut(j) .OR. ElemCut(j2)) THEN

15106
        LocalInds(1:4) = [1,2,3,4]

15107
        iCase = 13

15108
        SgnNode = j3          

15109
        mmax = 1

15110
      ELSE

15111
        mmax = 2

15112
        IF( ElemCut(j3) ) THEN

15113
          IF(m==1) THEN

15114
            LocalInds(1) = n + j

15115
            LocalInds(2) = j2

15116
            LocalInds(3) = j3

15117
            LocalInds(4) = j4

15118


15119
            iCase = 14

15120
            SgnNode = 3

15121
          ELSE IF(m==2) THEN

15122
            LocalInds(1) = j

15123
            LocalInds(2) = n + j

15124
            LocalInds(3) = j4

15125


15126
            iCase = 15

15127
            SgnNode = 1

15128
          END IF

15129


15130
        ELSE IF( ElemCut(j4)) THEN

15131
          IF(m==1) THEN

15132
            LocalInds(1) = j

15133
            LocalInds(2) = n + j

15134
            LocalInds(3) = j3

15135
            LocalInds(4) = j4

15136


15137
            iCase = 16

15138
            SgnNode = 4

15139
          ELSE IF(m==2) THEN

15140
            LocalInds(1) = n + j

15141
            LocalInds(2) = j2

15142
            LocalInds(3) = j3

15143


15144
            iCase = 17

15145
            SgnNode = 2

15146
          END IF

15147
        END IF

15148
      END IF

15149
      

15150
    CASE DEFAULT

15151
      PRINT *,'ElemCut:',ElemCut(1:n*n)

15152
      CALL Fatal('SplitSingleElement','Unknown split case in element divisions: '//I2S(SplitCase))

15153
    END SELECT

15154


15155
    IsMore = (m < mmax )

15156
    !IF(iCase>0) nCase(iCase) = nCase(iCase) + 1

15157
    

15158
  END SUBROUTINE SplitSingleElement

15159


15160


15161


15162
  

15163
END MODULE ElementDescription

15164


15165


15166
!> \}

15167


15168