C************************************************************
C  Subroutine GENE_ELLIPSE to generate a portion of an ellipse
C  in the arrays XX(NPOINTS), YY(NPOINTS).   (NPOINTS<1000)
C  Called by FITELLI and compatible with EFIT
C
C NPOINT : (output) number of points in the arrays XX and YY
C THEMI,THEMA: limiting angles in degrees
C ARRAY Z : REAL*8 !
C Z(1): major axis
C Z(2): minor axis
C Z(3): THETA0 in radians
C Z(4): OX
C Z(5): OY
C
C IOPT=0 : COMPLETE ELLIPSE
C IOPT=1 : PART OF AN ELLIPSE
C
C JLP
C Version 02-02-96
C************************************************************
	SUBROUTINE GENE_ELLIPSE(XX,YY,NPOINT,Z,THEMI,THEMA,IOPT)
	REAL*4 XX(1),YY(1)
	REAL*8 Z(5),THEMI,THEMA
        REAL*4 THETA_RAD,THETA0_RAD
	REAL*4 OX,OY,THETA0,MAJAXIS,MINAXIS,PI
        INTEGER*4 IOPT
	CHARACTER*4 NCHAR
	PI=ACOS(-1.)

	MAJAXIS=SNGL(Z(1))
	MINAXIS=SNGL(Z(2))
	THETA0=SNGL(Z(3))*180./PI
	OX=SNGL(Z(4))
	OY=SNGL(Z(5))

	IF(IOPT.EQ.1)THEN

	ECCEN=MINAXIS/MAJAXIS
	THEMI0=THEMI-THETA0
	THEMA0=THEMA-THETA0

	THEMIN=ELLIP_LIMIT(THEMI0,ECCEN)
	THEMAX=ELLIP_LIMIT(THEMA0,ECCEN)
	IF(THEMIN.GT.THEMAX)THEMIN=THEMIN-360.

	ELSE

	THEMIN=0.
	THEMAX=360.

	ENDIF

C Generating the ellipse (Step=.361 degree , i.e. less than 1000 pts max)
	THETA=THEMIN
        THETA0_RAD=THETA0*PI/180.
	JJ=0
94	IF (THETA.GT.THEMAX) GOTO 95
	JJ=JJ+1
        THETA_RAD=THETA*PI/180.
	CALL ELLIP(THETA_RAD,XX(JJ),YY(JJ),OX,OY,THETA0_RAD,MAJAXIS,MINAXIS)
	THETA=THETA+0.361
	GOTO 94

95	NPOINT=JJ
	RETURN
	END
C*******************************************************************
C Computing XX,YY for a given value of THETA (degrees):
C*******************************************************************
	SUBROUTINE ELLIP(THETA_RAD,X,Y,OX,OY,THETA0_RAD,MAJAXIS,MINAXIS)
	REAL*4 OX,OY,THETA0,MAJAXIS,MINAXIS
        REAL*4 THETA_RAD,THETA0_RAD
C Ellipse centred on (0.,0.) and with major axis OX
	XXX=MAJAXIS*COS(THETA_RAD)
	YYY=MINAXIS*SIN(THETA_RAD)
C Rotation of THETA0 and translation to (OX,OY)
	X=OX+COS(THETA0_RAD)*XXX-SIN(THETA0_RAD)*YYY
	Y=OY+SIN(THETA0_RAD)*XXX+COS(THETA0_RAD)*YYY
	RETURN
	END
C*******************************************************************
C Function ELLIP_LIMIT to compute the angular limits of an arc of ellipse
C taking into account the effects of the eccentricity
C*******************************************************************
	REAL FUNCTION ELLIP_LIMIT(THEMI0,ECCEN)
        REAL PI,THEMI0_RAD
	PI=ACOS(-1.)
        THEMI0_RAD=THEMI0*PI/180.
	 IF(COS(THEMI0_RAD).EQ.0)THEN
	   ELLIP_LIMIT=THEMI0
	 ELSE
	   TGTMIN=TAN(THEMI0_RAD)/ECCEN
	   THEMIN=ATAN(TGTMIN)*180./PI
	   IF(COS(THEMI0_RAD).LT.0.)THEMIN=THEMIN+180.
	   ELLIP_LIMIT=THEMIN
	 ENDIF
	END


      SUBROUTINE MA02FD( X1, X2, C, S, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients c and s (c^2 + s^2 = 1) for a modified
C     hyperbolic plane rotation, such that,
C
C         y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2),
C         y2 :=  -s * y1 +  c  * x2 = 0,
C
C     given two real numbers x1 and x2, satisfying either x1 = x2 = 0,
C     or abs(x2) < abs(x1).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     X1      (input/output) DOUBLE PRECISION
C             On entry, the real number x1.
C             On exit, the real number y1.
C
C     X2      (input) DOUBLE PRECISION
C             The real number x2.
C             The values x1 and x2 should satisfy either x1 = x2 = 0, or
C             abs(x2) < abs(x1).
C
C     C       (output) DOUBLE PRECISION
C             The cosines c of the modified hyperbolic plane rotation.
C
C     S       (output) DOUBLE PRECISION
C             The sines s of the modified hyperbolic plane rotation.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  succesful exit;
C             = 1:  if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, June 2000.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 2000.
C
C     KEYWORDS
C
C     Orthogonal transformation, plane rotation.
C
C     *****************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  X1, X2, C, S
      INTEGER           INFO
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SIGN, SQRT
C     .. Executable Statements ..
C
      IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND.
     $     ABS( X2 ).GE.ABS( X1 ) ) THEN
         INFO = 1
      ELSE
         INFO = 0
         IF ( X1.EQ.ZERO ) THEN
            S = ZERO
            C = ONE
         ELSE
            S = X2 / X1
C
C           No overflows could appear in the next statement; underflows
C           are possible if X2 is tiny and X1 is huge, but then
C              abs(C) = ONE - delta,
C           where delta is much less than machine precision.
C
            C  = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 )
            X1 = C * X1
         END IF
      END IF
C
      RETURN
C *** Last line of MA02FD ***
      END


!! R445 type-bound-procedure-part
!    is contains-stmt [ binding-private-stmt ] [ type-bound-proc-binding ] ...
!
! NOTE 4.43

module myjunk

TYPE POINT
  REAL :: X, Y
CONTAINS
  PROCEDURE, PASS :: LENGTH => POINT_LENGTH
END TYPE POINT

contains

REAL FUNCTION POINT_LENGTH (A, B)
  CLASS (POINT), INTENT (IN) :: A, B
  POINT_LENGTH = SQRT ( (A%X - B%X)**2 + (A%Y - B%Y)**2 )
END FUNCTION POINT_LENGTH

end module


      MODULE MOD_FLGRID

      CONTAINS

      SUBROUTINE FLGRID(NFLDIM, NFL, PHI, PWEIGHT, DELTAX)

!     FREQUENCY SCALE ETC. FOR THE CMF LINE CALCULATIONS
!     NFL          NUMBER OF FREQUENCY POINTS (ORIGINAL POINTS)
!     XMAX         MAXIMUM FREQUENCY
!     XK           FREQUENCY POINTS (FALLING, DOPPLER UNITS) -  NOT STORED
!     PHI(K)       NORMALIZED LINE PROFILE
!     PWEIGHT(K)   RENORMALIZED INTEGRATION WEIGHTS

      IMPLICIT REAL*8(A - H, O - Z)

      DIMENSION PHI(NFLDIM), PWEIGHT(NFLDIM)

!     WPI = SQRT(PI)
      DATA WPI /1.7724538509055D0/

      XMAX = 6.7D0
      NFL = 61

      IF (NFL .GT. NFLDIM) STOP "FLGRID: DIMENSION IS TOO SMALL"

      DELTAX = 2.D0 * XMAX / FLOAT(NFL - 1)
      WS = 0.0D0

      DO K = 1, NFL

         XK = XMAX - (K - 1) * DELTAX

         PWEIGHT(K) = EXP(-XK * XK)

         WS = WS + PWEIGHT(K)

         PHI(K) = EXP(-XK * XK) / WPI

      ENDDO

!     RENORMALIZATION
      DO K = 1, NFL; PWEIGHT(K) = PWEIGHT(K) / WS; ENDDO

      RETURN

      END SUBROUTINE

      END MODULE


      REAL FUNCTION DCAL(RCELL,IH,IK,IL)
      IMPLICIT NONE
C
      REAL RCELL(6)
      REAL RH,RK,RL
      INTEGER IH,IK,IL
C
      RH = FLOAT(IH)
      RK = FLOAT(IK)
      RL = FLOAT(IL)
C
      DCAL = SQRT(RH*RH*RCELL(1)*RCELL(1) +
     &            RK*RK*RCELL(2)*RCELL(2) +
     &            RL*RL*RCELL(3)*RCELL(3) +
     &            2.0*RK*RL*RCELL(2)*RCELL(3)*COS(RCELL(4)) +
     &            2.0*RL*RH*RCELL(3)*RCELL(1)*COS(RCELL(5)) +
     &            2.0*RH*RK*RCELL(1)*RCELL(2)*COS(RCELL(6)))
      RETURN
C
      END


program Heapsort_Demo
  implicit none

  integer, parameter :: num = 20
  real :: array(num)

  call random_seed
  call random_number(array)
  write(*,*) "Unsorted array:-"
  write(*,*) array
  write(*,*)
  call heapsort(array)
  write(*,*) "Sorted array:-"
  write(*,*) array

contains

subroutine heapsort(a)

   real, intent(in out) :: a(0:)
   integer :: start, n, bottom
   real :: temp

   n = size(a)
   do start = (n - 2) / 2, 0, -1
     call siftdown(a, start, n);
   end do

   do bottom = n - 1, 1, -1
     temp = a(0)
     a(0) = a(bottom)
     a(bottom) = temp;
     call siftdown(a, 0, bottom)
   end do

end subroutine heapsort

subroutine siftdown(a, start, bottom)

  real, intent(in out) :: a(0:)
  integer, intent(in) :: start, bottom
  integer :: child, root
  real :: temp

  root = start
  do while(root*2 + 1 < bottom)
    child = root * 2 + 1

    if (child + 1 < bottom) then
      if (a(child) < a(child+1)) child = child + 1
    end if

    if (a(root) < a(child)) then
      temp = a(child)
      a(child) = a (root)
      a(root) = temp
      root = child
    else
      return
    end if
  end do

end subroutine siftdown

end program Heapsort_Demo


!> K.A.Johannessen et al./Compt. Methods Appl. Mech. Engrg 269 (2014) 471-514の2.2.4 Exampleを再現
program main
  use module_globals
  use module_meshline
  use module_LRspline
  implicit none

  !> global tensor knot
  real(8),allocatable :: tn1(:), tn2(:)

  !> LR-spline
  type(LocallyRefinedSpline),pointer :: lrs_

  !> Mesh Line
  type(MeshLine),pointer :: ml_

  ! local variables
  type(LocallyRefinedSpline),pointer :: lrs
  type(MeshLine),pointer :: ml

  ! initialise
  call init_LRspline(lrs_)
  call init_meshline(ml_)

  ! tensor mesh = Bspline の global knotを設定
  ncp(1)=6
  ncp(2)=6
  ncp(0)=(ncp(1)+1)*(ncp(2)+1)
  allocate(tn1(0:ncp(1)+ndeg(1)+1))
  allocate(tn2(0:ncp(2)+ndeg(2)+1))
  tn1=[0.d0,0.d0,0.d0,1.d0,2.d0,4.d0,5.d0,6.d0,6.d0,6.d0]/6.d0
  tn2=[0.d0,0.d0,0.d0,1.d0,2.d0,4.d0,5.d0,6.d0,6.d0,6.d0]/6.d0

  ! tensor mesh の local knot を設定 = Bspline の knot
  call set_Bspline(lrs_,tn1,tn2)

  ! 適当なsurfaceを設定
  call set_Greville(lrs_)
  lrs=>lrs_
  do while(associated(lrs))
     lrs%cp(3)=cos(2.d0*pi*lrs%cp(1))*sin(2.d0*pi*lrs%cp(2))
     lrs=>lrs%next
  end do

  ! draw itinial Bspline
  call draw_LRmesh(lrs_,"LRmesh.res")
  call draw_controlpoints(lrs_,"controlpoints.res")
  call draw_surface(lrs_,50,"surface.res")

  ! set meshlines
  call append_meshline(ml_,1,3.d0/6.d0,1.d0/6.d0,5.d0/6.d0)
  call append_meshline(ml_,2,3.d0/6.d0,1.d0/6.d0,5.d0/6.d0)

  ! draw meshline
  call draw_meshline(ml_,"meshline.res")

  ! refine LR-splines
  ml=>ml_
  do while(associated(ml))
     call refine_LRspline(lrs_,ml_,ml)
     ml=>ml%next
  end do

  ! draw refined LR-spline
  call draw_LRmesh(lrs_,"LRmesh2.res")
  call draw_controlpoints(lrs_,"controlpoints2.res")
  call draw_surface(lrs_,50,"surface2.res")

  ! finalise
  deallocate(tn1,tn2)
  call uninit_meshline(ml_)
  call uninit_LRspline(lrs_)

end program main


module interpol_mod

use constants_mod

integer, parameter :: RP = selected_real_kind(15)
!real(dp), parameter :: PI = 4.0_rp * atan(1.0_rp)
!real(dp), parameter :: TOL = 4.0e-16

CONTAINS

!pure     SUBROUTINE DiffMatrix(x,N,D)
!        IMPLICIT NONE
!        INTEGER, INTENT(IN)                             :: N
!        real(dp)(KIND=RP), DIMENSION(0:N), INTENT(IN)       :: x
!        real(dp)(KIND=RP), DIMENSION(0:N,0:N), INTENT(OUT)  :: D
!!
!        ! lokale Variablen
!        INTEGER                                         :: i,j
!        real(dp)(KIND=RP), DIMENSION(0:N)                   :: w
!!
!        ! Baryzentrische Gewichte bestimmen
!        CALL BarycentricWeights(x,N,w)
!        ! DiffMatrix gemaess Aufg.1e) befuellen
!        DO i=0,N
!            DO j=0,N
!                IF (i.NE.j) THEN
!                    D(i,j) = w(j) / ( w(i) * (x(i)-x(j)) )
!                    ! auf der Diagonalen alle anderen subtrahieren
!                    D(i,i) = D(i,i) - D(i,j)
!                END IF
!            END DO
!        END DO
!!
!        RETURN
!!
!    END SUBROUTINE DiffMatrix

pure SUBROUTINE BarycentricWeights(N_in,xGP,wBary)
IMPLICIT NONE
!----------------------------------------------------------------------------------------------------------------------------------
! INPUT/OUTPUT VARIABLES
INTEGER,INTENT(IN) :: N_in               !< polynomial degree
real(dp),INTENT(IN)    :: xGP(0:N_in)        !< Gauss point positions for the reference interval [-1,1]
real(dp),INTENT(OUT)   :: wBary(0:N_in)      !< barycentric weights
!----------------------------------------------------------------------------------------------------------------------------------
! LOCAL VARIABLES
INTEGER            :: iGP,jGP
!==================================================================================================================================
wBary(:)=1.
DO iGP=1,N_in
  DO jGP=0,iGP-1
    wBary(jGP)=wBary(jGP)*(xGP(jGP)-xGP(iGP))
    wBary(iGP)=wBary(iGP)*(xGP(iGP)-xGP(jGP))
  END DO ! jGP
END DO ! iGP
wBary(:)=1./wBary(:)
END SUBROUTINE BarycentricWeights

pure SUBROUTINE DiffMatrix(N_in,xGP,D)
IMPLICIT NONE
!----------------------------------------------------------------------------------------------------------------------------------
! INPUT/OUTPUT VARIABLES
INTEGER,INTENT(IN) :: N_in              !< polynomial degree
real(dp),INTENT(IN)    :: xGP(0:N_in)       !< Gauss point positions for the reference interval [-1,1]
real(dp),INTENT(OUT)   :: D(0:N_in,0:N_in)  !< differentiation Matrix
!----------------------------------------------------------------------------------------------------------------------------------
! LOCAL VARIABLES
INTEGER            :: iGP,iLagrange
real(dp)               :: wBary(0:N_in)
!==================================================================================================================================
CALL BarycentricWeights(N_in,xGP,wBary)
D(:,:)=0.
DO iLagrange=0,N_in
  DO iGP=0,N_in
    IF(iLagrange.NE.iGP)THEN
      D(iGP,iLagrange)=wBary(iLagrange)/(wBary(iGP)*(xGP(iGP)-xGP(iLagrange)))
      D(iGP,iGP)=D(iGP,iGP)-D(iGP,iLagrange)
    END IF ! (iLagrange.NE.iGP)
  END DO ! iGP
END DO ! iLagrange
END SUBROUTINE

pure function LagrangePolynomialDerivative(N, xs, j, x) result(lp)

    integer, intent(in)     :: N
    real(dp), intent(in)    :: xs(N)
    integer, intent(in)     :: j
    real(dp), intent(in)    :: x

    real(dp)                :: lp
    real(dp)                :: acc
    integer                 :: i,m

    lp = 0.0_dp

    do i = 1,N
        if (i == j) cycle
        acc = 1.0_dp
        do m = 1,N
            if (m == i .or. m == j) cycle
            acc = acc * (x-xs(m))/(xs(j)-xs(m))
        end do
        lp = lp + acc/(xs(j)-xs(i))
    end do

end function

pure function LagrangePolynomialDerivativeMatrix(N,M, xs, ys) result(mat)

    integer, intent(in)     :: N,M
    real(dp), intent(in)    :: xs(N),ys(M)

    real(dp)                :: mat(M,N)
    integer                 :: i,j

    do i = 1,M; do j = 1,N;
        mat(i,j) = LagrangePolynomialDerivative(N,xs,j,ys(i))
    end do; end do

end function

pure function LagrangePolynomial(n, nodes, j, x) result(lp)

    integer, intent(in) :: n
    real(dp), intent(in) :: nodes(0:)
    integer, intent(in) :: j
    real(dp), intent(in) :: x

    real(dp) :: lp
    integer :: i

    lp = 1.0_dp
    do i = 0,n-1
        if (i == j) cycle
        lp = lp * (x - nodes(i))/(nodes(j) - nodes(i))
    end do

end function

pure     SUBROUTINE LagrangeInterpolatingPolynomials(y,x,w,N,l)

!(Algorithm 34)

        IMPLICIT NONE
        INTEGER, INTENT(IN)                         :: N
        real(dp), INTENT(IN)                   :: y
        real(dp), DIMENSION(0:N), INTENT(IN)   :: x,w
        real(dp), DIMENSION(0:N), INTENT(OUT)  :: l
    !
        ! lokale Variablen
        LOGICAL                                     :: stuetzstelle
        INTEGER                                     :: j
        real(dp)                               :: s,t
        real(dp), PARAMETER                    :: tol = 10.0E-16_dp
    !
        ! Falls y eine Stuetzstelle ist:
        stuetzstelle = .FALSE.
        DO j=0,N
            l(j) = 0.0_RP
            IF (ABS(y-x(j)).LT.tol) THEN
                l(j) = 1.0_RP
                stuetzstelle = .TRUE.
            END IF
        END DO
    !
!        IF (stuetzstelle) THEN
!            EXIT
!        END IF

        ! Falls y keine Stuetzstelle ist:
        IF (.NOT. stuetzstelle) THEN
            s = 0.0_RP

            DO j=0,N
                t = w(j) / (y-x(j))
                l(j) = t
                s = s + t
            END DO
            DO j=0,N
                l(j) = l(j)/s
            END DO
        END IF
!
    RETURN
!
    END SUBROUTINE LagrangeInterpolatingPolynomials
!
! ------------------------------------------------------------------------------------------------------------- !
!
pure     SUBROUTINE Evaluation(y,x,f,w,N,f_y)
        IMPLICIT NONE
        INTEGER, INTENT(IN)                         :: N
        real(dp), INTENT(IN)                   :: y
        real(dp), DIMENSION(0:N), INTENT(IN)   :: x,f,w
        real(dp), INTENT(OUT)                   :: f_y
    !
        ! lokale Variablen
        LOGICAL                                     :: stuetzstelle
        INTEGER                                     :: j
        real(dp)                               :: numerator,denominator,hilf
        real(dp), PARAMETER                    :: tol = 1.0E-16_dp
    !
        ! Falls y eine Stuetzstelle ist:
        stuetzstelle = .FALSE.
        DO j=0,N
            IF (ABS(y-x(j)).LT.tol) THEN
                f_y = f(j)
                stuetzstelle = .TRUE.
                EXIT
            END IF
        END DO
    !
        ! Falls y keine Stuetzstelle ist:
        numerator = 0
        denominator = 0
        IF (.NOT. stuetzstelle) THEN
            DO j=0,N
                hilf = w(j) / (y-x(j))
                numerator = numerator + hilf * f(j)
                denominator = denominator + hilf
            END DO
            f_y = numerator / denominator
        END IF
    !
        RETURN
    !
    END SUBROUTINE Evaluation

pure     SUBROUTINE LegendrePolynomialAndDerivativeAlbert(N,x,L_N,dL_N)
        IMPLICIT NONE
        INTEGER, INTENT(IN)         :: N
        real(dp), INTENT(IN)   :: x
        real(dp), INTENT(OUT)  :: L_N,dL_N
    !
        ! lokale Variablen
        INTEGER                     :: k
        real(dp)               :: L_N_1,L_N_2,dL_N_1,dL_N_2
    !
        ! Fuer den einfachsten Fall explizit vorgeben
        IF (N.EQ.0) THEN
            L_N = 0.0_RP
            dL_N = 0.0_RP
    !
        !  Ebenso fuer den zweit-einfachsten Fall
        ELSE IF (N.EQ.1) THEN
            L_N = x
            dL_N = 1.0_RP
    !
        ! Ansonsten auf die 3-Term-Rekursion zurueckgreifen
        ELSE
            ! Dazu wieder die beiden ersten Polynome vorgeben
            L_N_2 = 1.0_RP
            L_N_1 = x
            dL_N_2 = 0.0_RP
            dL_N_1 = 1.0_RP
    !
        DO k=2,N
            ! Rekursionsformel fuer die Legendre-Polynome verwenden
            L_N = ( (2.0_RP*real(k,dP)-1.0_RP) / real(k,dp) ) * x * L_N_1 - (real(k,dP)-1.0_RP) / real(k,dP) * L_N_2
            ! Rekursionsformel fuer die Ableitungen verwenden
            dL_N = dL_N_2 + ( 2.0_RP*real(k,dP) - 1.0_RP ) * L_N_1
            ! Werte fuer den naechsten Schritt updaten
            L_N_2 = L_N_1
            L_N_1 = L_N
            dL_N_2 = dL_N_1
            dL_N_1 = dL_N
        END DO
    !
        END IF
    !
        RETURN
    END SUBROUTINE

pure ELEMENTAL SUBROUTINE LegendrePolynomialAndDerivative(N_in,x,L,Lder)
IMPLICIT NONE
!----------------------------------------------------------------------------------------------------------------------------------
! INPUT/OUTPUT VARIABLES
INTEGER,INTENT(IN) :: N_in   !< (IN)  polynomial degree, (N+1) CLpoints
real(dp),INTENT(IN)    :: x      !< (IN)  coordinate value in the interval [-1,1]
real(dp),INTENT(OUT)   :: L      !< (OUT) Legedre polynomial evaluated at \f$ \xi: L_N(\xi), \partial/\partial\xi L_N(\xi) \f$
real(dp),INTENT(OUT)   :: Lder   !< (OUT) Legedre polynomial deriv. evaluated at \f$ \xi: L_N(\xi), \partial/\partial\xi L_N(\xi) \f$
!----------------------------------------------------------------------------------------------------------------------------------
! LOCAL VARIABLES
INTEGER :: iLegendre
real(dp)    :: L_Nm1,L_Nm2 ! L_{N_in-2},L_{N_in-1}
real(dp)    :: Lder_Nm1,Lder_Nm2 ! Lder_{N_in-2},Lder_{N_in-1}
!==================================================================================================================================
IF(N_in .EQ. 0)THEN
  L=1.0_dp
  Lder=0.0_dp
ELSEIF(N_in .EQ. 1) THEN
  L=x
  Lder=1.0_dp
ELSE ! N_in > 1
  L_Nm2=1.0_dp
  L_Nm1=x
  Lder_Nm2=0.0_dp
  Lder_Nm1=1.0_dp
  DO iLegendre=2,N_in
    L=(real(2*iLegendre-1,dp)*x*L_Nm1 - real(iLegendre-1,dp)*L_Nm2)/real(iLegendre,dp)
    Lder=Lder_Nm2 + real(2*iLegendre-1,dp)*L_Nm1
    L_Nm2=L_Nm1
    L_Nm1=L
    Lder_Nm2=Lder_Nm1
    Lder_Nm1=Lder
  END DO !iLegendre=2,N_in
END IF ! N_in
!normalize
L=L*SQRT(real(N_in,dp)+0.5_dp)
Lder=Lder*SQRT(real(N_in,dp)+0.5_dp)
END SUBROUTINE LegendrePolynomialAndDerivative

pure SUBROUTINE EquidistantNodesAndWeights(N_in,xGP,wGP)

    IMPLICIT NONE

    INTEGER,INTENT(IN)              :: N_in              !< polynomial degree, (N_in+1) Gausspoints
    real(dp),INTENT(OUT)            :: xGP(0:N_in)       !< Gauss point positions for the reference interval [-1,1]
    real(dp),INTENT(OUT),OPTIONAL   :: wGP(0:N_in)       !< Gauss point weights

    integer :: i

    do i = 1,N_IN+1
        xGP(i-1) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N_IN+1,dp)
    end do

    wGP = 2.0_dp/real(N_IN+1,dp)

end subroutine

pure subroutine equidistandinterfacenodes_3times(N,xs,ws)

    implicit none

    integer,intent(in)              :: N
    real(dp),intent(out)            :: xs(N)
    real(dp),intent(out),optional   :: ws(N)

    integer :: i

    do i = 2,N,3
        xs(i-1) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) - 3.0_dp/real(N,dp)
        xs(i+0) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp)
        xs(i+1) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) + 3.0_dp/real(N,dp)
    end do

    !wgp = 2.0/real(n_in+1,dp)
    ws = 0.0_dp

end subroutine

pure subroutine equidistandinterfacenodes(N,xs)

    integer,intent(in)              :: N
    real(dp),intent(out)            :: xs(N)

    integer :: i

    do i = 1,N
        xs(2*i-1) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) - 1.0_dp/real(N,dp)
        xs(2*i+0) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp)
    end do

    xs(2*N+1) = 1.0_dp

end subroutine

pure subroutine InterfaceNodes(N,xL,xC,xR)

    implicit none

    integer,intent(in)      :: N
    real(dp),intent(out)    :: xL(N),xC(N),xR(N)

    integer :: i

    do i = 1,N
        xL(i) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) - 1.0_dp/real(N,dp)
        xC(i) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp)
        xR(i) = -1.0_dp + 2.0_dp*(real(i,dp)-0.5_dp)/real(N,dp) + 1.0_dp/real(N,dp)
    end do

end subroutine

pure SUBROUTINE NodesAndWeights(N_in,xGP,wGP)

    IMPLICIT NONE

    INTEGER,INTENT(IN)        :: N_in              !< polynomial degree, (N_in+1) Gausspoints
    real(dp),INTENT(OUT)          :: xGP(0:N_in)       !< Gauss point positions for the reference interval [-1,1]
    real(dp),INTENT(OUT),OPTIONAL :: wGP(0:N_in)       !< Gauss point weights

    call LegendreGaussNodesAndWeights(N_in, xGP, wGP)

end subroutine

pure SUBROUTINE LegendreGaussNodesAndWeights(N_in,xGP,wGP)

IMPLICIT NONE
!----------------------------------------------------------------------------------------------------------------------------------
! INPUT/OUTPUT VARIABLES
INTEGER,INTENT(IN)        :: N_in              !< polynomial degree, (N_in+1) Gausspoints
real(dp),INTENT(OUT)          :: xGP(0:N_in)       !< Gauss point positions for the reference interval [-1,1]
real(dp),INTENT(OUT),OPTIONAL :: wGP(0:N_in)       !< Gauss point weights
!----------------------------------------------------------------------------------------------------------------------------------
! LOCAL VARIABLES
INTEGER, parameter          :: nIter = 10        ! max. number of newton iterations
real(dp), parameter             :: Tol   = 1.E-15_dp    ! tolerance for Newton iteration: TODO: use variable tolerance here!
INTEGER                   :: iGP,iter
real(dp)                      :: L_Np1,Lder_Np1    ! L_{N_in+1},Lder_{N_in+1}
real(dp)                      :: dx                ! Newton step
real(dp)                      :: cheb_tmp          ! temporary variable for evaluation of chebychev node positions
!==================================================================================================================================
IF(N_in .EQ. 0) THEN
  xGP=0.0_dp
  IF(PRESENT(wGP))wGP=2.0_dp
  RETURN
ELSEIF(N_in.EQ.1)THEN
  xGP(0)=-sqrt(1.0_dp/3.0_dp)
  xGP(N_in)=-xGP(0)
  IF(PRESENT(wGP))wGP=1.0_dp
  RETURN
ELSE ! N_in>1
  cheb_tmp=2.0_dp*atan(1.0_dp)/real(N_in+1,dp) ! pi/(2N+2)
  DO iGP=0,(N_in+1)/2-1 !since points are symmetric, only left side is computed
    xGP(iGP)=-cos(cheb_tmp*real(2*iGP+1,dp)) !initial guess
    ! Newton iteration
    DO iter=0,nIter
      CALL LegendrePolynomialAndDerivative(N_in+1,xGP(iGP),L_Np1,Lder_Np1)
      dx=-L_Np1/Lder_Np1
      xGP(iGP)=xGP(iGP)+dx
      IF(abs(dx).LT.Tol*abs(xGP(iGP))) EXIT
    END DO ! iter
    IF(iter.GT.nIter) THEN
      !WRITE(*,*) 'maximum iteration steps >10 in Newton iteration for Legendre Gausspoint'
      xGP(iGP)=-cos(cheb_tmp*real(2*iGP+1,dp)) !initial guess
      ! Newton iteration
      DO iter=0,nIter
        !WRITE(*,*) iter,xGP(iGP)    !DEBUG
        CALL LegendrePolynomialAndDerivative(N_in+1,xGP(iGP),L_Np1,Lder_Np1)
        dx=-L_Np1/Lder_Np1
        xGP(iGP)=xGP(iGP)+dx
        IF(abs(dx).LT.Tol*abs(xGP(iGP))) EXIT
      END DO !iter
      !CALL abort(__STAMP__,&
      !           'ERROR: Legendre Gauss nodes could not be computed up to desired precision. Code stopped!')
    END IF ! (iter.GT.nIter)
    CALL LegendrePolynomialAndDerivative(N_in+1,xGP(iGP),L_Np1,Lder_Np1)
    xGP(N_in-iGP)=-xGP(iGP)
    IF(PRESENT(wGP))THEN
      !wGP(iGP)=2./((1.-xGP(iGP)*xGP(iGP))*Lder_Np1*Lder_Np1) !if Legendre not normalized
      wGP(iGP)=(2.0_dp*N_in+3)/((1.0_dp-xGP(iGP)*xGP(iGP))*Lder_Np1*Lder_Np1)
      wGP(N_in-iGP)=wGP(iGP)
    END IF
  END DO !iGP
END IF ! N_in
IF(mod(N_in,2) .EQ. 0) THEN
  xGP(N_in/2)=0.
  CALL LegendrePolynomialAndDerivative(N_in+1,xGP(N_in/2),L_Np1,Lder_Np1)
  !IF(PRESENT(wGP))wGP(N_in/2)=2./(Lder_Np1*Lder_Np1) !if Legendre not normalized
  IF(PRESENT(wGP))wGP(N_in/2)=(2.0_dp*N_in+3.0_dp)/(Lder_Np1*Lder_Np1)
END IF ! (mod(N_in,2) .EQ. 0)
END SUBROUTINE LegendreGaussNodesAndWeights

pure     SUBROUTINE qAndLEvaluation(N,x,q,dq,L_N)
        IMPLICIT NONE
        INTEGER, INTENT(IN)         :: N
        real(dp), INTENT(IN)   :: x
        real(dp), INTENT(OUT)  :: L_N,q,dq
    !
        ! lokale Variablen
        INTEGER                     :: k
        real(dp)               :: L_N_1,L_N_2,L_k,dL_N,dL_N_1,dL_N_2,dL_k
    !
        ! NUR FUER N>=2 !
    !
        ! Initialisieren
        L_N_2 = 1.0_RP
        L_N_1 = x
        dL_N_2 = 0.0_RP
        dL_N_1 = 1.0_RP
    !
        DO k=2,N
            ! Rekursionsformel verwenden
            L_N = (2.0_RP*real(k,dP)-1.0_RP)/real(k,dP) * x * L_N_1 - (real(k,dP)-1.0_RP)/real(k,dP) * L_N_2
            ! Rekursionsformel fuer die Ableitungen verwenden
            dL_N = dL_N_2 + (2.0_RP*real(k,dP)-1.0_RP) * L_N_1
            ! Werte fuer den naechsten Schritt updaten
            L_N_2 = L_N_1
            L_N_1 = L_N
            dL_N_2 = dL_N_1
            dL_N_1 = dL_N
        END DO
    !
        ! Einen weiteren Schritt gehen
        k = N+1
        ! Rekursionsformel verwenden
        L_k = (2.0_RP*real(k,dP)-1.0_RP)/real(k,dP) * x * L_N - (real(k,dP)-1.0_RP)/real(k,dP) * L_N_2
        ! Rekursionsformel fuer die Ableitungen verwenden
        dL_k = dL_N_2 + (2.0_RP*real(k,dP)-1.0_RP) * L_N_1
        ! Benoetigtes Polynom und Ableitung bestimmen
        q = L_k - L_N_2
        dq = dL_k - dL_N_2
    !
        RETURN
    END SUBROUTINE qAndLEvaluation
!
! ------------------------------------------------------------------------------------------------------------- !
!
pure     SUBROUTINE LegendreGaussLobattoNodesAndWeights(N,x,w)
        IMPLICIT NONE
        INTEGER, INTENT(IN)                         :: N
        real(dp), DIMENSION(0:N), INTENT(OUT)  :: x,w
    !
        ! lokale Variablen
        INTEGER, PARAMETER            :: n_it = 4
        INTEGER                       :: j,k
        real(dp), PARAMETER      :: tol = 4.0E-16_dp
        real(dp)                 :: q,dq,L_N,Delta

        L_N = 0.0_dp
    !
        ! Fuer den einfachsten Fall Knoten und Gewicht explizit angeben
        IF (N.EQ.1) THEN
            x(0) = -1.0_RP
            w(0) = 1.0_RP
            x(1) = 1.0_RP
            w(1) = w(0)
    !
        ELSE
            ! Randwerte explizit vorgeben
            x(0) = -1.0_RP
            w(0) = 2.0_RP / ( real(N,dP)*(real(N,dP)+1) )
            x(N) = 1.0_RP
            w(N) = w(0)
            ! Ansonsten: Symmetrie ausnutzen (nur fuer die erste Haelfte berechnen)
            DO j=1,((N+1)/2 - 1)
                ! Anfangsschaetzung mittels asymptotischer Relation nach Parter:
                ! Setzte negatives Vorzeichen, um die Stuetzstellen aus dem Intervall (-1,0) zu erhalten.
                x(j) = -cos( ((real(j,dP)+0.25_RP)*pi)/real(N,dP) - (3.0_RP/(8_RP*real(N,dP)*pi)) * (1.0_dp/(real(j,dP)+0.25_RP)) )
    !
                ! Diese Schaetzung wird nun mithilfe des Newton-Verfahrens praezisiert
                DO k=0,n_it
                    ! Dazu wird das (N+1)-ste Polynom sowie dessen Ableitung benoetigt
                    ! (ausgewertet an der entspr. Stuetzstelle)
                    CALL qAndLEvaluation(N,x(j),q,dq,L_N)
                    ! Newton-Korrektur berechnen und anwenden
                    Delta = -q/dq
                    x(j) = x(j) + Delta
                    ! Falls vor Abarbeiten aller festgelegten Iterationen des Newton-Verfahrens der berechnete Wert
                    ! schon nahe genug an der Nullstelle liegt, wird abgebrochen.
                    IF ( ABS(Delta).LE.(tol * ABS(x(j))) ) THEN
                        EXIT
                    END IF
    !
                END DO
    !
                CALL qAndLEvaluation(N,x(j),q,dq,L_N)
                ! Nutze Symmetrie aus (Multiplikation mit -1)
                x(N-j) = -x(j)
                ! Gewichte berechnen
                w(j) = 2.0_RP / ( real(N,dP)*(real(N,dP)+1.0_RP) * (L_N*L_N) )
                ! Auch die Gewichte sind symmetrisch
                w(N-j) = w(j)
    !
            END DO
    !
        END IF
    !
        ! Falls eine ungerade Anzahl gefordert wird, noch die "mittleren" Werte angeben
        IF (MOD(N,2).EQ.0) THEN
            CALL qAndLEvaluation(N,0.0_RP,q,dq,L_N)
            ! Berechnung der Stuetzstellen und Gewichte analog
            x(N/2) = 0.0_RP
            w(N/2) = 2.0_RP / ( real(N,dP) * (real(N,dP)+1.0_RP) * (L_N*L_N) )
        END IF
    !
        RETURN
    END SUBROUTINE LegendreGaussLobattoNodesAndWeights

pure     subroutine mkVanderMondeMatrix(n, nodes, Vdm, sVdm)

        use linalg_mod, only: invert

        integer, intent(in)  :: n
        real(dp), intent(in)  :: nodes(:)
        real(dp), intent(out) ::   Vdm(:,:)
        real(dp), intent(out) ::  sVdm(:,:)
        real(dp) :: dummy
        integer :: i,j

        do i = 1,n; do j = 1,n
            call LegendrePolynomialAnDderivative(j-1, nodes(i), Vdm(i,j), dummy)
        end do; end do

        sVdm = invert(Vdm,n)

    end subroutine

END MODULE


! sets.f90 --
!     Implementation of unordered sets
!
!     See the example/test program for the way to use this
!
!     The module is straightforward: it uses the vector
!     data structure to store the data. The operations
!     are the typical mathematical set operations,
!     with operators defined for convenience.
!
!     Note:
!     Define the type SET_DATA for the data to be
!     maintained via this module.
!
!     Note:
!     To allow maximum freedom in chosing the names of
!     the modules the code is split in two parts:
!     - an include file to define the VECTOR data type
!       (see data_for_sets.f90)
!     - this file to define the SET data type itself.
!     The test/example program shows how to use them.
!
!     $Id: sets.f90,v 1.2 2006-03-26 19:03:53 arjenmarkus Exp $

!
! Make everything private, except what we want to
! expose
!
implicit none
private

type SET
    type(VECTOR) :: values
endtype

public :: SET, SET_DATA
public :: set_create, set_destroy, set_add, set_haselement, &
          set_union, set_intersection, set_exclusion, &
          set_hassubset, set_size, set_equal, set_delete_element, &
          operator(.elementof.), &
          operator(.union.), &
          operator(.intersect.), &
          operator(.exclude.), &
          operator(.subsetof.), &
          operator(.eq.), &
          operator(.ne.)

interface operator(.elementof.)
    module procedure set_iselement
end interface

interface operator(.subsetof.)
    module procedure set_issubset
end interface

interface operator(.union.)
    module procedure set_union
end interface

interface operator(.intersect.)
    module procedure set_intersection
end interface

interface operator(.exclude.)
    module procedure set_exclusion
end interface

interface operator(.eq.)
    module procedure set_equal
end interface

interface operator(.ne.)
    module procedure set_notequal
end interface

contains
!
! Code specific for the set data structure
!

! set_create --
!     Create and initialise a set
! Arguments:
!     dataset    New set
!
subroutine set_create( dataset )
    type(SET), intent(inout) :: dataset

    call vector_create( dataset%values )

end subroutine set_create

! set_destroy --
!     Destroy a set
! Arguments:
!     dataset    Existing set
!
subroutine set_destroy( dataset )
    type(SET), intent(inout) :: dataset

    call vector_destroy( dataset%values )

end subroutine set_destroy

! set_size --
!     Function to return the size of the set
! Arguments:
!     dataset    Existing set
!
integer function set_size( dataset )
    type(SET), intent(in) :: dataset

    set_size = vector_size( dataset%values )

end function set_size

! set_haselement --
!     Function to check if an element is contained
!     in the set
! Arguments:
!     dataset    Existing set
!     elem       Element to be checked
!
logical function set_haselement( dataset, elem )
    type(SET), intent(in)      :: dataset
    type(SET_DATA), intent(in) :: elem

    type(VECTOR_DATA)          :: vector_elem
    integer                    :: size
    integer                    :: i

    size = vector_size( dataset%values )

    set_haselement = .false.
    do i = 1,size
        vector_elem = vector_at( dataset%values, i )
        if ( elem == vector_elem%data ) then
            set_haselement = .true.
            exit
        endif
    enddo
end function set_haselement

! set_iselement --
!     Function to check if an element is contained
!     in the set (reversed arguments)
! Arguments:
!     elem       Element to be checked
!     dataset    Existing set
!
logical function set_iselement( elem, dataset )
    type(SET_DATA), intent(in) :: elem
    type(SET), intent(in)      :: dataset

    set_iselement = set_haselement( dataset, elem )
end function set_iselement

! set_hassubset --
!     Function to check if one set is contained
!     in another set
! Arguments:
!     set1       Set that may contain the second
!     set2       Set that is possibly a subset
!
logical function set_hassubset( set1, set2 )
    type(SET), intent(in) :: set1
    type(SET), intent(in) :: set2

    type(VECTOR_DATA)     :: vector_elem
    integer               :: size
    integer               :: i

    size = vector_size( set2%values )

    set_hassubset = .true.
    do i = 1,size
        vector_elem = vector_at( set2%values, i )
        if ( .not. set_haselement( set1, vector_elem%data ) ) then
            set_hassubset = .false.
            exit
        endif
    enddo
end function set_hassubset

! set_issubset --
!     Function to check if one set is contained
!     in another set (reversed arguments)
! Arguments:
!     set1       Set that is possibly a subset
!     set2       Set that may contain the first
!
logical function set_issubset( set1, set2 )
    type(SET), intent(in) :: set1
    type(SET), intent(in) :: set2

    set_issubset = set_hassubset( set2, set1 )
end function set_issubset

! set_equal --
!     Function to check if two sets are equal
! Arguments:
!     set1       First set
!     set2       Second set
!
logical function set_equal( set1, set2 )
    type(SET), intent(in)      :: set1
    type(SET), intent(in)      :: set2

    set_equal = set_hassubset( set2, set1 )
    if ( set_equal ) then
        set_equal = set_hassubset( set1, set2 )
    endif
end function set_equal

! set_notequal --
!     Function to check if two sets are not equal
! Arguments:
!     set1       First set
!     set2       Second set
!
logical function set_notequal( set1, set2 )
    type(SET), intent(in)      :: set1
    type(SET), intent(in)      :: set2

    set_notequal = .not. set_hassubset( set2, set1 )
    if ( .not. set_notequal ) then
       set_notequal = .not. set_hassubset( set1, set2 )
    endif
end function set_notequal

! set_union --
!     Function to return the union of two sets
! Arguments:
!     set1       First set
!     set2       Second set
!
function set_union( set1, set2 ) result(union)
    type(SET), intent(in)         :: set1
    type(SET), intent(in)         :: set2
    type(SET)         :: union

    type(VECTOR_DATA) :: vector_elem
    integer           :: size
    integer           :: i

    call set_create( union )

    size = vector_size( set1%values )
    do i = 1,size
        vector_elem = vector_at( set1%values, i )
        call set_add( union, vector_elem%data )
    enddo

    size = vector_size( set2%values )
    do i = 1,size
        vector_elem = vector_at( set2%values, i )
        call set_add( union, vector_elem%data )
    enddo
end function set_union

! set_intersection --
!     Function to return the intersection of two sets
! Arguments:
!     set1       First set
!     set2       Second set
!
function set_intersection( set1, set2 ) result(intersection)
    type(SET), intent(in) :: set1
    type(SET), intent(in) :: set2
    type(SET)             :: intersection

    type(VECTOR_DATA)     :: vector_elem
    integer               :: size
    integer               :: i

    call set_create( intersection )

    size = vector_size( set1%values )
    do i = 1,size
        vector_elem = vector_at( set1%values, i )
        if ( set_haselement( set2, vector_elem%data ) ) then
            call set_add( intersection, vector_elem%data )
        endif
    enddo
end function set_intersection

! set_exclusion --
!     Function to return the exclusion of two sets
! Arguments:
!     set1       First set
!     set2       Second set
!
function set_exclusion( set1, set2 ) result(exclusion)
    type(SET), intent(in) :: set1
    type(SET), intent(in) :: set2
    type(SET)             :: exclusion

    type(VECTOR_DATA)     :: vector_elem
    integer               :: size
    integer               :: i

    call set_create( exclusion )

    size = vector_size( set1%values )
    do i = 1,size
        vector_elem = vector_at( set1%values, i )
        if ( .not. set_haselement( set2, vector_elem%data ) ) then
            call set_add( exclusion, vector_elem%data )
        endif
    enddo
end function set_exclusion

! set_add --
!     Add an element to the set (if it already exists,
!     it is not added)
! Arguments:
!     dataset    Set to which the element must be added
!     elem       Element to be added
!
subroutine set_add( dataset, elem )
    type(SET), intent(in)      :: dataset
    type(SET_DATA), intent(in) :: elem

    type(VECTOR_DATA)          :: vector_elem

    if ( .not. set_haselement( dataset, elem  ) ) then
        vector_elem%data = elem
        call vector_append( dataset%values, vector_elem )
    endif
end subroutine set_add

! set_delete_element --
!     Delete an element from the set (if it does not exist,
!     nothing happens)
! Arguments:
!     dataset    Set from which the element must be deleted
!     elem       Element to be deleted
!
subroutine set_delete_element( dataset, elem )
    type(SET), intent(in)      :: dataset
    type(SET_DATA), intent(in) :: elem

    type(VECTOR_DATA) :: vector_elem
    integer           :: size
    integer           :: i

    size = vector_size( dataset%values )
    do i = 1,size
        vector_elem = vector_at( dataset%values, i )
        if ( elem == vector_elem%data ) then
            call vector_delete_elements( dataset%values, i, 1 )
            exit
        endif
    enddo
end subroutine set_delete_element


!===========================================
subroutine MatVecProd_real(Mat,m,vec)     !real product of a matrix and vector

  use global_com,only:dp

  implicit none
  INTEGER,INTENT(IN):: m
  REAL(kind=dp), INTENT(INOUT):: vec(m)
  REAL(kind=dp), INTENT(IN):: Mat(m,m)

  INTEGER:: i
  REAL(kind=dp):: temp(m),tempM(m)

  DO i = 1,m
        tempM(:) = Mat(i,:)
        temp(i) = DOT_PRODUCT(tempM,vec)
  ENDDO
  vec(:) = temp(:)

END SUBROUTINE MatVecProd_real
!!******************************************************************************************END

SUBROUTINE real_cross_product(va,vb,vc)     !cross product of two real numbers

  use global_com,only:dp

  implicit none
  real(kind=dp):: va(3),vb(3),vc(3)

  vc = 0.0_dp
  vc(1)=va(2)*vb(3)-va(3)*vb(2)
  vc(2)=va(3)*vb(1)-va(1)*vb(3)
  vc(3)=va(1)*vb(2)-va(2)*vb(1)

END subroutine real_cross_product
!******************************************************************************************END

!===========================================
subroutine getinverse(a,c,n)
  !
  ! Inverse matrix
  ! Method: Based on DOolittle LU factorization for Ax=b
  ! Alex G. December 2009
  !-----------------------------------------------------------
  ! input ...
  ! a(n,n) - array of coefficients for matrix A
  ! n      - dimension
  ! output ...
  ! c(n,n) - inverse matrix of A
  ! comments ...
  ! the original matrix a(n,n) will be destroyed
  ! during the calculation
  !
  use global_com,only:dp

  implicit none
  integer n
  real(kind=dp):: a(n,n), c(n,n)
  real(kind=dp):: L(n,n), U(n,n), b(n), d(n), x(n)
  real(kind=dp):: coeff
  integer i, j, k

  ! step 0: initialization for matrices L and U and b
  ! Fortran 90/95 aloows such operations on matrices
  L=0.0_dp
  U=0.0_dp
  b=0.0_dp

  ! step 1: forward elimination
  DO k=1, n-1
     DO i=k+1,n
        coeff=a(i,k)/a(k,k)
        L(i,k) = coeff
        DO j=k+1,n
           a(i,j) = a(i,j)-coeff*a(k,j)
        END DO
     END DO
  END DO

  ! Step 2: prepare L and U matrices
  ! L matrix is a matrix of the elimination coefficient
  ! + the diagonal elements are 1.0
  DO i=1,n
     L(i,i) = 1.0_dp
  END DO
  ! U matrix is the upper triangular part of A
  DO j=1,n
     DO i=1,j
        U(i,j) = a(i,j)
     END DO
  END DO

  ! Step 3: compute columns of the inverse matrix C
  DO k=1,n
     b(k)=1.0_dp
     d(1) = b(1)
     ! Step 3a: Solve Ld=b using the forward substitution
     DO i=2,n
        d(i)=b(i)
        DO j=1,i-1
           d(i) = d(i) - L(i,j)*d(j)
        END DO
     END DO
     ! Step 3b: Solve Ux=d using the back substitution
     x(n)=d(n)/U(n,n)
     DO i = n-1,1,-1
        x(i) = d(i)
        DO j=n,i+1,-1
           x(i)=x(i)-U(i,j)*x(j)
        END DO
        x(i) = x(i)/u(i,i)
     END DO
     ! Step 3c: fill the solutions x(n) into column k of C
     DO i=1,n
        c(i,k) = x(i)
     END DO
     b(k)=0.0_dp
  END DO
END subroutine getinverse
!******************************************************************************************END

 !***********************************************************************************************
SUBROUTINE OriginalGuiggiani_hard(vcsio,nipp,nums,quadPt_u,quadWgt_u,&
                    quadPt_v,quadWgt_v,coeffs,i,rNodes_field,nnpt,cjvk,z00)

    USE global_com,ONLY:dp,pid
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: nnpt,nipp,i,nums(2)
    COMPLEX(kind=dp), INTENT(OUT) :: z00
    REAL(kind=dp), INTENT(IN)::vcsio(2),coeffs(nipp,nipp)
    REAL(kind=dp), INTENT(IN)::rNodes_field(3,nnpt),quadPt_u(nums(1))
    REAL(kind=dp), INTENT(IN)::quadPt_v(nums(2)),quadWgt_u(nums(1))
    REAL(kind=dp), INTENT(IN)::quadWgt_v(nums(2))
    COMPLEX(kind=dp), INTENT(IN) :: cjvk

    INTEGER :: aa,ff,uu,vv,N_uu,N_vv
    REAL(kind=dp)::U1(3),U2(3),nCap(3),beta(3),nCapDotR
    REAL(kind=dp)::etaVecS(2),eta(2),zeta(2),temp_T(2),Lij,rho
    REAL(kind=dp):: R_bar(3),rrr,z,thetaBarPrime,th_bar,th
    REAL(kind=dp)::xxu(nums(1)),xxv(nums(2)),rhoCap_th,vipps(3),vippo(3)
    REAL(kind=dp):: thetaBar(2,3),theta(2,3),h_alpha(3)
    REAL(kind=dp):: wwv(nums(2)),wwu(nums(2)),rhoCap(3)
    COMPLEX(kind=dp) :: z11,F_rho_th

    !OPEN(unit=5001,file='polar_Gauss_points.out')

   !parameters for 1-D gauss quadrature
    xxu(:) = quadPt_u
    xxv(:)= quadPt_v
    wwu(:) = quadWgt_u
    wwv(:)= quadWgt_v
    N_uu = nums(1)
    N_vv = nums(2)

    CALL calcParams(vcsio,thetaBar,h_alpha,beta,rhoCap)     !Relevant quantities needed

  !Computing singular integral using Original Guiggiani formula
    z00 = 0.0_dp

    DO aa = 1,3     !per sub-triangle

        z11 = 0.0_dp

        !Along x direction
        DO uu = 1,N_uu

            th_bar = (thetaBar(1,aa)-thetaBar(2,aa))*xxu(uu) + thetaBar(2,aa)

            th = th_bar + beta(aa)

            rhoCap_th = h_alpha(aa)/cos(th_bar)
            thetaBarPrime = thetaBar(1,aa)-thetaBar(2,aa)

            !Along rho direction
            DO vv = 1,N_vv

               !map (rho,theta) to eta coordinates
                rho = rhoCap_th*xxv(vv)
                zeta(1) = vcsio(1) + rho*cos(th)
                zeta(2) = vcsio(2) + rho*sin(th)

                !Error detection mechanism
                IF ((zeta(1)<0.0_dp).OR.(zeta(2)<0.0_dp).OR.(zeta(1)>1.0_dp).OR.(zeta(2)>1.0_dp)) THEN
                    PRINT*,"zeta = ", zeta
                    PRINT*,"Error detected in zeta variable"
                    STOP
                ENDIF

               !unit normal evaluated at source point in the zeta plane
                CALL calcUnitNormal(zeta(1),zeta(2),nnpt,rNodes_field,nCap)

               !corresponding local distance
                CALL mapGaussPtTo3Ddomain(zeta(1),zeta(2),nnpt,rNodes_field,vipps)
                CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)
                R_bar = vippo-vipps
                rrr = SQRT(DOT_PRODUCT(R_bar,R_bar))
                nCapDotR = DOT_PRODUCT(nCap,R_bar)

                !basis function, Lij
                CALL basis_function(zeta,nipp,coeffs,i,Lij)

               !singular integral kernel evaluated at source point
                F_rho_th = nCapDotR*exp(cjvk*rrr)*(1.0_dp-cjvk*rrr)&
                                        /(4.0_dp*pid*rrr**3)*Lij*rho
               ! I(1) summation
                z11 = z11 + wwu(uu)*wwv(vv)*F_rho_th*rhoCap_th*thetaBarPrime

            ENDDO
        ENDDO

        z00 = z00 + z11        !Total singular integral value
    ENDDO

    RETURN

    CONTAINS

        SUBROUTINE calcParams(vcsio,thetaBar,h_alpha,beta,rhoCap)
            !Subroutine to find the point on the closest edge to the projected field point

            IMPLICIT NONE

            REAL(kind=dp), INTENT(IN) :: vcsio(2)
            REAL(kind=dp), INTENT(OUT)::beta(3),h_alpha(3),thetaBar(2,3),rhoCap(3)

            INTEGER :: aa
            REAL(kind=dp)::Rs1(3),Rs2(3),Rs3(3),R31(3),R23(3),R12(3)
            REAL(kind=dp)::zetaCap(3,2),nCap(3),zetaVec1(2),zetaVec2(2),zetaVec3(2),zetaVecS(2)
            REAL(kind=dp)::mCap(3,3),temp(3)

           !compute eta_2
            zetaVec1 = (/1.0_dp, 0.0_dp/)
            zetaVec2 = (/0.0_dp, 1.0_dp/)
            zetaVec3 = (/0.0_dp, 0.0_dp/)
            zetaVecS = vcsio

           !local unit vectors in the zeta domain
            zetaCap(:,1) = (/1.0_dp,0.0_dp,0.0_dp/)
            zetaCap(:,2) = (/0.0_dp,1.0_dp,0.0_dp/)
            nCap = (/0.0_dp,0.0_dp,1.0_dp/)

            Rs1 = (zetaVec1(1)-zetaVecS(1))*zetaCap(:,1) + (zetaVec1(2)-zetaVecS(2))*zetaCap(:,2)
            Rs2 = (zetaVec2(1)-zetaVecS(1))*zetaCap(:,1) + (zetaVec2(2)-zetaVecS(2))*zetaCap(:,2)
            Rs3 = (zetaVec3(1)-zetaVecS(1))*zetaCap(:,1) + (zetaVec3(2)-zetaVecS(2))*zetaCap(:,2)
            R12 = (zetaVec2(1)-zetaVec1(1))*zetaCap(:,1) + (zetaVec2(2)-zetaVec1(2))*zetaCap(:,2)
            R23 = (zetaVec3(1)-zetaVec2(1))*zetaCap(:,1) + (zetaVec3(2)-zetaVec2(2))*zetaCap(:,2)
            R31 = (zetaVec1(1)-zetaVec3(1))*zetaCap(:,1) + (zetaVec1(2)-zetaVec3(2))*zetaCap(:,2)

            !
            rhoCap=(/SQRT(DOT_PRODUCT(Rs3,Rs3)),SQRT(DOT_PRODUCT(Rs1,Rs1)),&
                        SQRT(DOT_PRODUCT(Rs2,Rs2))/)

            CALL real_cross_product(R23,nCap,temp)
            mCap(:,1) = temp/SQRT(DOT_PRODUCT(temp,temp))

            CALL real_cross_product(R31,nCap,temp)
            mCap(:,2) = temp/SQRT(DOT_PRODUCT(temp,temp))

            CALL real_cross_product(R12,nCap,temp)
            mCap(:,3) = temp/SQRT(DOT_PRODUCT(temp,temp))

            h_alpha(1) = DOT_PRODUCT(Rs3,mCap(:,1))
            h_alpha(2) = DOT_PRODUCT(Rs1,mCap(:,2))
            h_alpha(3) = DOT_PRODUCT(Rs2,mCap(:,3))

            thetaBar(:,1) = (/ACOS(h_alpha(1)/rhoCap(1)),&
                             -ACOS(h_alpha(1)/rhoCap(3))/)
            thetaBar(:,2) = (/ACOS(h_alpha(2)/rhoCap(2)),&
                             -ACOS(h_alpha(2)/rhoCap(1))/)
            thetaBar(:,3) = (/ACOS(h_alpha(3)/rhoCap(3)),&
                             -ACOS(h_alpha(3)/rhoCap(2))/)

            beta(3) = ACOS(DOT_PRODUCT((R31/SQRT(DOT_PRODUCT(R31,R31))),&
                            mCap(:,3)))

            beta(2) = 3.0_dp/2.0_dp*pid
            beta(1) =  beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))

        END SUBROUTINE calcParams

END SUBROUTINE OriginalGuiggiani_hard
!*****************************************************************************************END

 !***********************************************************************************************
SUBROUTINE ImprovedGuiggianiMethod(vcsio,nipp,nums,quadPt_u,quadWgt_u,&
                    quadPt_v,quadWgt_v,coeffs,i,rNodes_field,nnpt,cjvk,z00)

    USE global_com,ONLY:dp,pid
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: nnpt,nipp,i,nums(2)
    COMPLEX(kind=dp), INTENT(OUT) :: z00
    REAL(kind=dp), INTENT(IN)::vcsio(2),coeffs(nipp,nipp)
    REAL(kind=dp), INTENT(IN)::rNodes_field(3,nnpt),quadPt_u(nums(1))
    REAL(kind=dp), INTENT(IN)::quadPt_v(nums(2)),quadWgt_u(nums(1))
    REAL(kind=dp), INTENT(IN)::quadWgt_v(nums(2))
    COMPLEX(kind=dp), INTENT(IN) :: cjvk

    INTEGER :: aa,ff,uu,vv,N_uu,N_vv, wrt1=1, wrt2=2, derivativeDeg=1
    REAL(kind=dp)::U1(3),U2(3),nCap(3),beta(3),etaVec2(2),nCapDotR
    REAL(kind=dp)::etaVecS(2),eta(2),zeta(2),temp_T(2),Lij0,Lij,f_1,rho
    REAL(kind=dp):: R_bar(3),rrr,z,sigma_z,thetaBarPrime,th_bar,th,rr0
    REAL(kind=dp)::xxu(nums(1)),xxv(nums(2)),rhoCap_th,vipps(3),vippo(3)
    REAL(kind=dp):: Z_alpha(2,3),theta(2,3),h_alpha(3),R_cap(3)
    REAL(kind=dp)::Det_T_1,wwu(nums(1)),wwv(nums(2)),tVec_1(2,2),rhoCap(3)
    COMPLEX(kind=dp) :: z11,z22,F_rho_th

   !parameters for 1-D gauss quadrature
    xxu(:) = quadPt_u
    xxv(:)= quadPt_v
    wwu(:) = quadWgt_u
    wwv(:)= quadWgt_v
    N_uu = nums(1)
    N_vv = nums(2)

   ! Column vectors of Jacobian matrix from physical to zeta plane
    CALL calcPosVectDerivative(derivativeDeg,wrt1,vcsio(1),vcsio(2),nnpt,&
                                rNodes_field,U1)   !dr/dZeta1
    CALL calcPosVectDerivative(derivativeDeg,wrt2,vcsio(1),vcsio(2),&
                                nnpt,rNodes_field,U2)   !dr/dZeta2

   !Relevant quantities needed
    CALL computeParams_IGM(U1,U2,Det_T_1,Z_alpha,etaVecS,h_alpha,tVec_1,beta,rhoCap,etaVec2)

  !Computing singular integral using improved Guiggiani formula

    z00 = 0.0_dp
    DO aa = 1,3             !per subtriangle
        z11 = 0.0_dp

        DO uu = 1,N_uu              !Along theta direction
            z = (Z_alpha(1,aa)-Z_alpha(2,aa))*xxu(uu) + Z_alpha(2,aa)     ! z(x)

           !m = 3
            sigma_z = (z**3)/(z**3+(1.0_dp-z)**3)       ! sigma(z) for m = 3
            thetaBarPrime = 3.0_dp*pid*(Z_alpha(1,aa)-Z_alpha(2,aa))*&
                            sigma_z*((1.0_dp-z)**2)/(z*(z**3 + (1.0_dp-z)**3))

           !!m = 2
            !sigma_z = (z**2)/(z**2+(1.0_dp-z)**2)       ! sigma(z) for m = 2
            !thetaBarPrime = 2.0_dp*pid*(Z_alpha(1,aa)-Z_alpha(2,aa))*sigma_z*&
            !                (1.0_dp-z)/(z*(z**2 + (1.0_dp-z)**2))

            th_bar = pid*sigma_z - 0.5_dp*pid
            th = th_bar + beta(aa)

            rhoCap_th = h_alpha(aa)/cos(th_bar)

            DO vv = 1,N_vv          !Along rho direction

               !map (rho,theta) to eta coordinates
                rho = rhoCap_th*xxv(vv)
                eta(1) = etaVecS(1) + rho*cos(th)
                eta(2) = etaVecS(2) + rho*sin(th)
                temp_T = eta

               !map eta to zeta plane
                CALL MatVecProd_real(tVec_1,2,temp_T)
                zeta = temp_T

                !Error detection mechanism
                IF ((zeta(1)<0.0_dp).OR.(zeta(2)<0.0_dp).OR.(zeta(1)>1.0_dp).OR.(zeta(2)>1.0_dp)) THEN
                    PRINT*,"zeta = ", zeta
                    PRINT*,"vcsio = ", vcsio
                    PRINT*,"Error detected in zeta variable"
                    STOP
                ENDIF

               !unit normal evaluated at source point in the zeta plane
                CALL calcUnitNormal(zeta(1),zeta(2),nnpt,rNodes_field,nCap)

               !corresponding local distance
                CALL mapGaussPtTo3Ddomain(zeta(1),zeta(2),nnpt,rNodes_field,vipps)
                CALL mapGaussPtTo3Ddomain(vcsio(1),vcsio(2),nnpt,rNodes_field,vippo)
                R_bar = vippo-vipps
                rrr = SQRT(DOT_PRODUCT(R_bar,R_bar))
                nCapDotR = DOT_PRODUCT(nCap,R_bar)

                !basis function, Lij
                CALL basis_function(zeta,nipp,coeffs,i,Lij)

               !singular integral kernel evaluated at source point
                F_rho_th = nCapDotR*exp(cjvk*rrr)*(1.0_dp-cjvk*rrr)&
                                        /(4.0_dp*pid*rrr**3)*Lij*rho

               ! I(1) summation
                z11 = z11 + wwu(uu)*wwv(vv)*F_rho_th*rhoCap_th*thetaBarPrime*Det_T_1

            ENDDO
        ENDDO

        z00 = z00 + z11        !Total singular integral value
    ENDDO

    RETURN

  CONTAINS

        SUBROUTINE computeParams_IGM(U1,U2,Det_T_1,Z_alpha,etaVecS,&
                                 h_alpha,tVec_1,beta,rhoCap,etaVec2)
            !Subroutine to find the point on the closest edge to the projected field point

            IMPLICIT NONE

            REAL(kind=dp), INTENT(IN) :: U1(3),U2(3)
            REAL(kind=dp), INTENT(OUT)::Z_alpha(2,3)
            REAL(kind=dp), INTENT(OUT)::etaVecS(2),tVec_1(2,2)
            REAL(kind=dp), INTENT(OUT)::beta(3),h_alpha(3),Det_T_1
            REAL(kind=dp), INTENT(OUT)::rhoCap(3),etaVec2(2)

            INTEGER :: aa
            REAL(kind=dp)::Tvec(2,2),temp_T(2)
            REAL(kind=dp)::Rs1(3),Rs2(3),Rs3(3),R31(3),R23(3),R12(3)
            REAL(kind=dp)::etaCap(3,2),nCap(3),sigma(2)
            REAL(kind=dp)::mCap(3,3),thetaBar(2,3),temp(3),lambda,gamma

           !compute eta_2
            lambda = SQRT(DOT_PRODUCT(U1,U1))/SQRT(DOT_PRODUCT(U2,U2))
            gamma = ACOS(DOT_PRODUCT(U1,U2)/(SQRT(DOT_PRODUCT(U1,U1))&
                         *SQRT(DOT_PRODUCT(U2,U2))))
            etaVec2 = (/(COS(gamma)/lambda), (SIN(gamma)/lambda)/)

           !Define transformation jacobian from zeta to eta (i.e., Tvec) and vice versa, (i.e., tvec_1)
            temp_T = (/-etaVec2(1)/etaVec2(2), 1.0_dp/etaVec2(2)/)
            tVec_1 = RESHAPE((/1.0_dp, 0.0_dp,temp_T(1),temp_T(2)/),(/2,2/))
            Tvec = RESHAPE((/1.0_dp,0.0_dp,etaVec2(1),etaVec2(2)/),(/2,2/))

           !image of singular point in the eta plane.
            temp_T = vcsio      !singular point in the zeta plane
            CALL MatVecProd_real(Tvec,2,temp_T)
            etaVecS = temp_T

           !local unit vectors in the eta domain
            etaCap(:,1) = (/1.0_dp,0.0_dp,0.0_dp/)
            etaCap(:,2) = (/0.0_dp,1.0_dp,0.0_dp/)
            nCap = (/0.0_dp,0.0_dp,1.0_dp/)

           !Distance vectors
            Rs1 = (1.0_dp-etaVecS(1))*etaCap(:,1) - etaVecS(2)*etaCap(:,2)
            Rs2 = (etaVec2(1)-etaVecS(1))*etaCap(:,1) +&
                    (etaVec2(2)-etaVecS(2))*etaCap(:,2)
            Rs3 = -etaVecS(1)*etaCap(:,1) - etaVecS(2)*etaCap(:,2)
            R12 = (etaVec2(1)-1.0_dp)*etaCap(:,1) + etaVec2(2)*etaCap(:,2)
            R23 = -etaVec2(1)*etaCap(:,1) - etaVec2(2)*etaCap(:,2)
            R31 = etaCap(:,1)

            rhoCap=(/SQRT(DOT_PRODUCT(Rs3,Rs3)),SQRT(DOT_PRODUCT(Rs1,Rs1)),&
                        SQRT(DOT_PRODUCT(Rs2,Rs2))/)

            CALL real_cross_product(R23,nCap,temp)
            mCap(:,1) = temp/SQRT(DOT_PRODUCT(temp,temp))

            CALL real_cross_product(R31,nCap,temp)
            mCap(:,2) = temp/SQRT(DOT_PRODUCT(temp,temp))

            CALL real_cross_product(R12,nCap,temp)
            mCap(:,3) = temp/SQRT(DOT_PRODUCT(temp,temp))

            h_alpha(1) = DOT_PRODUCT(Rs3,mCap(:,1))
            h_alpha(2) = DOT_PRODUCT(Rs1,mCap(:,2))
            h_alpha(3) = DOT_PRODUCT(Rs2,mCap(:,3))

            CALL calcAngles(mCap,rhoCap,h_alpha,etaVecS,etaVec2,Rs1,Rs2,Rs3,R31,R23,R12,beta,thetaBar)

            DO aa = 1,3
                sigma(:) = (thetaBar(:,aa)+0.5_dp*pid)/pid

               !m = 2
                !DO ff = 1,2
                !    IF (sigma(ff).EQ.0.5_dp) THEN
                !        Z_alpha(ff,aa) = 0.5_dp
                !    ELSE
                !        Z_alpha(ff,aa) = (sigma(ff)-sqrt(sigma(ff)-&
                !               sigma(ff)**2))/(2.0_dp*sigma(ff)-1.0_dp)
                !    ENDIF
                !ENDDO

               !m = 3
                Z_alpha(:,aa) = (sigma**3-sigma**2)**(1.0_dp/3.0_dp) + &
                    (sigma**2-sigma)/((sigma**3-sigma**2)**(1.0_dp/3.0_dp))&
                    + sigma

            ENDDO
            Det_T_1 = tVec_1(1,1)*tVec_1(2,2)-tVec_1(1,2)*tVec_1(2,1)

        END SUBROUTINE computeParams_IGM

      SUBROUTINE calcAngles(mCap,rhoCap,h_alpha,etaVecS,etaVec2,Rs1,Rs2,Rs3,R31,R23,R12,beta,thetaBar)

            !Subroutine to find the point on the closest edge to the projected field point

            IMPLICIT NONE

            REAL(kind=dp), INTENT(IN) :: h_alpha(3),mCap(3,3),rhoCap(3),etaVec2(2),etaVecS(2)
            REAL(kind=dp), INTENT(IN) :: Rs1(3),Rs2(3),Rs3(3),R31(3),R23(3),R12(3)
            REAL(kind=dp), INTENT(OUT):: beta(3),thetaBar(2,3)

            REAL(kind=dp)::theta_tot(3),psi(3),area(3),ss,area_tot
            REAL(kind=dp)::len_Rs1,len_Rs2,len_Rs3,len_R31,len_R23,len_R12

           !Lengths of the distance vectors in eta plane.
            len_Rs1 = SQRT(DOT_PRODUCT(Rs1,Rs1))
            len_Rs2 = SQRT(DOT_PRODUCT(Rs2,Rs2))
            len_Rs3 = SQRT(DOT_PRODUCT(Rs3,Rs3))
            len_R31 = SQRT(DOT_PRODUCT(R31,R31))
            len_R23 = SQRT(DOT_PRODUCT(R23,R23))
            len_R12 = SQRT(DOT_PRODUCT(R12,R12))

           !Angles subtended at the singular image point by each sub-triangle
            theta_tot(1) = ACOS((len_Rs2**2+len_Rs3**2-len_R23**2)/(2.0_dp*len_Rs2*len_Rs3))
            theta_tot(2) = ACOS((len_Rs1**2+len_Rs3**2-len_R31**2)/(2.0_dp*len_Rs1*len_Rs3))
            theta_tot(3) = ACOS((len_Rs1**2+len_Rs2**2-len_R12**2)/(2.0_dp*len_Rs1*len_Rs2))

           !
            psi(1) = ACOS((len_R31**2+len_Rs1**2-len_Rs3**2)/(2.0_dp*len_R31*len_Rs1))
            psi(2) = ACOS((len_Rs2**2+len_R23**2-len_Rs3**2)/(2.0_dp*len_Rs2*len_R23))
            psi(3) = ACOS((len_R12**2+len_Rs2**2-len_Rs1**2)/(2.0_dp*len_R12*len_Rs2))

            thetaBar(:,1) = (/ACOS(h_alpha(1)/rhoCap(1)),&
                             -ACOS(h_alpha(1)/rhoCap(3))/)
            thetaBar(:,2) = (/ACOS(h_alpha(2)/rhoCap(2)),&
                             -ACOS(h_alpha(2)/rhoCap(1))/)
            thetaBar(:,3) = (/ACOS(h_alpha(3)/rhoCap(3)),&
                             -ACOS(h_alpha(3)/rhoCap(2))/)
            beta(2) = 3.0_dp/2.0_dp*pid

            !Calculation of beta and thetaBar based on eta-plane triangle type.
            IF (etaVec2(1)>1) THEN

                beta(3) = -ACOS(DOT_PRODUCT((R31/SQRT(DOT_PRODUCT(R31,R31))),&
                            mCap(:,3)))

                 IF (theta_tot(3).LE.abs(thetaBar(1,3))) THEN
                    thetaBar(2,3) = thetaBar(1,3) -  theta_tot(3)
                    thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))
                    beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                    !PRINT*,"triangle-type 1a  "

                ELSEIF (theta_tot(2).LE.abs(thetaBar(2,2))) THEN
                    thetaBar(1,2) = thetaBar(2,2) + theta_tot(2)
                    beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                    !PRINT*,"triangle-type 1b  "

                ELSE
                    thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                    thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))
                    beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                    !PRINT*,"triangle-type 1c  "
                ENDIF

            ELSEIF (etaVec2(1)<0) THEN
                thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                beta(3) = ACOS(DOT_PRODUCT((R31/SQRT(DOT_PRODUCT(R31,R31))),&
                            mCap(:,3)))

                 IF (theta_tot(1).LE.abs(thetaBar(2,1))) THEN
                    thetaBar(1,1) = theta_tot(1) - abs(thetaBar(2,1))
                    thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))
                    beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                    !PRINT*,"triangle-type 2a  "

                ELSEIF (theta_tot(2).LE.abs(thetaBar(1,2))) THEN
                    thetaBar(2,2) = thetaBar(1,2) - theta_tot(2)
                    thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                    thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                    beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                    !PRINT*,"triangle-type 2b  "

                ELSE
                    thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                    thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))
                    beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                    !PRINT*,"triangle-type 2c  "
                ENDIF

            ELSE
                IF (len_R23.GT.len_R12) THEN
                    beta(3) = ACOS(DOT_PRODUCT((R31/SQRT(DOT_PRODUCT(R31,R31))),&
                                mCap(:,3)))

                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))

                    IF (etaVec2(2)<1) THEN

                        IF (theta_tot(3).LE.abs(thetaBar(2,3))) THEN
                           thetaBar(1,3) = thetaBar(2,3) + theta_tot(3)
                           thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                           beta(1) = beta(3) + ACOS(DOT_PRODUCT(mCap(:,1),mCap(:,3)))
                           !PRINT*,"triangle-type 3a  "

                        ELSEIF (theta_tot(1).LE.abs(thetaBar(1,1))) THEN
                           thetaBar(2,1) = thetaBar(1,1) - theta_tot(1)
                           beta(1) = beta(3) + thetaBar(1,3) - abs(thetaBar(2,1))
                           !PRINT*,"triangle-type 3b  "

                        ELSE
                           thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                           thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                           beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                           !PRINT*,"triangle-type 3c  "

                        ENDIF
                    ELSE
                        thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                        thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                        beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                        !PRINT*,"triangle-type 3d  "
                    ENDIF

                ELSEIF (len_R23.LT.len_R12) THEN

                    beta(3) = ACOS(DOT_PRODUCT((R31/SQRT(DOT_PRODUCT(R31,R31))),&
                                mCap(:,3)))

                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))

                    IF (etaVec2(2)<1) THEN

                        IF (theta_tot(3).LE.abs(thetaBar(2,3))) THEN
                           thetaBar(1,3) = thetaBar(2,3) + theta_tot(3)
                           thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                           beta(1) = beta(3) + ACOS(DOT_PRODUCT(mCap(:,1),mCap(:,3)))
                           !PRINT*,"triangle-type 4a  "

                        ELSEIF (theta_tot(1).LE.abs(thetaBar(1,1))) THEN
                           thetaBar(2,1) = thetaBar(1,1) - theta_tot(1)
                           beta(1) = beta(3) + thetaBar(1,3) - abs(thetaBar(2,1))
                           !PRINT*,"triangle-type 4b  "

                        ELSE
                           thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                           thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                           beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                           !PRINT*,"triangle-type 4c  "
                        ENDIF

                    ELSE
                        thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                        thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                        beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                        !PRINT*,"triangle-type 4d  "

                    ENDIF
                ELSE
                    beta(3) = ACOS(DOT_PRODUCT((R31/SQRT(DOT_PRODUCT(R31,R31))),&
                                mCap(:,3)))

                    thetaBar(2,2) = -(theta_tot(2) - thetaBar(1,2))

                    IF (etaVec2(2)<1) THEN

                        IF (theta_tot(3).LE.abs(thetaBar(2,3))) THEN
                           thetaBar(1,3) = thetaBar(2,3) + theta_tot(3)
                           thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                           beta(1) = beta(3) + ACOS(DOT_PRODUCT(mCap(:,1),mCap(:,3)))
                           !PRINT*,"triangle-type 5a  "
                        ELSEIF (theta_tot(1).LE.abs(thetaBar(1,1))) THEN
                           thetaBar(2,1) = thetaBar(1,1) - theta_tot(1)
                           beta(1) = beta(3) + thetaBar(1,3) - abs(thetaBar(2,1))
                           !PRINT*,"triangle-type 5b  "
                        ELSE
                           thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                           thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                           beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                           !PRINT*,"triangle-type 5c  "
                        ENDIF
                    ELSE
                        thetaBar(2,3) = -(theta_tot(3) - thetaBar(1,3))
                        thetaBar(2,1) = -(theta_tot(1) - thetaBar(1,1))
                        beta(1) = beta(3) + thetaBar(1,3) + abs(thetaBar(2,1))
                        !PRINT*,"triangle-type 5d  "
                    ENDIF

                ENDIF
            ENDIF

           !Areas of each sub-triangles and area of eta-plane triangle
            area(1) = 0.5_dp*len_Rs2*len_Rs3*sin(theta_tot(1))
            area(2) = 0.5_dp*len_Rs1*len_Rs3*sin(theta_tot(2))
            area(3) = 0.5_dp*len_Rs1*len_Rs2*sin(theta_tot(3))
            area_tot = 0.5_dp*etaVec2(2)*len_R31

            !Error-detection mechanism
            IF (abs(area_tot-sum(area)).GT.1.0E-10_dp) THEN
                PRINT*,"An overlap of subtiangles detected."
                PRINT*,"Total Area = ",area_tot
                PRINT*,"sub_area1+sub_area2+sub_area3  = ",sum(area)
                PRINT*,"Error detected in 'calcAngles'!!."
                STOP
            ENDIF

    END SUBROUTINE calcAngles

END SUBROUTINE ImprovedGuiggianiMethod
!*****************************************************************************************END

!***********************************************************************************************
SUBROUTINE calcJacobian(zeta,eta,numNodes,rNodes,J)
    !Subroutine for calculating the Jacobian and unit normal vector, respectively, at area coordinates:(zeta,eta)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes
    REAL(kind=dp), INTENT(OUT) ::   J
    REAL(kind=dp),INTENT(IN) :: zeta, eta, rNodes(3,numNodes)
    REAL(kind=dp) :: dr_bar1(3), dr_bar2(3), temp_J(3)
    INTEGER :: i, wrt1=1, wrt2=2, derivativeDeg=1

    CALL calcPosVectDerivative(derivativeDeg,wrt1,zeta,eta,numNodes,rNodes,dr_bar1)
    CALL calcPosVectDerivative(derivativeDeg,wrt2,zeta,eta,numNodes,rNodes,dr_bar2)

    CALL real_cross_product(dr_bar1,dr_bar2,temp_J)  !cross-product of edge vectors
    J = SQRT(DOT_PRODUCT(temp_J,temp_J))             ! Jacobian

END SUBROUTINE calcJacobian
!******************************************************************************************END

 !***********************************************************************************************
SUBROUTINE calcUnitVec(zeta,eta,numNodes,rNodes,dr_bar1,dr_bar2)
    !Subroutine for calculating the Jacobian and unit normal vector, respectively, at area coordinates:(zeta,eta)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes
    REAL(kind=dp), INTENT(OUT) ::   dr_bar1(3), dr_bar2(3)
    REAL(kind=dp),INTENT(IN) :: zeta, eta, rNodes(3,numNodes)
    REAL(kind=dp) ::  temp_J(3)
    INTEGER :: i, wrt1=1, wrt2=2, derivativeDeg=1

    CALL calcPosVectDerivative(derivativeDeg,wrt1,zeta,eta,numNodes,rNodes,dr_bar1)
    CALL calcPosVectDerivative(derivativeDeg,wrt2,zeta,eta,numNodes,rNodes,dr_bar2)

END SUBROUTINE calcUnitVec
!******************************************************************************************END

 !***********************************************************************************************
SUBROUTINE calcUnitNormal(zeta,eta,numNodes,rNodes,N)
    !Subroutine for calculating the Jacobian and unit normal vector, respectively, at area coordinates:(zeta,eta)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes
    REAL(kind=dp), INTENT(OUT) ::   N(3)
    REAL(kind=dp),INTENT(IN) :: zeta, eta, rNodes(3,numNodes)
    REAL(kind=dp) :: dr_bar1(3), dr_bar2(3), temp_J(3),J
    INTEGER :: i, wrt1=1, wrt2=2, derivativeDeg=1

    CALL calcPosVectDerivative(derivativeDeg,wrt1,zeta,eta,numNodes,rNodes,dr_bar1)
    CALL calcPosVectDerivative(derivativeDeg,wrt2,zeta,eta,numNodes,rNodes,dr_bar2)

    CALL real_cross_product(dr_bar1,dr_bar2,temp_J)  !cross-product of edge vectors
    J = SQRT(DOT_PRODUCT(temp_J,temp_J))             ! Jacobian

    N = temp_J/J

END SUBROUTINE calcUnitNormal
!******************************************************************************************END

!***********************************************************************************************
SUBROUTINE calcPosVectDerivative(derivativeDeg,wrt,zeta,eta,numNodes,rNodes,dr_bar)
    !Subroutine for interpolating derivatives of r in terms of given nodes rNodes
    ! triangular patch given the area coordinates:(zeta,eta)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes, wrt, derivativeDeg
    REAL(kind=dp), INTENT(OUT) :: dr_bar(3)
    REAL(kind=dp),INTENT(IN) :: zeta, eta, rNodes(3,numNodes)
    REAL(kind=dp) :: dN(numNodes)
    INTEGER :: i

!-------------Determine the degree and type of derivative --------------------------
    IF (wrt == 1) THEN          !derivative w.r.t zeta

        !First derivatives w.r.t zeta of shape functions
         INNER1:IF (derivativeDeg==1) THEN
            INNER2:IF (numNodes==6)  THEN
                        dN(1) = 4.0_dp*zeta-1.0_dp
                        dN(2) = 0.0_dp
                        dN(3) = -3.0_dp+4.0_dp*zeta+4.0_dp*eta
                        dN(4) = 4.0_dp*eta
                        dN(5) = -4.0_dp*eta
                        dN(6) = 4.0_dp*(1.0_dp-2.0_dp*zeta-eta)
                    ELSEIF (numNodes==3)  THEN
                        dN(1) = 1.0_dp
                        dN(2) = 0.0_dp
                        dN(3) = -1.0_dp
                    ELSE
                        PRINT*,"1st derivatives for order > 3 or < 1, not supported for now."
                        STOP
                    ENDIF INNER2

               !Second derivatives w.r.t zeta of shape functions
         ELSEIF (derivativeDeg==2) THEN
                INNER3:IF (numNodes==6)  THEN
                            dN(1) = 4.0_dp
                            dN(2) = 0.0_dp
                            dN(3) = 4.0_dp
                            dN(4) = 0.0_dp
                            dN(5) = 0.0_dp
                            dN(6) = -8.0_dp
                        ELSEIF (numNodes==3)  THEN
                            dN(1) = 0.0_dp
                            dN(2) = 0.0_dp
                            dN(3) = 0.0_dp
                        ELSE
                            PRINT*,"2nd derivatives for order > 3 or < 1, not supported for now."
                            STOP
                        ENDIF INNER3
                ELSE
                    PRINT*,"Derivative degrees must be <= 3."
                    STOP
                ENDIF INNER1

    ELSEIF (wrt == 2) THEN      !derivative w.r.t eta

        !First derivatives w.r.t eta of shape functions
         INNERa:IF (derivativeDeg==1) THEN
             INNERb:IF (numNodes==6)  THEN
                        dN(1) = 0.0_dp
                        dN(2) = 4.0_dp*eta-1.0_dp
                        dN(3) = -3.0_dp+4.0_dp*zeta+4.0_dp*eta
                        dN(4) = 4.0_dp*zeta
                        dN(5) = 4.0_dp*(1.0_dp-zeta-2.0_dp*eta)
                        dN(6) = -4.0_dp*zeta
                    ELSEIF (numNodes==3)  THEN
                        dN(1) = 0.0_dp
                        dN(2) = 1.0_dp
                        dN(3) = -1.0_dp
                    ELSE
                        PRINT*,"1st derivatives for order > 3 or < 1, not supported for now."
                        STOP
                    ENDIF INNERb

               !Second derivatives w.r.t eta of shape functions
                ELSEIF (derivativeDeg==2) THEN
                 INNERc:IF (numNodes==6)  THEN
                            dN(1) = 0.0_dp
                            dN(2) = 4.0_dp
                            dN(3) = 4.0_dp
                            dN(4) = 0.0_dp
                            dN(5) = -8.0_dp
                            dN(6) = 0.0_dp
                        ELSEIF (numNodes==3)  THEN
                            dN(1) = 0.0_dp
                            dN(2) = 0.0_dp
                            dN(3) = 0.0_dp
                        ELSE
                            PRINT*,"2nd derivatives for order > 3 or < 1, not supported for now."
                            STOP
                        ENDIF INNERc
                ELSE

                    PRINT*,"Derivative degrees must be <= 3."
                    STOP
                ENDIF INNERa

    ELSE                !2nd derivative w.r.t zeta and eta
           IF (numNodes==6)  THEN
                dN(1) = 0.0_dp
                dN(2) = 0.0_dp
                dN(3) = 4.0_dp
                dN(4) = 4.0_dp
                dN(5) = -4.0_dp
                dN(6) = -4.0_dp
            ELSEIF (numNodes==3)  THEN
                dN(1) = 0.0_dp
                dN(2) = 0.0_dp
                dN(3) = 0.0_dp
            ELSE
                PRINT*,"2nd derivatives for order > 3 or < 1, not supported for now."
                STOP
            ENDIF
    ENDIF

!-----------------Compute position-vector derivative ---------------------------------
    dr_bar(:) = 0.0_dp         !initialize variable

    DO i = 1,numNodes
        dr_bar(:) = dr_bar(:) + dN(i)*rNodes(:,i)
    ENDDO

END SUBROUTINE calcPosVectDerivative
!******************************************************************************************END

!***********************************************************************************************
SUBROUTINE mapGaussPtTo3DDOmain(zetaSrc,etaSrc,numNodes,rNodes,r)
    !Subroutine for interpolating r in terms of given nodes rj
    ! triangular patch given the area coordinates:(zetaSrc,etaSrc)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes
    REAL(kind=dp), INTENT(OUT) :: r(3)
    REAL(kind=dp),INTENT(IN) :: zetaSrc, etaSrc, rNodes(3,numNodes)
    REAL(kind=dp) :: shape_func(numNodes)
    INTEGER :: i

    CALL shape_function(zetaSrc,etaSrc,numNodes,shape_func)

    r(:) = 0.0_dp
    DO i=1,numNodes
        r(:) = r(:) + shape_func(i)*rNodes(:,i)
    ENDDO

END SUBROUTINE mapGaussPtTo3DDOmain
!******************************************************************************************END

!**********************************************************************************************
SUBROUTINE shape_function(zeta,eta,numNodes,shape_func)
    !Subroutine for implementing silvester-Lagrange shape function for a 1,3, & 6-node
    ! triangular patch given an area coordinate:(zetaSrc,eta)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes
    REAL(kind=dp), INTENT(OUT) :: shape_func(numNodes)
    REAL(kind=dp),INTENT(IN) :: zeta, eta
    REAL(kind=dp) :: AreaCoords(3)

    AreaCoords(1) = zeta
    AreaCoords(2) = eta
    AreaCoords(3) = 1.0_dp-zeta-eta

    IF (numNodes==1) THEN
        shape_func(1) = 1.0_dp

    ELSEIF (numNodes==3) THEN
        shape_func(1) = AreaCoords(1)
        shape_func(2) = AreaCoords(2)
        shape_func(3) = AreaCoords(3)

    ELSEIF (numNodes==6) THEN
        shape_func(1) = AreaCoords(1)*(2.0_dp*AreaCoords(1)-1.0_dp)
        shape_func(2) = AreaCoords(2)*(2.0_dp*AreaCoords(2)-1.0_dp)
        shape_func(3) = AreaCoords(3)*(2.0_dp*AreaCoords(3)-1.0_dp)
        shape_func(4) = 4.0_dp*AreaCoords(1)*AreaCoords(2)
        shape_func(5) = 4.0_dp*AreaCoords(2)*AreaCoords(3)
        shape_func(6) = 4.0_dp*AreaCoords(1)*AreaCoords(3)

    ELSEIF (numNodes==10) THEN
        shape_func(1) = 0.5_dp*AreaCoords(1)*(3.0_dp*AreaCoords(1)-1.0_dp)*(3.0*AreaCoords(1)-2.0_dp)
        shape_func(2) = 0.5_dp*AreaCoords(2)*(3.0_dp*AreaCoords(2)-1.0_dp)*(3.0*AreaCoords(2)-2.0_dp)
        shape_func(3) = 0.5_dp*AreaCoords(3)*(3.0_dp*AreaCoords(3)-1.0_dp)*(3.0*AreaCoords(3)-2.0_dp)
        shape_func(4) = 9.0_dp/2.0_dp*AreaCoords(2)*AreaCoords(1)*(3.0_dp*AreaCoords(1)-1.0_dp)
        shape_func(5) = 9.0_dp/2.0_dp*AreaCoords(1)*AreaCoords(2)*(3.0_dp*AreaCoords(2)-1.0_dp)
        shape_func(6) = 9.0_dp/2.0_dp*AreaCoords(3)*AreaCoords(2)*(3.0_dp*AreaCoords(2)-1.0_dp)
        shape_func(7) = 9.0_dp/2.0_dp*AreaCoords(2)*AreaCoords(3)*(3.0_dp*AreaCoords(3)-1.0_dp)
        shape_func(8) = 9.0_dp/2.0_dp*AreaCoords(1)*AreaCoords(3)*(3.0_dp*AreaCoords(3)-1.0_dp)
        shape_func(9) = 9.0_dp/2.0_dp*AreaCoords(3)*AreaCoords(1)*(3.0_dp*AreaCoords(1)-1.0_dp)
        shape_func(10) = 27.0_dp*AreaCoords(1)*AreaCoords(2)*AreaCoords(3)

    ELSE
        PRINT*,"Shape function undefined for order > 3 for now"
        STOP
    ENDIF

    END SUBROUTINE shape_function
!******************************************************************************************END

!***********************************************************************************************
SUBROUTINE basis_function(zeta,numNodes,coeffs,i,basisFunc)
    !Subroutine for interpolating the grid-robust Lagrange basis functions at any desired (interior) point
    ! on a patch with area coordinates: (zeta,eta). (See G. Kang et al, 2001).

    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes,i
    REAL(kind=dp), INTENT(OUT) :: basisFunc
    REAL(kind=dp), INTENT(IN) :: zeta(2),coeffs(numNodes,numNodes)
    INTEGER :: k
    REAL(kind=dp) :: polyvector(numNodes)

    basisFunc=0.0_dp
    IF(numNodes.eq.6) THEN
        polyvector(1)=1.0_dp
        polyvector(2)=zeta(1)
        polyvector(3)=zeta(2)
        polyvector(4)=zeta(1)*zeta(2)
        polyvector(5)=zeta(1)*zeta(1)
        polyvector(6)=zeta(2)*zeta(2)
        DO k=1,6
            basisFunc=basisFunc+coeffs(i,k)*polyvector(k)
        ENDDO
    ELSEIF(numNodes.eq.12) THEN
        polyvector(1)=1.0_dp
        polyvector(2)=zeta(1)
        polyvector(3)=zeta(2)
        polyvector(4)=zeta(1)*zeta(1)
        polyvector(5)=zeta(1)*zeta(2)
        polyvector(6)=zeta(2)*zeta(2)
        polyvector(7)=zeta(1)*zeta(1)*zeta(1)
        polyvector(8)=zeta(1)*zeta(1)*zeta(2)
        polyvector(9)=zeta(1)*zeta(2)*zeta(2)
        polyvector(10)=zeta(2)*zeta(2)*zeta(2)
        polyvector(11)=zeta(1)*zeta(1)*zeta(1)*zeta(2)
        polyvector(12)=zeta(1)*zeta(2)*zeta(2)*zeta(2)
        DO k=1,12
            basisFunc=basisFunc+coeffs(i,k)*polyvector(k)
        ENDDO
     ELSEIF(numNodes.eq.3) THEN
        polyvector(1)=1.0_dp
        polyvector(2)=zeta(1)
        polyvector(3)=zeta(2)
        DO k=1,3
           basisFunc=basisFunc+coeffs(i,k)*polyvector(k)
        ENDDO
      ELSEIF(numNodes.eq.1) THEN
         polyvector(1)=1.0_dp
         DO k=1,1
            basisFunc=basisFunc+coeffs(i,k)*polyvector(k)
         ENDDO
      ELSE
         PRINT*,"can not set polynomial vector for higher order now"
         STOP
      ENDIF

END SUBROUTINE basis_function
!******************************************************************************************END

!***********************************************************************************************
SUBROUTINE findPolyCoeffs(alphas,betas,gammas,numNodes,coeffs)
    USE global_com,ONLY:dp
    IMPLICIT NONE

    INTEGER,INTENT(IN) :: numNodes
    REAL(kind=dp), INTENT(OUT) :: coeffs(numNodes,numNodes)
    REAL(kind=dp), INTENT(IN) :: alphas(numNodes),betas(numNodes),gammas(numNodes)
    REAL(kind=dp) :: vcsis(2),vos1(2),vos2(2),vos3(2)
    REAL(kind=dp) :: polymatrix(numNodes,numNodes),idMat(numNodes,numNodes)
    INTEGER :: IPIV(numNodes),INFO,k,i

    vos1=(/1.0_dp,0.0_dp/)  !right angle triangle vertex points in (u,v) space
    vos2=(/0.0_dp,1.0_dp/)  !the first number is u value, the second number is v value
    vos3=(/0.0_dp,0.0_dp/)

    IF(numNodes.eq.6) THEN
         DO i=1,6
            vcsis= alphas(i)*vos1+betas(i)*vos2+gammas(i)*vos3
            polymatrix(1,i)=1.0_dp
            polymatrix(2,i)=vcsis(1)
            polymatrix(3,i)=vcsis(2)
            polymatrix(4,i)=vcsis(1)*vcsis(2)
            polymatrix(5,i)=vcsis(1)*vcsis(1)
            polymatrix(6,i)=vcsis(2)*vcsis(2)
         ENDDO

         idMat(1:6,1:6)=0.0_dp
         DO k=1,6
            idMat(k,k)=1.0_dp
         ENDDO

         CALL dGESV(6,6,polymatrix,6,IPIV,idMat,6,INFO)

      ELSEIF(numNodes.eq.12) THEN
         DO i=1,12
            vcsis= alphas(i)*vos1+betas(i)*vos2+gammas(i)*vos3
            polymatrix(1,i)=1.0_dp
            polymatrix(2,i)=vcsis(1)
            polymatrix(3,i)=vcsis(2)
            polymatrix(4,i)=vcsis(1)*vcsis(1)
            polymatrix(5,i)=vcsis(1)*vcsis(2)
            polymatrix(6,i)=vcsis(2)*vcsis(2)
            polymatrix(7,i)=vcsis(1)*vcsis(1)*vcsis(1)
            polymatrix(8,i)=vcsis(1)*vcsis(1)*vcsis(2)
            polymatrix(9,i)=vcsis(1)*vcsis(2)*vcsis(2)
            polymatrix(10,i)=vcsis(2)*vcsis(2)*vcsis(2)
            polymatrix(11,i)=vcsis(1)*vcsis(1)*vcsis(1)*vcsis(2)
            polymatrix(12,i)=vcsis(1)*vcsis(2)*vcsis(2)*vcsis(2)
         ENDDO

         idMat(1:12,1:12)=0.0_dp
         DO k=1,12
            idMat(k,k)=1.0_dp
         ENDDO

         CALL dGESV(12,12,polymatrix,12,IPIV,idMat,12,INFO)

      ELSEIF(numNodes.eq.3) THEN
         DO i=1,3
            vcsis= alphas(i)*vos1+betas(i)*vos2+gammas(i)*vos3
            polymatrix(1,i)=1.0_dp
            polymatrix(2,i)=vcsis(1)
            polymatrix(3,i)=vcsis(2)
         ENDDO

         idMat(1:3,1:3)=0.0_dp
         DO k=1,3
            idMat(k,k)=1.0_dp
         ENDDO

         CALL dGESV(3,3,polymatrix,3,IPIV,idMat,3,INFO)

      ELSEIF(numNodes.eq.1) THEN
         DO i=1,1
            vcsis= alphas(i)*vos1+betas(i)*vos2+gammas(i)*vos3
            polymatrix(1,i)=1.0_dp
         ENDDO

         idMat(1:1,1:1)=0.0_dp
         DO k=1,1
            idMat(k,k)=1.0_dp
         ENDDO

         CALL dGESV(1,1,polymatrix,1,IPIV,idMat,1,INFO)

      ELSE
         PRINT*,"can not set polynomial matrix for higher order now"
         STOP
      ENDIF

      coeffs(:,:) = idMat(:,:)

END SUBROUTINE findPolyCoeffs
!******************************************************************************************END


program euler226
   integer, parameter :: dp = selected_real_kind(15,307)
   real(dp) :: x, dx, F

   x = lower_bound()
   dx = (0.5 - x)/50000.0
   F = 0.0
   do while(x < 0.5)
      F = F + dx*something()
   end do !-
   print *,"The area of overlap is %0.8f",F

contains
   !> finds the lower bound for integrating
   real(dp) function lower_bound()
      real(dp) :: p, q, r
      p = 0.0
      q = 0.5
      do while (abs(p-q) > 1e-15)
         r = 0.5*(q + p)
         f = something()
         g = something()
         h = something()
         if (f*h < 0.0) then
            q = r
         else if (g*h < 0.0) then
            p = r
         end if
      end do !-
      lower_bound = 0.5*(q + p)
   end function lower_bound

   !> snipped out relevant function(s)
end program euler226


program main
    use plantFEM
    implicit none

    real(real64),parameter :: dt = 0.010d0
    type(Random_) :: random
    type(IO_) :: f,z
    type(Math_) :: Math
    integer(int32) :: i
    complex(kind(0d0) ),allocatable :: wave(:),spectre(:)

    wave = zeros(4096)
    do i=1, size(wave)
        wave(i) = random%gauss(mu=0.0d0, sigma=1.0d0)
        wave(i) = sin( dt*dble(i) )+sin( 3.0d0*dt*dble(i) )+random%gauss(mu=0.0d0, sigma=1.0d0)
    enddo

    call f%open("gauss.txt")
    call f%write( real(wave) )
    call f%close()

    spectre = zeros(1024    )
    spectre =  FFT(wave)
    call z%open("spectre.txt")
    do i=1,size(spectre)/2
        call z%write( sqrt( spectre(i)*spectre(i) ))
    enddo
    call z%close()

end program main


function julday(dd,mm,yyyy)
!
implicit none
!
! PARAMETER definitions
!
integer,parameter :: igreg = 15 + 31*(10+12*1582)
!
! Dummy arguments
!
integer :: dd,mm,yyyy
integer :: julday
!
! Local variables
!
real*8 :: dble
integer :: int
integer :: ja,jm,jy,y_nw
!
!     + + + purpose + + +
!     in this routine julday returns the julian day number which begins at
!     noon of the calendar date specified by day "dd", month "mm", & year "yyyy"
!     all are integer variables. positive year signifies a.d.; negative, b.c.
!     remember that the year after 1 b.c. was 1 a.d.

!     the following invalid calendar dates are checked for and reported:
!     1. zero year
!     2. dates between 4/10/1582 and 15/10/1582 are specified.
!
!     additional checking for other invalid dates could be added
!     in the future if necessary.
!
!     + + + keywords + + +
!     date, utility
!
!     + + + argument declarations + + +
!
!     + + + argument definitions + + +
!     dd - integer value of day in the range 1-31
!     julday - value returned by the julday function. debe added 09/09/09
!     mm - integer value of month in the range 1-12
!     yyyy - integer value of year (negative a.d., positive b.c.)
!
!     + + + parameters + + +
!     gregorian calendar was adopted on oct. 15, 1582.
!
!     + + + local variable definitions + + +
!     dble -
!     int -
!     ja -
!     jm -
!     jy -
!     y_nw -

!     + + + end specifications + + +
!
if (yyyy==0) write (*,*) 'there is no year zero'
if ((yyyy==1582).and.(mm==10).and.(dd<15).and.(dd>4)) write (*,*)               &
   & 'this is an invalid date'
if (yyyy<0) then
  y_nw = yyyy + 1
else
  y_nw = yyyy
end if
if (mm>2) then
  jy = y_nw
  jm = mm + 1
else
  jy = y_nw - 1
  jm = mm + 13
end if
julday = int(365.25*jy) + int(30.6001*jm) + dd + 1720995
if (dd+31*(mm+12*y_nw)>=igreg) then
  ja = jy/100
!         ja=int(dble(0.01)*dble(jy))
  julday = julday + 2 - ja + int(dble(0.25)*dble(ja))
end if
!
end function julday


program main

  use array_utils, only: diagonal, norm
  use davidson, only: generalized_eigensolver
  use numeric_kinds, only: dp
  use test_utils, only: read_matrix

  implicit none

  integer, parameter :: dim = 864
  integer, parameter :: lowest = 6
  real(dp), dimension(lowest) :: eigenvalues_DPR, eigenvalues_GJD, expected
  real(dp), dimension(dim, lowest) :: eigenvectors_DPR, eigenvectors_GJD
  real(dp), dimension(dim, dim) :: mtx
  integer :: iter_i

  mtx = read_matrix("../src/tests/data/bse_singlet.dat", dim)

  print *, "DPR Method"
  call generalized_eigensolver(mtx, eigenvalues_DPR, eigenvectors_DPR, lowest, "DPR", 50, 1d-4, iter_i, lowest*3)

  expected = [0.30445426, 0.31341032, 0.31360998, 0.33246853, 0.34212415, 0.35761287]

  print "(a, i2)", "steps to convergence: ", iter_i
  print "(a, 6f8.4)", "Eigenvalues:", eigenvalues_DPR
  print "(a, e10.3)", "Relative error with expected eigenvalues: ", norm(eigenvalues_DPR - expected)

  print *, "GJD Method"

  call generalized_eigensolver(mtx, eigenvalues_GJD, eigenvectors_GJD, lowest, "GJD", 10, 1d-4, iter_i, lowest*2)

  print "(a, i2)", "steps to convergence: ", iter_i
  print "(a, 6f8.4)", "Eigenvalues:", eigenvalues_GJD
  print "(a, e10.3)", "Relative error with expected eigenvalues: ", norm(eigenvalues_GJD - expected)

end program main


! { dg-do run }
! Tests the fix for PR28496 in which initializer array constructors with
! a missing initial array index would cause an ICE.
!
! Test for the fix of the initializer array constructor part of PR29975
! was added later.  Here, the indexing would get in a mess if the array
! specification had a lower bound other than unity.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
! Based on original test case from Samir Nordin  <snordin_ng@yahoo.fr>
!
  integer, dimension(3), parameter :: a=(/1,2,3/)
  integer, dimension(3), parameter :: b=(/a(:)/)
  integer, dimension(3,3), parameter :: c=reshape ((/(i, i = 1,9)/),(/3,3/))
  integer, dimension(2,3), parameter :: d=reshape ((/c(3:2:-1,:)/),(/2,3/))
  integer, dimension(3,3), parameter :: e=reshape ((/a(:),a(:)+3,a(:)+6/),(/3,3/))
  integer, dimension(2,3), parameter :: f=reshape ((/c(2:1:-1,:)/),(/2,3/))
  CHARACTER (LEN=1), DIMENSION(3:7),  PARAMETER :: g =  &
    (/ '+', '-', '*', '/', '^' /)
  CHARACTER (LEN=3) :: h = "A+C"
!
! PR28496
!
  if (any (b .ne. (/1,2,3/))) call abort ()
  if (any (reshape(d,(/6/)) .ne. (/3, 2, 6, 5, 9, 8/))) call abort ()
  if (any (reshape(f,(/6/)) .ne. (/2, 1, 5, 4, 8, 7/))) call abort ()
!
! PR29975
!
  IF (all(h(2:2) /= g(3:4))) call abort ()
end


      double precision function DSVAL ( K, NC, T, BCOEF, X, IDERIV )
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DSVAL Krogh  Changes to use M77CON
c>> 1994-09-26 DSVAL CLL Moved "DSVAL = ZERO" to be 1st executable stmt.
c>> 1992-11-12 C. L. Lawson, JPL  Saving LEFTI.
c>> 1992-10-27 C. L. Lawson, JPL
c>> 1988-03-15 C. L. Lawson, JPL
C     Calculates the value at X of the derivative of order IDERIV
c     of the spline function represented in B-spline form by
c     K, NC, T(), and BCOEF().
c
c     Based on subroutine BVALUE on pp. 144-145 of A PRACTICAL GUIDE TO
c     SPLINES by Carl De Boor, Springer-Verlag, 1978.
c     Current version by C. L. Lawson, JPL, March 1988.
c     ------------------------------------------------------------------
c  K     [in]  Order of the spline functions.  Note that the polynomial
c        degree of the segments of the spline is one less than the
c        order.  Example:  Cubic splines have order K = 4.
c  NC     [in]  Number of B-spline coefficients.  Require NC .ge. 1.
C  T()   [in]  Knot sequence, indexed from 1 to NT, with
c        NT = NC + K.  Knot values must be nonincreasing.
c        Repetition of values is permitted and has the effect of
c        decreasing the order of contimuity at the repeated knot.
c        Proper function representation by splines of order K is
c        supported on the interval from T(K) to T(NC+1).
c        Extrapolation can be done outside this interval.
c  BCOEF()  [in]  Coefficients of B-spline basis functions, indexed from
c        1 to NC.
c  X     [in]  Abcissa at which the spline function or one of its
c        derivatives is to be evaluated.  The evaluation will use one
c        of the polynomial pieces of the spline as follows:
c        If X .lt. T(K+1) use the piece associated with [T(K),T(K+1))
c        If T(L) .le. X .lt. T(L+1) for some L in [K+1, NC-1] use the
c        piece associated with [T(L),T(L+1)).
c        If T(NC) .le. X use the piece associated with
c        [T(NC),T(NC+1)].
c  IDERIV   [in]  Order of derivative to be evaluated.  IDERIV = 0
c        selects evaluation of the spline function.  Require
c        IDERIV .ge. 0.  All derivatives of orders .ge. K will be zero.
c  DSVAL [out] Returned value of the spline function or its requested
c        derivative.
c     ------------------------------------------------------------------
c--D replaces "?": ?SVAL, ?SFIND
c     ------------------------------------------------------------------
      integer KMAX
      parameter(KMAX = 20)
      integer IDERIV, IDERP1, IHI, ILO, IMK, IP1
      integer J, JJ, K, KM1, KMIDER, KMJ, LEFTI, MODE, NC
      double precision AJ(KMAX), BCOEF(NC)
      double precision DP(KMAX), DM(KMAX), FKMJ, T(NC+K), X, ZERO
      parameter(ZERO=0.0D0)
      save LEFTI
      data LEFTI / 1 /
c     ------------------------------------------------------------------
      DSVAL = ZERO
      if(K .gt. KMAX) then
         call IERM1('DSVAL',1,2,'Require KORDER .le. KMAX.',
     *   'KORDER',K,',')
         call IERV1('KMAX',KMAX,'.')
         return
      endif
      KMIDER = K - IDERIV
      if (KMIDER .LE. 0)               GO TO 99
C
c     If T(K) .le. X .lt. NC+1, DSFIND will return LEFTI such that
C     T(LEFTI) .le. X .lt. T(LEFTI+1).
c     Otherwise if X .lt. T(K), sets LEFTI := K
c            or if X .ge. T(NC+1), sets LEFTI := NC.
c
      KM1 = K-1
      call DSFIND (T, K, NC+1, X, LEFTI, MODE )
c
c        MODE =  -1 if X < T(K)
c                  0 if T(1) .le. X .le. T(NC+1)
c                 +1 if T(NC+1) .lt. X
c
C               *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES .
      IMK = LEFTI-K
      do 21 J=1,K
         AJ(J) = BCOEF(IMK+J)
   21 continue
      do 25 J=1,IDERIV
         KMJ = K-J
         FKMJ = dble(KMJ)
         do 23 JJ=1,KMJ
            IHI = LEFTI + JJ
            AJ(JJ) = (AJ(JJ+1) - AJ(JJ))/(T(IHI) - T(IHI-KMJ))*FKMJ
   23    continue
   25 continue
C
C  *** COMPUTE VALUE AT *X* IN (T(I),T(I+1)) OF IDERIV-TH DERIVATIVE,
C      GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV).
c
      if (IDERIV .ne. KM1) then
         IP1 = LEFTI+1
         do 32 J=1,KMIDER
            DP(J) = T(LEFTI+J) - X
            DM(J) = X - T(IP1-J)
   32    continue
         IDERP1 = IDERIV+1
         do 35 J=IDERP1,KM1
            KMJ = K-J
            ILO = KMJ
            do 33 JJ=1,KMJ
               AJ(JJ) = (AJ(JJ+1)*DM(ILO) + AJ(JJ)*DP(JJ))/
     *                  (DM(ILO)+DP(JJ))
               ILO = ILO - 1
   33       continue
   35    continue
      endif
      DSVAL = AJ(1)
C
   99 continue
      return
      end


program compute_pi
    use, intrinsic :: iso_fortran_env, only : I8 => INT64
    implicit none
    real, parameter :: PI = acos(-1.0)
    integer(kind=I8), parameter :: nr_tries = 500000000
    integer(kind=I8) :: nr_success, i
    integer :: num_threads = 1, thread_num = 0
    real :: x, y

    nr_success = 0
    do i = 1, nr_tries
        call random_number(x)
        call random_number(y)
        if (x**2 + y**2 <= 1.0) nr_success = nr_success + 1
    end do
    print '(A, F10.7)', 'sampled pi = ', 4.0*real(nr_success)/real(nr_tries)
    print '(A, F10.7)', 'real pi = ', PI
end program compute_pi


      FUNCTION bessi(n,x)
      INTEGER n,IACC
      REAL bessi,x,BIGNO,BIGNI
      PARAMETER (IACC=40,BIGNO=1.0e10,BIGNI=1.0e-10)
CU    USES bessi0
      INTEGER j,m
      REAL bi,bim,bip,tox,bessi0
      if (n.lt.2) pause 'bad argument n in bessi'
      if (x.eq.0.) then
        bessi=0.
      else
        tox=2.0/abs(x)
        bip=0.0
        bi=1.0
        bessi=0.
        m=2*((n+int(sqrt(float(IACC*n)))))
        do 11 j=m,1,-1
          bim=bip+float(j)*tox*bi
          bip=bi
          bi=bim
          if (abs(bi).gt.BIGNO) then
            bessi=bessi*BIGNI
            bi=bi*BIGNI
            bip=bip*BIGNI
          endif
          if (j.eq.n) bessi=bip
11      continue
        bessi=bessi*bessi0(x)/bi
        if (x.lt.0..and.mod(n,2).eq.1) bessi=-bessi
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bessi.for