PROGRAM dgMatrixTest

  USE KindModule, ONLY: &
    DP, Pi
  USE QuadratureModule, ONLY: &
    InitializeQuadratures, &
    GetQuadrature
  USE UtilitiesModule, ONLY: &
    WriteVector, &
    WriteMatrix
  USE PolynomialBasisModule_Lagrange, ONLY: &
    LagrangeP, &
    dLagrangeP

  IMPLICIT NONE

  INCLUDE 'mpif.h'

  INTEGER  :: i1, i2, i3, iNode
  INTEGER  :: j1, j2, j3, jNode
  INTEGER  :: k1, k2, k3, kNode
  INTEGER  :: q1, q2, q3
  INTEGER  :: mpierr
  INTEGER  :: NodeNumberTable2D_G4(2,16)
  INTEGER  :: NodeNumberTable2D_G5(2,25)
  INTEGER  :: NodeNumberTable3D(3,64)
  REAL(DP) :: wTime
  REAL(DP) :: xG4(4), wG4(4), xG5(5), wG5(5)
  REAL(DP) :: xL4(4), wL4(4)
  REAL(DP) :: xL(3), xR(3), dX(3)
  REAL(DP) :: xN_L(3,64), xN(3,64)
  REAL(DP) :: J_L(64), J  (64)
  REAL(DP) :: g11_L(64), g22_L(64), g33_L(64)
  REAL(DP) :: g11  (64), g22  (64), g33  (64)
  REAL(DP) :: sg11_L(64), sg22_L(64), sg33_L(64)
  REAL(DP) :: sg11  (64), sg22  (64), sg33  (64)
  REAL(DP) :: w(64), w1(16), w2(16), w3(16)
  REAL(DP) :: L_L2G(64,64)
  REAL(DP) :: L_G2L(64,64)
  REAL(DP) :: L1L_4(16,64), L1H_4(16,64)
  REAL(DP) :: L1L_5(25,64), L1H_5(25,64)
  REAL(DP) :: L2L_4(16,64), L2H_4(16,64)
  REAL(DP) :: L2L_5(25,64), L2H_5(25,64)
  REAL(DP) :: L3L_4(16,64), L3H_4(16,64)
  REAL(DP) :: L3L_5(25,64), L3H_5(25,64)
  REAL(DP) :: dLdX1(64,64), dLdX2(64,64), dLdX3(64,64)
  REAL(DP) :: M0ij_4(64,64), M0ij_5(64,64)
  REAL(DP) :: M1ijL_4(64,16), M1ijH_4(64,16)
  REAL(DP) :: M2ijL_4(64,16), M2ijH_4(64,16)
  REAL(DP) :: M3ijL_4(64,16), M3ijH_4(64,16)
  REAL(DP) :: Mij_4 (64,64), Mij_5 (64,64)
  REAL(DP) :: S1ij_4(64,64), S1ij_5(64,64)
  REAL(DP) :: S2ij_4(64,64), S2ij_5(64,64)
  REAL(DP) :: S3ij_4(64,64), S3ij_5(64,64)

  CALL MPI_INIT( mpierr )

  ! --- Create Node Number Tables ---

  iNode = 1
  DO i3 = 1, 4
    DO i2 = 1, 4
      DO i1 = 1, 4

        NodeNumberTable3D(1:3,iNode) = [ i1, i2, i3 ]

        iNode = iNode + 1

      END DO
    END DO
  END DO

  iNode = 1
  DO i3 = 1, 4
    DO i2 = 1, 4

      NodeNumberTable2D_G4(1:2,iNode) = [ i2, i3 ]

      iNode = iNode + 1

    END DO
  END DO

  iNode = 1
  DO i3 = 1, 5
    DO i2 = 1, 5

      NodeNumberTable2D_G5(1:2,iNode) = [ i2, i3 ]

      iNode = iNode + 1

    END DO
  END DO

  CALL InitializeQuadratures

  ! --- Gaussian Quadrature ---

  CALL GetQuadrature( 4, xG4, wG4, 'Gaussian' )
  CALL GetQuadrature( 5, xG5, wG5, 'Gaussian' )

  ! --- Lobatto Quadrature ---

  CALL GetQuadrature( 4, xL4, wL4, 'Lobatto' )

  ! --- Define Element ---

  xL = [ 0.0_DP, 0.0_DP, 1.0_DP * Pi ]
  xR = [ 1.0_DP, Pi/4.0_DP, 2.0_DP * Pi ]
  dX = xR - xL

  CALL WriteVector( 3, xL, 'xL.dat' )
  CALL WriteVector( 3, xR, 'xH.dat' )
  CALL WriteVector( 3, dX, 'dX.dat' )

  ! --- Compute Geometry Fields in Lobatto Points ---

  DO iNode = 1, 64

    i1 = NodeNumberTable3D(1,iNode)
    i2 = NodeNumberTable3D(2,iNode)
    i3 = NodeNumberTable3D(3,iNode)

    xN_L(:,iNode) = xL + dX * ( 0.5_DP + [ xL4(i1), xL4(i2), xL4(i3) ] )
    xN  (:,iNode) = xL + dX * ( 0.5_DP + [ xG4(i1), xG4(i2), xG4(i3) ] )

    g11_L(iNode) = 1.0_DP
    g22_L(iNode) = xN_L(1,iNode)**2
    g33_L(iNode) = xN_L(1,iNode)**2 * SIN( xN_L(2,iNode) )**2

    J_L(iNode) = SQRT( ( xN_L(1,iNode)**2 * SIN( xN_L(2,iNode) ) )**2 )

    sg11_L(iNode) = 1.0_DP
    sg22_L(iNode) = xN_L(1,iNode)
    sg33_L(iNode) = xN_L(1,iNode) * SIN( xN_L(2,iNode) )

  END DO

  ! --- Write Global Node Coordinates ---

  CALL WriteVector( 64, xN(1,:), 'x1.dat' )
  CALL WriteVector( 64, xN(2,:), 'x2.dat' )
  CALL WriteVector( 64, xN(3,:), 'x3.dat' )

  ! --- Transformation Matrix Lobatto -> Gaussian: L_L2G ---
  ! --- Transformation Matrix Gaussian -> Lobatto: L_G2L ---

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      L_L2G(iNode,jNode) &
        = LagrangeP  (xG4(i1),j1,xL4,4) &
          * LagrangeP(xG4(i2),j2,xL4,4) &
          * LagrangeP(xG4(i3),j3,xL4,4)

      L_G2L(iNode,jNode) &
        = LagrangeP  (xL4(i1),j1,xG4,4) &
          * LagrangeP(xL4(i2),j2,xG4,4) &
          * LagrangeP(xL4(i3),j3,xG4,4)

    END DO

  END DO

  CALL WriteMatrix( 64, 64, L_L2G, 'L_L2G.dat' )

  CALL WriteMatrix( 64, 64, L_G2L, 'L_G2L.dat' )

  ! --- Compute Geometry Fields in Gaussian Points ---

  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, g11_L, 1, 0.0_DP, g11, 1 )
  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, g22_L, 1, 0.0_DP, g22, 1 )
  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, g33_L, 1, 0.0_DP, g33, 1 )
  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, J_L,   1, 0.0_DP, J,   1 )

  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, sg11_L, 1, 0.0_DP, sg11, 1 )
  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, sg22_L, 1, 0.0_DP, sg22, 1 )
  CALL DGEMV( 'N', 64, 64, 1.0_DP, L_L2G, 64, sg33_L, 1, 0.0_DP, sg33, 1 )

  CALL WriteVector( 64, g11, 'g11.dat' )
  CALL WriteVector( 64, g22, 'g22.dat' )
  CALL WriteVector( 64, g33, 'g33.dat' )
  CALL WriteVector( 64, J_L, 'J_L.dat' )
  CALL WriteVector( 64, J,   'J.dat'   )
  CALL WriteVector( 64, sg11, 'sg11.dat' )
  CALL WriteVector( 64, sg22, 'sg22.dat' )
  CALL WriteVector( 64, sg33, 'sg33.dat' )

  ! --- Compute Volume Integral Weights ---

  DO iNode = 1, 64

    i1 = NodeNumberTable3D(1,iNode)
    i2 = NodeNumberTable3D(2,iNode)
    i3 = NodeNumberTable3D(3,iNode)

    w(iNode) = 0.0_DP

    DO q3 = 1, 4
      DO q2 = 1, 4
        DO q1 = 1, 4

          w(iNode) &
            = w(iNode) &
                + wG4(q1) * wG4(q2) * wG4(q3) &
                  * LagrangeP(XG4(q1),i1,xG4,4) &
                  * LagrangeP(XG4(q2),i2,xG4,4) &
                  * LagrangeP(XG4(q3),i3,xG4,4)

        END DO
      END DO
    END DO

  END DO

  CALL WriteVector( 64, w, 'w.dat' )

  ! --- Compute Surface Integral Weights ---

  ! --- Dimension 1 ---

  DO iNode = 1, 16

    i2 = NodeNumberTable2D_G4(1,iNode)
    i3 = NodeNumberTable2D_G4(2,iNode)

    w1(iNode) = 0.0_DP

    DO q3 = 1, 4
      DO q2 = 1, 4

        w1(iNode) &
          = w1(iNode) &
              + wG4(q2) * wG4(q3) &
                * LagrangeP(xG4(q2),i2,XG4,4) &
                * LagrangeP(xG4(q3),i3,XG4,4)

      END DO
    END DO

  END DO

  ! --- Dimension 2 ---

  DO iNode = 1, 16

    i1 = NodeNumberTable2D_G4(1,iNode)
    i3 = NodeNumberTable2D_G4(2,iNode)

    w2(iNode) = 0.0_DP

    DO q3 = 1, 4
      DO q1 = 1, 4

        w2(iNode) &
          = w2(iNode) &
              + wG4(q1) * wG4(q3) &
                * LagrangeP(xG4(q1),i1,XG4,4) &
                * LagrangeP(xG4(q3),i3,XG4,4)

      END DO
    END DO

  END DO

  ! --- Dimension 3 ---

  DO iNode = 1, 16

    i1 = NodeNumberTable2D_G4(1,iNode)
    i2 = NodeNumberTable2D_G4(2,iNode)

    w3(iNode) = 0.0_DP

    DO q2 = 1, 4
      DO q1 = 1, 4

        w3(iNode) &
          = w3(iNode) &
              + wG4(q1) * wG4(q2) &
                * LagrangeP(xG4(q1),i1,XG4,4) &
                * LagrangeP(xG4(q2),i2,XG4,4)

      END DO
    END DO

  END DO

  CALL WriteVector( 16, w1, 'w1.dat' )
  CALL WriteVector( 16, w2, 'w2.dat' )
  CALL WriteVector( 16, w3, 'w3.dat' )

  ! --- Interpolation Matrices ---

  ! --- Dimension 1 ---

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 16

      i2 = NodeNumberTable2D_G4(1,iNode)
      i3 = NodeNumberTable2D_G4(2,iNode)

      L1L_4(iNode,jNode) &
        = LagrangeP( - 0.5_DP,j1,xG4,4) &
          * LagrangeP(xG4(i2),j2,xG4,4) &
          * LagrangeP(xG4(i3),j3,xG4,4)

      L1H_4(iNode,jNode) &
        = LagrangeP( + 0.5_DP,j1,xG4,4) &
          * LagrangeP(xG4(i2),j2,xG4,4) &
          * LagrangeP(xG4(i3),j3,xG4,4)

    END DO

    DO iNode = 1, 25

      i2 = NodeNumberTable2D_G5(1,iNode)
      i3 = NodeNumberTable2D_G5(2,iNode)

      L1L_5(iNode,jNode) &
        = LagrangeP( - 0.5_DP,j1,xG4,4) &
          * LagrangeP(xG5(i2),j2,xG4,4) &
          * LagrangeP(xG5(i3),j3,xG4,4)

      L1H_5(iNode,jNode) &
        = LagrangeP( + 0.5_DP,j1,xG4,4) &
          * LagrangeP(xG5(i2),j2,xG4,4) &
          * LagrangeP(xG5(i3),j3,xG4,4)

    END DO

  END DO

  ! --- Dimension 2 ---

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 16

      i1 = NodeNumberTable2D_G4(1,iNode)
      i3 = NodeNumberTable2D_G4(2,iNode)

      L2L_4(iNode,jNode) &
        = LagrangeP  (xG4(i1),j1,xG4,4) &
          * LagrangeP(-0.5_DP,j2,xG4,4) &
          * LagrangeP(xG4(i3),j3,xG4,4)

      L2H_4(iNode,jNode) &
        = LagrangeP  (xG4(i1),j1,xG4,4) &
          * LagrangeP(+0.5_DP,j2,xG4,4) &
          * LagrangeP(xG4(i3),j3,xG4,4)

    END DO

    DO iNode = 1, 25

      i1 = NodeNumberTable2D_G5(1,iNode)
      i3 = NodeNumberTable2D_G5(2,iNode)

      L2L_5(iNode,jNode) &
        = LagrangeP  (xG5(i1),j1,xG4,4) &
          * LagrangeP(-0.5_DP,j2,xG4,4) &
          * LagrangeP(xG5(i3),j3,xG4,4)

      L2H_5(iNode,jNode) &
        = LagrangeP  (xG5(i1),j1,xG4,4) &
          * LagrangeP(+0.5_DP,j2,xG4,4) &
          * LagrangeP(xG5(i3),j3,xG4,4)

    END DO

  END DO

  ! --- Dimension 3 ---

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 16

      i1 = NodeNumberTable2D_G4(1,iNode)
      i2 = NodeNumberTable2D_G4(2,iNode)

      L3L_4(iNode,jNode) &
        = LagrangeP  (xG4(i1),j1,xG4,4) &
          * LagrangeP(xG4(i2),j2,xG4,4) &
          * LagrangeP(-0.5_DP,j3,xG4,4)

      L3H_4(iNode,jNode) &
        = LagrangeP  (xG4(i1),j1,xG4,4) &
          * LagrangeP(xG4(i2),j2,xG4,4) &
          * LagrangeP(+0.5_DP,j3,xG4,4)

    END DO

    DO iNode = 1, 25

      i1 = NodeNumberTable2D_G5(1,iNode)
      i2 = NodeNumberTable2D_G5(2,iNode)

      L3L_5(iNode,jNode) &
        = LagrangeP  (xG5(i1),j1,xG4,4) &
          * LagrangeP(xG5(i2),j2,xG4,4) &
          * LagrangeP(-0.5_DP,j3,xG4,4)

      L3H_5(iNode,jNode) &
        = LagrangeP  (xG5(i1),j1,xG4,4) &
          * LagrangeP(xG5(i2),j2,xG4,4) &
          * LagrangeP(+0.5_DP,j3,xG4,4)

    END DO

  END DO

  CALL WriteMatrix( 16, 64, L1L_4, 'L1L_4.dat' )
  CALL WriteMatrix( 16, 64, L1H_4, 'L1H_4.dat' )

  CALL WriteMatrix( 25, 64, L1L_5, 'L1L_5.dat' )
  CALL WriteMatrix( 25, 64, L1H_5, 'L1H_5.dat' )

  CALL WriteMatrix( 16, 64, L2L_4, 'L2L_4.dat' )
  CALL WriteMatrix( 16, 64, L2H_4, 'L2H_4.dat' )

  CALL WriteMatrix( 25, 64, L2L_5, 'L2L_5.dat' )
  CALL WriteMatrix( 25, 64, L2H_5, 'L2H_5.dat' )

  CALL WriteMatrix( 16, 64, L3L_4, 'L3L_4.dat' )
  CALL WriteMatrix( 16, 64, L3H_4, 'L3H_4.dat' )

  CALL WriteMatrix( 25, 64, L3L_5, 'L3L_5.dat' )
  CALL WriteMatrix( 25, 64, L3H_5, 'L3H_5.dat' )

  ! --- Derivative Matrices ---

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      dLdX1(iNode,jNode) &
        = dLagrangeP (xG4(i1),j1,xG4,4) &
          * LagrangeP(xG4(i2),j2,xG4,4) &
          * LagrangeP(xG4(i3),j3,xG4,4)

      dLdX2(iNode,jNode) &
        = LagrangeP   (xG4(i1),j1,xG4,4) &
          * dLagrangeP(xG4(i2),j2,xG4,4) &
          * LagrangeP (xG4(i3),j3,xG4,4)

      dLdX3(iNode,jNode) &
        = LagrangeP   (xG4(i1),j1,xG4,4) &
          * LagrangeP (xG4(i2),j2,xG4,4) &
          * dLagrangeP(xG4(i3),j3,xG4,4)

    END DO

  END DO

  CALL WriteMatrix( 64, 64, dLdX1, 'dLdX1.dat' )
  CALL WriteMatrix( 64, 64, dLdX2, 'dLdX2.dat' )
  CALL WriteMatrix( 64, 64, dLdX3, 'dLdX3.dat' )

  ! --- Flux Integration Matrices ---

  ! --- Dimension 1 ---

  DO jNode = 1, 16

    j2 = NodeNumberTable2D_G4(1,jNode)
    j3 = NodeNumberTable2D_G4(2,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      M1ijL_4(iNode,jNode) = 0.0_DP
      M1ijH_4(iNode,jNode) = 0.0_DP

      DO q3 = 1, 4
        DO q2 = 1, 4

          M1ijL_4(iNode,jNode) &
            = M1ijL_4(iNode,jNode) &
                + wG4(q2) * wG4(q3) &
                  ! ---
                  * LagrangeP(-0.5_DP,i1,xG4,4) &
                  * LagrangeP(xG4(q2),i2,xG4,4) &
                  * LagrangeP(xG4(q3),i3,xG4,4) &
                  ! ---
                  * LagrangeP(xG4(q2),j2,xG4,4) &
                  * LagrangeP(xG4(q3),j3,xG4,4)

          M1ijH_4(iNode,jNode) &
            = M1ijH_4(iNode,jNode) &
                + wG4(q2) * wG4(q3) &
                  ! ---
                  * LagrangeP(+0.5_DP,i1,xG4,4) &
                  * LagrangeP(xG4(q2),i2,xG4,4) &
                  * LagrangeP(xG4(q3),i3,xG4,4) &
                  ! ---
                  * LagrangeP(xG4(q2),j2,xG4,4) &
                  * LagrangeP(xG4(q3),j3,xG4,4)

        END DO
      END DO

    END DO

  END DO

  ! --- Dimension 2 ---

  DO jNode = 1, 16

    j1 = NodeNumberTable2D_G4(1,jNode)
    j3 = NodeNumberTable2D_G4(2,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      M2ijL_4(iNode,jNode) = 0.0_DP
      M2ijH_4(iNode,jNode) = 0.0_DP

      DO q3 = 1, 4
        DO q1 = 1, 4

          M2ijL_4(iNode,jNode) &
            = M2ijL_4(iNode,jNode) &
                + wG4(q1) * wG4(q3) &
                  ! ---
                  * LagrangeP(xG4(q1),i1,xG4,4) &
                  * LagrangeP(-0.5_DP,i2,xG4,4) &
                  * LagrangeP(xG4(q3),i3,xG4,4) &
                  ! ---
                  * LagrangeP(xG4(q1),j1,xG4,4) &
                  * LagrangeP(xG4(q3),j3,xG4,4)

          M2ijH_4(iNode,jNode) &
            = M2ijH_4(iNode,jNode) &
                + wG4(q1) * wG4(q3) &
                  ! ---
                  * LagrangeP(xG4(q1),i1,xG4,4) &
                  * LagrangeP(+0.5_DP,i2,xG4,4) &
                  * LagrangeP(xG4(q3),i3,xG4,4) &
                  ! ---
                  * LagrangeP(xG4(q1),j1,xG4,4) &
                  * LagrangeP(xG4(q3),j3,xG4,4)

        END DO
      END DO

    END DO

  END DO

  ! --- Dimension 3 ---

  DO jNode = 1, 16

    j1 = NodeNumberTable2D_G4(1,jNode)
    j2 = NodeNumberTable2D_G4(2,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      M3ijL_4(iNode,jNode) = 0.0_DP
      M3ijH_4(iNode,jNode) = 0.0_DP

      DO q2 = 1, 4
        DO q1 = 1, 4

          M3ijL_4(iNode,jNode) &
            = M3ijL_4(iNode,jNode) &
                + wG4(q1) * wG4(q2) &
                  ! ---
                  * LagrangeP(xG4(q1),i1,xG4,4) &
                  * LagrangeP(xG4(q2),i2,xG4,4) &
                  * LagrangeP(-0.5_DP,i3,xG4,4) &
                  ! ---
                  * LagrangeP(xG4(q1),j1,xG4,4) &
                  * LagrangeP(xG4(q2),j2,xG4,4)

          M3ijH_4(iNode,jNode) &
            = M3ijH_4(iNode,jNode) &
                + wG4(q1) * wG4(q2) &
                  ! ---
                  * LagrangeP(xG4(q1),i1,xG4,4) &
                  * LagrangeP(xG4(q2),i2,xG4,4) &
                  * LagrangeP(+0.5_DP,i3,xG4,4) &
                  ! ---
                  * LagrangeP(xG4(q1),j1,xG4,4) &
                  * LagrangeP(xG4(q2),j2,xG4,4)

        END DO
      END DO

    END DO

  END DO

  CALL WriteMatrix( 64, 16, M1ijL_4, 'M1ijL_4.dat' )
  CALL WriteMatrix( 64, 16, M1ijH_4, 'M1ijH_4.dat' )

  CALL WriteMatrix( 64, 16, M2ijL_4, 'M2ijL_4.dat' )
  CALL WriteMatrix( 64, 16, M2ijH_4, 'M2ijH_4.dat' )

  CALL WriteMatrix( 64, 16, M3ijL_4, 'M3ijL_4.dat' )
  CALL WriteMatrix( 64, 16, M3ijH_4, 'M3ijH_4.dat' )

  ! --- Compute Triple Index Mass Matrices ---

  wTime = MPI_WTIME( )

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      M0ij_4(iNode,jNode) = 0.0_DP
      M0ij_5(iNode,jNode) = 0.0_DP

      DO kNode = 1, 64

        k1 = NodeNumberTable3D(1,kNode)
        k2 = NodeNumberTable3D(2,kNode)
        k3 = NodeNumberTable3D(3,kNode)

        ! --- 4-Point Gaussian Quadrature

        DO q3 = 1, 4
          DO q2 = 1, 4
            DO q1 = 1, 4

              M0ij_4(iNode,jNode) &
                = M0ij_4(iNode,jNode) &
                  + wG4(q1)*wG4(q2)*wG4(q3) &
                    ! ---
                    * LagrangeP(xG4(q1),k1,xG4,4) &
                    * LagrangeP(xG4(q2),k2,xG4,4) &
                    * LagrangeP(xG4(q3),k3,xG4,4) &
                    ! ---
                    * LagrangeP(xG4(q1),i1,xG4,4) &
                    * LagrangeP(xG4(q2),i2,xG4,4) &
                    * LagrangeP(xG4(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG4(q1),j1,xG4,4) &
                    * LagrangeP(xG4(q2),j2,xG4,4) &
                    * LagrangeP(xG4(q3),j3,xG4,4) &
                    * J(kNode)

            END DO
          END DO
        END DO

        ! --- 5-Point Gaussian Quadrature

        DO q3 = 1, 5
          DO q2 = 1, 5
            DO q1 = 1, 5

              M0ij_5(iNode,jNode) &
                = M0ij_5(iNode,jNode) &
                  + wG5(q1)*wG5(q2)*wG5(q3) &
                    ! ---
                    * LagrangeP(xG5(q1),k1,xG4,4) &
                    * LagrangeP(xG5(q2),k2,xG4,4) &
                    * LagrangeP(xG5(q3),k3,xG4,4) &
                    ! ---
                    * LagrangeP(xG5(q1),i1,xG4,4) &
                    * LagrangeP(xG5(q2),i2,xG4,4) &
                    * LagrangeP(xG5(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG5(q1),j1,xG4,4) &
                    * LagrangeP(xG5(q2),j2,xG4,4) &
                    * LagrangeP(xG5(q3),j3,xG4,4) &
                    * J(kNode)

            END DO
          END DO
        END DO

      END DO
    END DO
  END DO

  wTime = MPI_WTIME( ) - wTime

  PRINT*
  PRINT*, "  M(0): ", wTime
  PRINT*

  ! --- Remove Numerical Noise ---

  DO jNode = 1, 64
    DO iNode = 1, 64

      IF( ABS( M0ij_4(iNode,jNode) ) < 1.0d-12 ) &
        M0ij_4(iNode,jNode) = 0.0_DP

      IF( ABS( M0ij_5(iNode,jNode) ) < 1.0d-12 ) &
        M0ij_5(iNode,jNode) = 0.0_DP

    END DO
  END DO

  CALL WriteMatrix( 64, 64, M0ij_4, 'M0ij_4.dat' )

  CALL WriteMatrix( 64, 64, M0ij_5, 'M0ij_5.dat' )

  ! --- Compute Mass and Stiffness Matrices ---

  wTime = MPI_WTIME( )

  wTime = MPI_WTIME( )

  DO jNode = 1, 64

    j1 = NodeNumberTable3D(1,jNode)
    j2 = NodeNumberTable3D(2,jNode)
    j3 = NodeNumberTable3D(3,jNode)

    DO iNode = 1, 64

      i1 = NodeNumberTable3D(1,iNode)
      i2 = NodeNumberTable3D(2,iNode)
      i3 = NodeNumberTable3D(3,iNode)

      ! --- 4-Point Gaussian Quadrature

      Mij_4 (iNode,jNode) = 0.0_DP
      S1ij_4(iNode,jNode) = 0.0_DP
      S2ij_4(iNode,jNode) = 0.0_DP
      S3ij_4(iNode,jNode) = 0.0_DP

      DO q3 = 1, 4
        DO q2 = 1, 4
          DO q1 = 1, 4

            Mij_4(iNode,jNode) &
              = Mij_4(iNode,jNode) &
                  + wG4(q1)*wG4(q2)*wG4(q3) &
                    ! ---
                    * LagrangeP(xG4(q1),i1,xG4,4) &
                    * LagrangeP(xG4(q2),i2,xG4,4) &
                    * LagrangeP(xG4(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG4(q1),j1,xG4,4) &
                    * LagrangeP(xG4(q2),j2,xG4,4) &
                    * LagrangeP(xG4(q3),j3,xG4,4)

            S1ij_4(iNode,jNode) &
              = S1ij_4(iNode,jNode) &
                  + wG4(q1)*wG4(q2)*wG4(q3) &
                    ! ---
                    * dLagrangeP(xG4(q1),i1,xG4,4) &
                    *  LagrangeP(xG4(q2),i2,xG4,4) &
                    *  LagrangeP(xG4(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG4(q1),j1,xG4,4) &
                    * LagrangeP(xG4(q2),j2,xG4,4) &
                    * LagrangeP(xG4(q3),j3,xG4,4)

            S2ij_4(iNode,jNode) &
              = S2ij_4(iNode,jNode) &
                  + wG4(q1)*wG4(q2)*wG4(q3) &
                    ! ---
                    *  LagrangeP(xG4(q1),i1,xG4,4) &
                    * dLagrangeP(xG4(q2),i2,xG4,4) &
                    *  LagrangeP(xG4(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG4(q1),j1,xG4,4) &
                    * LagrangeP(xG4(q2),j2,xG4,4) &
                    * LagrangeP(xG4(q3),j3,xG4,4)

            S3ij_4(iNode,jNode) &
              = S3ij_4(iNode,jNode) &
                  + wG4(q1)*wG4(q2)*wG4(q3) &
                    ! ---
                    *  LagrangeP(xG4(q1),i1,xG4,4) &
                    *  LagrangeP(xG4(q2),i2,xG4,4) &
                    * dLagrangeP(xG4(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG4(q1),j1,xG4,4) &
                    * LagrangeP(xG4(q2),j2,xG4,4) &
                    * LagrangeP(xG4(q3),j3,xG4,4)

          END DO
        END DO
      END DO

      ! --- 5-Point Gaussian Quadrature

      Mij_5 (iNode,jNode) = 0.0_DP
      S1ij_5(iNode,jNode) = 0.0_DP
      S2ij_5(iNode,jNode) = 0.0_DP
      S3ij_5(iNode,jNode) = 0.0_DP

      DO q3 = 1, 5
        DO q2 = 1, 5
          DO q1 = 1, 5

            Mij_5(iNode,jNode) &
              = Mij_5(iNode,jNode) &
                  + wG5(q1)*wG5(q2)*wG5(q3) &
                    ! ---
                    * LagrangeP(xG5(q1),i1,xG4,4) &
                    * LagrangeP(xG5(q2),i2,xG4,4) &
                    * LagrangeP(xG5(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG5(q1),j1,xG4,4) &
                    * LagrangeP(xG5(q2),j2,xG4,4) &
                    * LagrangeP(xG5(q3),j3,xG4,4)

            S1ij_5(iNode,jNode) &
              = S1ij_5(iNode,jNode) &
                  + wG5(q1)*wG5(q2)*wG5(q3) &
                    ! ---
                    * dLagrangeP(xG5(q1),i1,xG4,4) &
                    *  LagrangeP(xG5(q2),i2,xG4,4) &
                    *  LagrangeP(xG5(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG5(q1),j1,xG4,4) &
                    * LagrangeP(xG5(q2),j2,xG4,4) &
                    * LagrangeP(xG5(q3),j3,xG4,4)

            S2ij_5(iNode,jNode) &
              = S2ij_5(iNode,jNode) &
                  + wG5(q1)*wG5(q2)*wG5(q3) &
                    ! ---
                    *  LagrangeP(xG5(q1),i1,xG4,4) &
                    * dLagrangeP(xG5(q2),i2,xG4,4) &
                    *  LagrangeP(xG5(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG5(q1),j1,xG4,4) &
                    * LagrangeP(xG5(q2),j2,xG4,4) &
                    * LagrangeP(xG5(q3),j3,xG4,4)

            S3ij_5(iNode,jNode) &
              = S3ij_5(iNode,jNode) &
                  + wG5(q1)*wG5(q2)*wG5(q3) &
                    ! ---
                    *  LagrangeP(xG5(q1),i1,xG4,4) &
                    *  LagrangeP(xG5(q2),i2,xG4,4) &
                    * dLagrangeP(xG5(q3),i3,xG4,4) &
                    ! ---
                    * LagrangeP(xG5(q1),j1,xG4,4) &
                    * LagrangeP(xG5(q2),j2,xG4,4) &
                    * LagrangeP(xG5(q3),j3,xG4,4)

          END DO
        END DO
      END DO

    END DO

  END DO

  wTime = MPI_WTIME( ) - wTime

  PRINT*
  PRINT*, "  M and Si: ", wTime
  PRINT*

  CALL WriteMatrix( 64, 64, Mij_4,  'Mij_4.dat'  )

  CALL WriteMatrix( 64, 64, Mij_5,  'Mij_5.dat'  )

  CALL WriteMatrix( 64, 64, S1ij_4, 'S1ij_4.dat' )

  CALL WriteMatrix( 64, 64, S1ij_5, 'S1ij_5.dat' )

  CALL WriteMatrix( 64, 64, S1ij_4, 'S1ij_4.dat' )

  CALL WriteMatrix( 64, 64, S1ij_5, 'S1ij_5.dat' )

  CALL WriteMatrix( 64, 64, S2ij_4, 'S2ij_4.dat' )

  CALL WriteMatrix( 64, 64, S2ij_5, 'S2ij_5.dat' )

  CALL WriteMatrix( 64, 64, S3ij_4, 'S3ij_4.dat' )

  CALL WriteMatrix( 64, 64, S3ij_5, 'S3ij_5.dat' )

  CALL MPI_FINALIZE( mpierr )

END PROGRAM dgMatrixTest


      SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve a system of linear equations
C        H * X = B,  H' * X = B  or  H**H * X = B
C     with a complex upper Hessenberg N-by-N matrix H using the LU
C     factorization computed by MB02SZ.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANS   CHARACTER*1
C             Specifies the form of the system of equations:
C             = 'N':  H * X = B  (No transpose)
C             = 'T':  H'* X = B  (Transpose)
C             = 'C':  H**H * X = B  (Conjugate transpose)
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix H.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of right hand sides, i.e., the number of
C             columns of the matrix B.  NRHS >= 0.
C
C     H       (input) COMPLEX*16 array, dimension (LDH,N)
C             The factors L and U from the factorization H = P*L*U
C             as computed by MB02SZ.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     IPIV    (input) INTEGER array, dimension (N)
C             The pivot indices from MB02SZ; for 1<=i<=N, row i of the
C             matrix was interchanged with row IPIV(i).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
C             On entry, the right hand side matrix B.
C             On exit, the solution matrix X.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     INFO    (output) INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine uses the factorization
C        H = P * L * U
C     where P is a permutation matrix, L is lower triangular with unit
C     diagonal elements (and one nonzero subdiagonal), and U is upper
C     triangular.
C
C     REFERENCES
C
C     -
C
C     NUMERICAL ASPECTS
C                                2
C     The algorithm requires 0( N x NRHS ) complex operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TB01FW by A.J. Laub, University of
C     Southern California, United States of America, May 1980.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Frequency response, Hessenberg form, matrix algebra.
C
C     ******************************************************************
C
C     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, LDH, N, NRHS
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         B( LDB, * ), H( LDH, * )
C     .. Local Scalars ..
      LOGICAL            NOTRAN
      INTEGER            J, JP
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           XERBLA, ZAXPY, ZSWAP, ZTRSM
C     .. Intrinsic Functions ..
      INTRINSIC          DCONJG, MAX
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02RZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
C
      IF( NOTRAN ) THEN
C
C        Solve H * X = B.
C
C        Solve L * X = B, overwriting B with X.
C
C        L is represented as a product of permutations and unit lower
C        triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
C        where each transformation L(i) is a rank-one modification of
C        the identity matrix.
C
         DO 10 J = 1, N - 1
            JP = IPIV( J )
            IF( JP.NE.J )
     $         CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB )
            CALL ZAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ),
     $                  LDB )
   10    CONTINUE
C
C        Solve U * X = B, overwriting B with X.
C
         CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, H, LDH, B, LDB )
C
      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
C
C        Solve H' * X = B.
C
C        Solve U' * X = B, overwriting B with X.
C
         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
     $               H, LDH, B, LDB )
C
C        Solve L' * X = B, overwriting B with X.
C
         DO 20 J = N - 1, 1, -1
            CALL ZAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ),
     $                  LDB )
            JP = IPIV( J )
            IF( JP.NE.J )
     $         CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB )
   20    CONTINUE
C
      ELSE
C
C        Solve H**H * X = B.
C
C        Solve U**H * X = B, overwriting B with X.
C
         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,
     $               H, LDH, B, LDB )
C
C        Solve L**H * X = B, overwriting B with X.
C
         DO 30 J = N - 1, 1, -1
            CALL ZAXPY( NRHS, -DCONJG( H( J+1, J ) ), B( J+1, 1 ), LDB,
     $                  B( J, 1 ), LDB )
            JP = IPIV( J )
            IF( JP.NE.J )
     $         CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB )
   30    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of MB02RZ ***
      END


c *****************************************************
c    kernel.F for GCD+ pv.30.7
c 20 Aug., 2008   written by D. Kawata
c *****************************************************
c70*******************************************************************
      subroutine setkernel()

      include './define.f'
      integer i,j
      double precision f,cv,s

      ds_tb=1.0d0/dble(NKTAB+1)

c *** W: SPH kernel ***
c *** for constant ***
      cv=8.0d0/M_PI
      do i=0,NKTAB
        s_tb(i)=ds_tb*dble(i)
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(1.0d0-6.0d0*(s**2)+6.0d0*(s**3))
        else if(s.le.1.0d0) then
          f=(2.0d0*((1.0d0-s)**3))
        else
          f=0.0d0
        endif
        w_tb(i)=cv*f
      enddo
c *** dW(s)/ds/s: SPH kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=-12.0d0+18.0d0*s
        else if(s.le.1.0d0) then
          f=-6.0d0*((1.0d0-s)**2)/s
        else
          f=0.0d0
        endif
        dwds_s_tb(i)=cv*f
c *** core dw/ds ***
        if(s.le.THIRD) then
          f=-2.0d0
        else if(s.le.0.5d0) then
          f=-12.0d0*s+18.0d0*s*s
        else if(s.le.1.0d0) then
          f=-6.0d0*((1.0d0-s)**2)
        else
          f=0.0d0
        endif
        dwdsc_tb(i)=cv*f
      enddo

c *** dphi/dr/r: phi kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(32.0d0/15.0d0)
     &     *(5.0d0-18.0d0*(s**2)+15.0d0*(s**3))
        else if(s.le.1.0d0) then
          f=(4.0d0/15.0d0)
     &     *(80.0d0*s-180.0d0*(s**2)+144.0d0*(s**3)
     &     -40.0d0*(s**4)-0.25d0/(s**2))/s
        endif
        dphidr_r_tb(i)=f
      enddo
c *** dphi/dh: phi kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=-40.0d0*(s**2)+120.0d0*(s**4)-96.0d0*(s**5)+7.0d0
        else if(s.le.1.0d0) then
          f=-80.0d0*(s**2)+160.0d0*(s**3)-120.0d0*(s**4)
     &      +32.0d0*(s**5)+8.0d0
        endif
        dphidh_tb(i)=0.4d0*f
      enddo
c *** for multipole ***
c *** d2phi/dr2 ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(32.0d0/15.0d0)
     &     *(5.0d0-54.0d0*(s**2)+60.0d0*(s**3))
        else if(s.le.1.0d0) then
          f=(4.0d0/15.0d0)
     &     *(80.0d0-360.0d0*s+432.0d0*(s**2)
     &     -160.0d0*(s**3)+2.0d0/(4.0d0*(s**3)))
        endif
        d2phidr2_tb(i)=f
      enddo
c *** d3phi/dr3 ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(32.0d0/15.0d0)
     &     *(-108.0d0*s+180.0d0*(s**2))
        else if(s.le.1.0d0) then
          f=(4.0d0/15.0d0)
     &     *(-360.0d0+864.0d0*s
     &     -480.0d0*(s**2)-6.0d0/(4.0d0*(s**4)))
        endif
        d3phidr3_tb(i)=f
      enddo

      return
      end


subroutine getaa(ndim,np)

! generates a matrix with ndim columns and ntot [=sum_{i=1}^{ndim} np(i)]
! rows which can be used to transform ndim nested loops into a single loop
!
! e.g.
! do i=1,np(1)
!	do j=1,np(2)
!		do k=1,np(3)
!			write(*,*)i,j,k
!		enddo
!	enddo
! enddo
!
! is equivalent to
!
! call getaa(3,np,aa)
! do i=1,np(1)*np(2)*np(3)
!	write(*,*)aa(1,i),aa(2,i),aa(3,i)
! enddo
!
!

use share, only: aa,ntot

implicit none

!input/output
integer, intent(in)			:: ndim
integer, intent(in)			:: np(ndim)

!local
integer					::	i,j
integer					::    	istat !allocate status var
integer					::	v(ndim) !values
integer					::	c(ndim)	!counters
integer					::	nr(ndim)!number of repetitions

if (allocated(aa)) deallocate(aa)
allocate(aa(ndim,ntot),stat=istat)
call checkstat(istat,'aa')

!write(*,*)'ntot=',ntot

!initialize counters and values for the indices
!set number of repetitions
do i=1,ndim
   v(i)=1
   c(i)=0
   nr(i)=1
   do j=i+1,ndim
   	nr(i)=nr(i)*np(j)
   enddo
   !write(*,*)c(i),v(i),nr(i)
enddo

do i=1,ntot
	do j=1,ndim
		c(j)=c(j)+1
		if (c(j) > nr(j)) then
			v(j)=v(j)+1
			c(j)=1
			if (v(j) > np(j)) then
				v(j)=1
			endif
		endif
		aa(j,i)=v(j)
	enddo
	!write(*,*)aa(:,i)
enddo

end subroutine getaa


subroutine sort3(x,y,z,imax,iloc)

! sort -k 3, 2, 1

 implicit none
 integer::imax,i,iloc(imax),k,kk,itmp
 real,dimension(imax)::x,y,z,x0,y0,z0
 real::xtmp,ytmp,ztmp

  z0=z ; y0=y ; x0=x

  do i=1,imax
     iloc(i)=i
  enddo

  do i=1,imax-1
     ztmp=z(i) ; ytmp=y(i) ; xtmp=x(i) ; kk=i
     itmp=iloc(i)
     do k=i+1,imax
        if(ztmp>z(k)) then
           ztmp=z(k) ; ytmp=y(k) ; xtmp=x(k) ; kk=k
           itmp=iloc(k)
        else if(ztmp==z(k)) then
           if(ytmp>y(k)) then
              ztmp=z(k) ; ytmp=y(k) ; xtmp=x(k) ; kk=k
              itmp=iloc(k)
           else if(ytmp==y(k)) then
              if(xtmp>x(k)) then
                 ztmp=z(k) ; ytmp=y(k) ; xtmp=x(k) ; kk=k
                 itmp=iloc(k)
              endif
           endif
        endif
     enddo
     z(kk)=z(i) ; y(kk)=y(i) ; x(kk)=x(i) ; iloc(kk)=iloc(i)
     z(i)=ztmp ; y(i)=ytmp ; x(i)=xtmp ; iloc(i)=itmp
  enddo
  return
end subroutine sort3


! { dg-do run }
! Test the fix for PR41706, in which arguments of class methods that
! were themselves class methods did not work.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
!
module m
type :: t
  real :: v = 1.5
contains
  procedure, nopass :: a
  procedure, nopass :: b
  procedure, pass :: c
  procedure, nopass :: d
end type

contains

  real function a (x)
    real :: x
    a = 2.*x
  end function

  real function b (x)
    real :: x
    b = 3.*x
  end function

  real function c (x)
    class (t) :: x
    c = 4.*x%v
  end function

  subroutine d (x)
    real :: x
    if (abs(x-3.0)>1E-3) call abort()
  end subroutine

  subroutine s (x)
    class(t) :: x
    real :: r
    r = x%a (1.1)       ! worked
    if (r .ne. a (1.1)) call abort

    r = x%a (b (1.2))   ! worked
    if (r .ne. a(b (1.2))) call abort

    r = b ( x%a (1.3))  ! worked
    if (r .ne. b(a (1.3))) call abort

    r = x%a(x%b (1.4))   ! failed
    if (r .ne. a(b (1.4))) call abort

    r = x%a(x%c ())   ! failed
    if (r .ne. a(c (x))) call abort

    call x%d (x%a(1.5))  ! failed

  end subroutine

end

  use m
  class(t),allocatable :: x
  allocate(x)
  call s (x)
end


program test_chirp

use fwdmodel, only: chirp
use comm, only: wp,c_int

implicit none (type, external)

real(wp),parameter :: bm=10e6_wp !Hz
real(wp),parameter :: tm=0.01_wp !second
real(wp),parameter :: fs=10e6_wp !Hz
real(wp),parameter :: nlfm=0._wp

integer(c_int),parameter  :: Ntarg = 2
real(wp),parameter :: Atarg(Ntarg)=[0.001_wp, 0.002_wp]
real(wp),parameter :: range_m(Ntarg)=[5._wp, 7._wp]

integer(c_int) :: Ns
complex(wp), allocatable :: y(:,:)
real(wp), allocatable :: t(:)
integer(c_int) :: i

Ns = int(tm*fs)
allocate(y(Ns,Ntarg), t(Ns))

print *, Ns,' samples'

! time vector
do concurrent (i=1:Ns)
  t(i) = (i-1)/fs
enddo

call chirp(bm,tm,t,Ns,range_m,Atarg,Ntarg,nlfm,y)

end program


! julia.f90
!
! Julia set demo for EGGX/ProCALL.
!
! Author:  Philipp Engel
! Licence: ISC
program main
    use, intrinsic :: iso_c_binding, only: c_null_char
    use :: procall
    implicit none

    character(len=*), parameter :: WIN_TITLE  = 'Fortran Julia Set'
    integer,          parameter :: WIN_WIDTH  = 800
    integer,          parameter :: WIN_HEIGHT = 600
    integer,          parameter :: MAX_ITER   = 256

    integer :: key
    integer :: j
    integer :: r, g, b
    integer :: win
    integer :: x, y

    call gopen(WIN_WIDTH, WIN_HEIGHT, win)          ! Open X11 window.
    call winname(win, WIN_TITLE // c_null_char)     ! Set window title.
    call gsetbgcolor(win, 'black' // c_null_char)   ! Set background colour.
    call gclr(win)                                  ! Clear drawing area.

    do y = 0, WIN_HEIGHT - 1
        do x = 0, WIN_WIDTH - 1
            j  = julia(x, y, WIN_WIDTH, WIN_HEIGHT, 1.0, 0.0, 0.0, cmplx(-0.7, 0.27015), MAX_ITER)
            call makecolor(PROCALL_IDL1_STERN_SPECIAL, 0.0, real(MAX_ITER), real(j), r, g, b)
            call newrgbcolor(win, r, g, b)
            call pset(win, real(x), real(y))
        end do
    end do

    call ggetch(key)
    call gcloseall()
contains
    function julia(x, y, width, height, zoom, mx, my, c, max_iter)
        integer, intent(in) :: x, y, width, height
        real,    intent(in) :: zoom, mx, my
        complex, intent(in) :: c
        integer, intent(in) :: max_iter
        integer             :: i, julia
        complex             :: z

        julia = 0

        z = cmplx(1.5 * (x - width / 2) / (0.5 * zoom * width) + mx, &
                  1.0 * (y - height / 2) / (0.5 * zoom * height) + my)

        do i = 1, max_iter
            z = z**2 + c

            if (abs(z) > 2) then
                julia = i
                exit
            end if
        end do
    end function julia
end program main


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE ELECOR (NDIM, NELBLK, LEN, NLNK, LINK,
     &   XN, YN, ZN, XE, YE, ZE)
C=======================================================================

C   --*** ELECOR *** (BLOT) Calculate element centers
C   --   Written by Amy Gilkey, revised 10/23/87
C   --
C   --ELECOR calculates the element centers from the nodal coordinates.
C   --
C   --Parameters:
C   --   NDIM - IN - the number of dimensions
C   --   NELBLK - IN - the number of element blocks
C   --   LEN - IN - the cumulative element counts by element block
C   --   NLNK - IN - the number of nodes per element
C   --   LINK - IN - the connectivity array; connectivity all zero if
C   --      element is undefined
C   --   XN, YN, ZN - IN - the nodal coordinates
C   --   XE, YE, ZE - OUT - the element center coordinates

      INTEGER LEN(0:*), LINK(*)
      INTEGER NLNK(*)
      REAL XN(*), YN(*), ZN(*)
      REAL XE(*), YE(*), ZE(*)

      DO 170 IELB = 1, NELBLK
         IF (NLNK(IELB) .LE. 0) GOTO 170

         DIVLNK = 1.0 / NLNK(IELB)

         IXL0 = IDBLNK (IELB, 0, LEN, NLNK) - 1
         IF (NDIM .EQ. 2) THEN
            IF (NLNK(IELB) .NE. 8) THEN
               DO 110 IEL = LEN(IELB-1)+1, LEN(IELB)
                  X0 = 0.0
                  Y0 = 0.0
                  IF (LINK(IXL0+1) .NE. 0) THEN
                     DO 100 I = 1, NLNK(IELB)
                        X0 = X0 + XN(LINK(IXL0+I))
                        Y0 = Y0 + YN(LINK(IXL0+I))
  100                CONTINUE
                  END IF
                  XE(IEL) = X0 * DIVLNK
                  YE(IEL) = Y0 * DIVLNK
                  IXL0 = IXL0 + NLNK(IELB)
  110          CONTINUE

            ELSE IF (NLNK(IELB) .EQ. 8) THEN
C            --Note that 8-node elements are numbered with corners at 1-3-5-7
               DO 140 IEL = LEN(IELB-1)+1, LEN(IELB)
                  X0 = 0.0
                  Y0 = 0.0
                  IF (LINK(IXL0+1) .NE. 0) THEN
                     DO 120 I = 1, NLNK(IELB), 2
                        X0 = X0 - 0.25 * XN(LINK(IXL0+I))
                        Y0 = Y0 - 0.25 * YN(LINK(IXL0+I))
  120                CONTINUE
                     DO 130 I = 2, NLNK(IELB), 2
                        X0 = X0 + 0.5 * XN(LINK(IXL0+I))
                        Y0 = Y0 + 0.5 * YN(LINK(IXL0+I))
  130                CONTINUE
                  END IF
                  XE(IEL) = X0
                  YE(IEL) = Y0
                  IXL0 = IXL0 + NLNK(IELB)
  140          CONTINUE
            END IF

         ELSE IF (NDIM .EQ. 3) THEN
            DO 160 IEL = LEN(IELB-1)+1, LEN(IELB)
               X0 = 0.0
               Y0 = 0.0
               Z0 = 0.0
               IF (LINK(IXL0+1) .NE. 0) THEN
                  DO 150 I = 1, NLNK(IELB)
                     X0 = X0 + XN(LINK(IXL0+I))
                     Y0 = Y0 + YN(LINK(IXL0+I))
                     Z0 = Z0 + ZN(LINK(IXL0+I))
  150             CONTINUE
               END IF
               XE(IEL) = X0 * DIVLNK
               YE(IEL) = Y0 * DIVLNK
               ZE(IEL) = Z0 * DIVLNK
               IXL0 = IXL0 + NLNK(IELB)
  160       CONTINUE
         END IF
  170 CONTINUE

      RETURN
      END


! =====================================================================
! function VXV
!
! This function computes the expectation value of any potential operator,
! except for the nonlinear, mean-field interaction potential of the GPE.
! ---------------------------------------------------------------------
      double precision function VXV(nRP,nR,nP,RdRP,V,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: RdRP(nR)
      double precision :: V(nRP)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double precision :: XV

      VXV = 0.0d0

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            XV = V(k)*cdabs(U(k))**2
            VXV = VXV + XV*RdRP(i)
         enddo
      enddo

      return
      end
! =====================================================================


      Subroutine dload(f, kstep, kinc, time, noel, npt, layer, kspt,
     1coords, jltyp, sname)

c
      include 'ABA_PARAM.INC'
c
c    形参定义
      DIMENSION TIME(2), COORDS (3)
      Character *80 sname
      Real :: f
      Integer :: noel, kinc, kspt, jltyp, kstep, layer, npt

c     内参定义
c    形参说明：
c	X：双精度实型一维数组，存放矩形区域X方向的N个坐标值
c	Y：双精度实型一维数组，存放矩形区域Y方向的M个坐标值
c	Z: 双精度实型二维数组，体积为NXM,输入参数，存放矩形区域上的N*M个节点上的函数值
c	N：整型变量，输入参数，矩形区域X方向的坐标个数
c	M: 整型变量，输入参数，矩形区域X方向的坐标个数
c	U，V：双精度实型变量，输入参数，存放指定插值点的X、Y坐标
c	W：双精度实型变量，输出参数，存放指定（U，Y）处的函数近似值。
      Real :: z(86, 431),x(431),y(76)
      Real :: uu,fresult
      Integer :: rc,i,j
      Character :: blankLine
      Dimension b(10)
      Real :: u, v, w, b, hh
c     Implicit None
       jltyp=2
c     读取Z文件信息
      Open (101,FILE="D:\abaqusTemp\Fz.txt",STATUS='OLD',ACTION='READ')

      Read (101, *) x
C        Write (*, *) x
      Read (101, *) y
C        Write (*, *) y
      Do j = 1, 75
        Read (101, *,IOSTAT=ios) z(:, j)
C          Write (*, *) z(:, j)
        if (ios.NE.0) then
            write(*,*) "******some thing wrong happened****"
            f=10000
            exit
          endif
      EndDo
       close(101)
       write(*,*) "***************read load***********************"
      x = x/1000
      y = y/1000
C       Close (101)
C c     读取R文件信息
C c
C c
C c
C c
C c
C c
C c     开始计算力的大小,插值计算
      u = coords(1)
      v = coords(2)

      If (u<=x(1)) Then
        ip = 1
        ipp = 4
      Else If (u>=x(n)) Then
      ip = n - 3
      ipp = n
      Else
        i = 1
        j = n
10      If (iabs(i-j)/=1) Then
          l = (i+j)/2
          If (u<x(l)) Then
            j = l
          Else
            i = l
          End If
          Goto 10
        End If
        ip = i - 3
        ipp = i + 4
      End If
      If (ip<1) ip = 1
      If (ipp>n) ipp = n
      If (v<=y(1)) Then
        iq = 1
        iqq = 4
      Else If (v>=y(m)) Then
        iq = m - 3
        iqq = m
      Else
        i = 1
        j = m

20    If (iabs(j-i)/=1) Then
          l = (i+j)/2
          If (v<y(l)) Then
            j = l
          Else
            i = l
          End If
          Goto 20
        End If
        iq = i - 3
        iqq = i + 4
      End If
      If (iq<1) iq = 1
      If (iqq>m) iqq = m
      Do i = ip, ipp
        b(i-ip+1) = 0.0
        Do j = iq, iqq
          hh = z(i, j)
          Do k = iq, iqq
            If (k/=j) Then
              hh = hh*(v-y(k))/(y(j)-y(k))
            End If
          End Do
          b(i-ip+1) = b(i-ip+1) + hh
        End Do
      End Do
      w = 0.0
      Do i = ip, ipp
        hh = b(i-ip+1)
        Do j = ip, ipp
          If (j/=i) Then
            hh = hh*(u-x(j))/(x(i)-x(j))
          End If
        End Do
        w = w + hh
      End Do
      f = w
       write(*,*) "*************get load ******************"

      Return
      End