module fzero
! This module is for finding a root of function(s). This contains
! following items:
!
! FUNCTIONS:
!   brent (fun, x0, tol, LowerBound, UpperBound, detail)
!   Find root of a function using Brent's method. This function tries to
!   find x1 and x2 such that sign of f(x1) and f(x2) are not equal. Then it
!   calls brent0().
!
!   brent0 (fun, x1, x2, tol, detail)
!   Fund root of function fun given TWO intial values.
!
!   fun1(x) ... fun3(x)
!   Test functions for maximization problem
!
! SUBROUTINES:
!   test_functions()
!   It tests functions defined in this module.

contains
	function brent0 (fun, x1, x2, tol, detail)
	! Find zero in a fucntion fun using the Brent's method
	!
	! Description of algorithm:
	! Find a root of function f(x) given intial bracketing interval [a,b]
	! where f(a) and f(b) must have opposite signs. At a typical step we have
	! three points a, b, and c such that f(b)f(c)<0, and a may coincide with
	! c. The points a, b, and c change during the algorithm, and the root
	! always lies in either [b,c] or [c, b]. The value b is the best
	! approximation to the root and a is the previous value of b.
	!
	! The iteration uses following selection of algorithms
	! when bracket shrinks reasonablly fast,
	!  - Linear interporation if a == b
	!  - Quadratic interporation if a != b and the point is in the bracket.
	! othrwise
	! - Bisection.
	!
	! Inputs:
	!   fun: function to be solved
	!   x0, x1: Upper bound and lower bound for a function
	!   tol: error tolerance.
	!   detail (optional): output result of iteration if detail is some value.
	!
	! Date: Jan 30, 09
	! Based on zeroin.f in netlib

	implicit none
	integer, parameter :: d = selected_real_kind(p=13,r=200)
	real(kind=d) :: brent0
	real(kind=d), intent(IN) :: x1, x2, tol
	real(kind=d), external :: fun
	integer, intent(IN), optional :: detail
	integer :: i, exitflag, disp
	real(kind=d) :: a, b, c, diff,e, fa, fb, fc, p, q, r, s, tol1,xm,tmp
	real(kind=d), parameter :: EPS = epsilon(a)
	integer, parameter :: imax = 100  ! maximum number of iteration
	! values from Numerical Recipe

	exitflag = 0
	if (present(detail) .and. detail /= 0) then
		disp = 1
	else
		disp = 0
	end if

	! intialize values
	a = x1
	b = x2
	c = x2
	fa = fun(a)
	fb = fun(b)
	fc=fb

	! check sign
	if ( (fa>0. .and. fb>0. )  .or.  (fa>0. .and. fb>0. )) then
		write(*,*)  'Error (brent.f90): Root must be bracked by two imputs'
		write(*, "('f(x1) = ', 1F8.4, '   f(x2) = ', 1F8.4)") fa,fb
		write(*,*) 'press any key to halt the program'
		read(*,*)
		stop
	end if

	if (disp == 1 ) then
		write(*,*) 'Brents method to find a root of f(x)'
		write(*,*) ' '
		write(*,*) '  i           x          bracketsize            f(x)'
	end if

	! main iteration
	do i = 1, imax
		! rename c and adjust bounding interval if both a(=b) and c are same sign
		if ((fb > 0.  .and. fc > 0) .or. (fb <0. .and. fc < 0. ) ) then
			c = a
			fc = fa
			e = b-a
			diff = e
		end if

		! if c is better guess than b, use it.
		if (abs(fc) < abs(fb) ) then
			a=b
			b=c
			c=a
			fa=fb
			fb=fc
			fc= fa
		end if

		! convergence check
		tol1=2.0_d* EPS * abs(b) + 0.5_d*tol
		xm = 0.5_d * (c - b)
		if (abs(xm) < tol1 .or. fb == 0.0_d )  then
			exitflag = 1
			exit
		end if

		if (disp == 1) then
			tmp = c-b
			write(*,"('  ', 1I2, 3F16.6)") i, b, abs(b-c), fb
		end if

		! try inverse quadratic interpolation
		if (abs(e) >= tol1 .and. abs(fa) > abs(fb) ) then
			s = fb/fa
				if (abs(a - c) < EPS) then
				p = 2.0_d *xm * s
				q = 1.0_d  - s
			else
				q = fa/fc
				r = fb/fc
				p = s * (2.0_d * xm * q * (q -r ) - (b - a) * (r - 1.0_d))
				q = (q - 1.0_d ) * (r - 1.0_d) * (s - 1.0_d)
			end if

			! accept if q is not too small to stay in bound
			if (p > 0.0_d) q = -q
			p = abs(p)
			if (2.0 * p < min(3.0 * xm * q - abs(tol1* q), abs(e *q))) then
				e = d
				diff = p / q
			else   ! interpolation failed. use bisection
				diff= xm
				e = d
			end if
		else  ! quadratic interpolation bounds moves too slowly, use bisection
			diff = xm
			e = d
		end if

		! update last bound
		a = b
		fa = fb

		! move the best guess
		if (abs(d) > tol1) then
			b = b + diff
		else
			b = b + sign(tol1, xm)
		end if

		! evaluate new trial root
		fb = fun(b)
	end do

	! case for non convergence
	if (exitflag /= 1 ) then
		write(*,*) 'Error (brent.f90) :  convergence was not attained'
		write(*,*) 'Initial value:'
		write(*,"(4F10.5)" )   x1, x2, fun(x1), fun(x2)
		write(*,*) ' '
		write(*,*) 'final value:'
		write(*,"('x = '  ,1F6.4, ':                f(x1) = ' ,  1F6.4  )" )  b,  fb
	else if( disp == 1) then
		write(*,*) 'Brents method was converged.'
		write(*,*) ''
	end if
	brent0 = b
	return

	end function brent0

	function brent (fun, x0, tol, LowerBound, UpperBound, detail)
	! Root finding using brent().
	! find an initial guess of bracket and call brent()
	!
	! Inputs
	! fun: function to evaluate
	! x0: Initial guess
	!
	! Optional Inputs:
	! LowerBound, UpperBound : Lower and upper bound of the function
	! detail : Output result of iteration if detail is there.
	!
	! Date: Jan 30, 09

	implicit none
	integer, parameter :: d = selected_real_kind(p=13,r=200)
	real(kind=d) :: brent
	real(kind=d), intent(IN) :: x0, tol
	real(kind=d), external :: fun
	real(kind=d), intent(IN), optional :: LowerBound, UpperBound
	integer, intent(IN), optional :: detail

	real(kind=d) :: a , b , olda, oldb, fa, fb
	real(kind=d), parameter :: sqrt2 = sqrt(2.0_d)! change in dx
	integer, parameter :: maxiter = 40
	real(kind=d) :: dx  ! change in bracket
	integer :: iter, exitflag, disp
	real(kind=d) :: sgn

	a  = x0  ! lower bracket
	b =  x0 ! upper bracket
	olda = a
	oldb = b
	exitflag = 0  ! flag to see we found the bracket
	sgn  =fun(x0) ! sign of initial guess

	! set disp variable
	if (present(detail) .and. detail /= 0) then
		disp = 1
	else
		disp = 0
	end if

	! set initial change dx
	if (abs(x0)<0.00000002_d) then
		dx = 1.0_d/50.0_d
	else
		dx = 1.0_d/50.0_d * x0
	end if

	if (disp == 1) then
		write(*,*) 'Search for initial guess for Brents method'
		write(*,*) 'find two points whose sign for f(x) is different '
		write(*,*) 'x1 searches downwards, x2 searches upwards with increasing increment'
		write(*,*) ' '
		write(*,*) '   i         x1         x2         f(x1)          f(x2)'
	end if

	! main loop to extend a and b
	do iter = 1, maxiter
		fa = fun(a)
		fb = fun(b)

		if (disp == 1) write(*,"(1I4,4F14.7)") iter, a, b, fa, fb

		! check if sign of functions changed or not
		if ( (sgn >= 0 ) .and.  (fa <= 0) ) then  ! sign of a changed
			! use a and olda as bracket
			b = olda
			exitflag = 1
			exit
		else if  ( (sgn <= 0 ) .and.  (fa >= 0  ) ) then ! sign of b changed
			b = olda
			exitflag = 1
			exit
		else if  ( (sgn >= 0 ) .and.  (fb <= 0  ) ) then ! sign of a changed
			a = oldb
			exitflag = 1
			exit
		else if  ( (sgn <= 0 ) .and.  (fb >= 0  ) ) then ! sign of a changed
			a = oldb
			exitflag = 1
			exit
		end if

		! update boundary
		olda = a
		oldb = b
		a = a - dx
		b = b+ dx
		dx = dx * sqrt2

		! boundary check
		if (present(LowerBound)) then
			if (a < LowerBound ) a = LowerBound + tol
		end if
		if (present(UpperBound) ) then
			if (b > UpperBound ) b = UpperBound  -  tol
		end if
	end do

	if (exitflag /=  1 ) then
		write(*,*) ' Error (brent2) : Proper initial value for Brents method could not be found'
		write(*,*) ' Change initial guess and try again. '
		write(*,*) ' You might want to try disp = 1 option too'
		write(*,*) 'i              x1            x2          fx1              fx2'
		write(*,"(1I4,4F12.7)") iter, a, b, fa, fb
		write(*,*) '  press any key to abort the program'
		read(*,*)
		stop
	else if (disp == 1) then
		write(*,*) '  Initial guess was found.'
		write(*,*) ''
	end if

	if (present (detail)) then
		brent = brent0(fun,a,b,tol,detail)
	else
		brent = brent0(fun,a,b,tol)
	end if

	end function brent

	subroutine TestFunctions()
	! test various functions defined in this module
	implicit none
	integer, parameter :: d = selected_real_kind(p=13,r=200)

	real(kind=d) :: out

	! test function 1 with a few more options
! 	write(*,*) 'Function 1: answer =  0.09534 '
! 	out = brent(fun =fun1, x0 = 4.0_d, tol = 0.0000001_d, &
! 		LowerBound= 0.0_d, detail = 1)

	! test function 2
! 	write(*,*) 'Function 2: answer =  -3 '
! 	out = brent(fun2, 3.0_d,0.00001_d, detail = 1)

	write(*,*) 'Function 3: answer =  8.10451, 10, 11.8955'
	out = brent(fun3, 0.0_d, 0.000001_d, detail = 34)

	write(*,*) ' '

	write(*,*) 'press any key to continue'
	read(*,*)

	end subroutine testfunctions

	function fun1  (x)
	! test function for root finding
	! f(x) = exp(x)  -  1 / (10 * x) ** 2
	! answer = 0.095344
	implicit none
	integer, parameter :: d = selected_real_kind(p=13,r=200)
	real(kind=d) :: fun1
	real(kind=d) , intent(IN) :: x

	fun1 =  exp(x)  -  1 / (10 * x) ** 2
	end function fun1

	function fun2  (x)
	! test function for root finding
	! f(x) = (x+3) *  (x - 1) ** 2
	! answer:  -3, 1
	implicit none
	integer, parameter :: d = selected_real_kind(p=13,r=200)
	real(kind=d) :: fun2
	real(kind=d) , intent(IN) :: x

	fun2 =  (x+3) *  (x - 1) ** 2
	end function fun2

	function fun3  (x)
	! test function for root finding
	! f(x) = sin(x-10)  - 0.5 * (x - 10)
	! answer = 10
	implicit none
	integer, parameter :: d = selected_real_kind(p=13,r=200)
	real(kind=d) :: fun3
	real(kind=d) , intent(IN) :: x

	fun3 =  sin(x-10)  - 0.5 * (x - 10)
	end function fun3

end module fsolve


module fun_mod
    use input_mod
    implicit none
    contains
    !>define fn=dn/dt
    function fn(n,c)
        real(8)::fn
        real(8)::n,c
        fn=(rou-beta)/A*n+lamda*c
    end function
    !>define fc=dc/dt
    function fc(n,c)
        real(8)::fc
        real(8)::n,c
        fc=beta/A*n-lamda*c
    end function
    !>modified elur method of fn
    function eu_fn(n,c)
        real(8)::eu_fn
        real(8)::n,c
        real(8)::n0,c0
        n0=n+deltat*fn(n,c)
        c0=c+deltat*fc(n,c)
        eu_fn=n+0.5*deltat*(fn(n,c)+fn(n0,c0))
    end function
    function rk_fn(n,c)
        real(8)::rk_fn
        real(8)::n,c
        real(8)::kn1,kn2,kn3,kn4,kc1,kc2,kc3,kc4
        kn1=deltat*fn(n,c)
        kc1=deltat*fc(n,c)
        kn2=deltat*fn(n+0.5*kn1,c+0.5*kc1)
        kc2=deltat*fc(n+0.5*kn1,c+0.5*kc1)
        kn3=deltat*fn(n+0.5*kn2,c+0.5*kc2)
        kc3=deltat*fc(n+0.5*kn2,c+0.5*kc2)
        kn4=deltat*fn(n+kn3,c+kc3)
        kc4=deltat*fc(n+kn3,c+kc3)
        rk_fn=n+(kn1+2*kn2+2*kn3+kn4)/6
    end function
    function rk_fc(n,c)
        real(8)::rk_fc
        real(8)::n,c
        real(8)::kn1,kn2,kn3,kn4,kc1,kc2,kc3,kc4
        kn1=deltat*fn(n,c)
        kc1=deltat*fc(n,c)
        kn2=deltat*fn(n+0.5*kn1,c+0.5*kc1)
        kc2=deltat*fc(n+0.5*kn1,c+0.5*kc1)
        kn3=deltat*fn(n+0.5*kn2,c+0.5*kc2)
        kc3=deltat*fc(n+0.5*kn2,c+0.5*kc2)
        kn4=deltat*fn(n+kn3,c+kc3)
        kc4=deltat*fc(n+kn3,c+kc3)
        rk_fc=c+(kc1+2*kc2+2*kc3+kc4)/6
    end function
    !>modified elur method of fc
    function eu_fc(n,c)
        real(8)::eu_fc
        real(8)::n,c
        real(8)::n0,c0
        n0=n+deltat*fn(n,c)
        c0=c+deltat*fc(n,c)
        eu_fc=c+0.5*deltat*(fc(n,c)+fc(n0,c0))
    end function
end module


SUBROUTINE rhohat(rho, y, tol)

!*********************************************************************

!     Find RHOHAT (ML estimator) of gamma density by Y

!     Requires subroutine POLG(X, PSI, POL, N, ICODE)

!     INPUT:  Y = LN(XBAR / Geometric mean) = LN(RHO) - PSI(RHO)
!             TOL = desired accuracy

!     OUTPUT: RHO = ML estimate of RHO

! N.B. The scale parameter for the gamma density is then obtained by
!      equating the population (arithmetic) mean to XBAR = sample mean.

! This version, which is compatible with Lahey's ELF90 compiler,
! is by Alan Miller: amiller @ bigpond.net.au
! URL: http://users.bigpond.net.au/amiller
! Latest revision - 27 August 1997

!*********************************************************************
IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
REAL (dp), INTENT(IN)  :: y, tol
REAL (dp), INTENT(OUT) :: rho

! Local variables
REAL (dp)              :: r1, di
REAL (dp), PARAMETER   :: one = 1._dp, four = 4._dp, three = 3._dp
INTEGER                :: i

INTERFACE
  SUBROUTINE polg(x, psi, pol, n, icode)
    IMPLICIT NONE
    INTEGER, PARAMETER               :: dp = SELECTED_REAL_KIND(15, 60)
    REAL (dp), INTENT(IN)            :: x
    INTEGER, INTENT(IN), OPTIONAL    :: n
    REAL (dp), INTENT(OUT)           :: psi
    REAL (dp), INTENT(OUT), OPTIONAL :: pol(:)
    INTEGER, INTENT(OUT), OPTIONAL   :: icode
  END SUBROUTINE polg
END INTERFACE

IF (y <= EPSILON(one)) THEN
  WRITE(*, *) 'Error: argument y to routine RHOHAT must be > 0'
  RETURN
END IF

!     Initial RHO is Thom's estimator
rho = (one + SQRT(one + four * y / three)) / (four * y)

DO i = 1, 100
  r1 = rho
  CALL polg(r1, di)
  rho = r1 * (LOG(r1) - di) / y
  IF (ABS(r1 - rho) < tol) EXIT
END DO

RETURN
END SUBROUTINE rhohat

SUBROUTINE polg(x, psi, pol, n, icode)

!     This program computes PSI(X) & its first N derivatives.

!*********************************************************************

!     Input parameter X must be positive and < 4000
!                     N integer - highest derivative required >= 0
!     Output parameter PSI = 1st derivative of log (gamma (X) )
!                      POL dimension at least N contains the derivatives
!                      ICODE = 0 for normal exit
!                            = 1 if X <= 0
!                            = 2 if N < 0 or N > 20

!*********************************************************************

!     BER(S) = the Bernouilli number of order 2S (apart from signs)

IMPLICIT NONE
INTEGER, PARAMETER               :: dp = SELECTED_REAL_KIND(15, 60)
REAL (dp), INTENT(IN)            :: x
INTEGER, INTENT(IN), OPTIONAL    :: n
REAL (dp), INTENT(OUT)           :: psi
REAL (dp), INTENT(OUT), OPTIONAL :: pol(:)
INTEGER, INTENT(OUT), OPTIONAL   :: icode

! Local variables
REAL (dp)              :: x2, w(8), di, dj, dum, ds, sgn
REAL (dp), PARAMETER   :: ber(8) = (/ 0.16666666666666667D+00,  &
   0.33333333333333333D-01, 0.23809523809523810D-01, 0.33333333333333333D-01, &
   0.75757575757575758D-01, 0.25311355311355311D+00, 0.11666666666666667D+01, &
   0.70921568627450980D+01 /)
!     Values above are 1/6, 1/30, 1/42, 1/30, 5/66, 691/2730, 7/6 & 3617/510.

INTEGER                :: i, ic, in, indx, j, jj, nn

!     Check for valid input parameters X and N.

ic = 0
IF (x < 0.01D0 .OR. x > 4000.D0) ic = 1
IF (PRESENT(n)) THEN
  IF (n < 0 .OR. n > 20) ic = 2
  nn = n
ELSE
  nn = 0
END IF
IF (PRESENT(icode)) icode = ic
IF (ic > 0) RETURN

!     Increment X to a value > 40

indx = 0
x2 = x
DO i = 1, 40
  IF (x2 > 40.D0) EXIT
  indx = indx + 1
  x2 = x2 + 1.D0
END DO

IF (x2 > 500.D0) THEN
  in = 3
ELSE IF (x2 > 200.D0) THEN
  in = 4
ELSE IF (x2 > 100.D0) THEN
  in = 6
ELSE
  in = 8
END IF

!     Calculate polygamma function using table 6.4.11 on page 260 of
!     Bowman, K.O. & Shenton, L.R. (1988), Properties of Estimators for
!     the Gamma Distribution, Marcel Dekker.
!     X2 = 40 + fractional part of X

IF (nn == 0) GO TO 40
dum = 1.D0 / x2
sgn = 1.D0
DO i = 1, nn
  di = i
  pol(i) = dum * (1.D0 + di * 0.5D0 / x2)
  dum = - dum * di / x2
  DO j = 1, in
    dj = j
    IF (i == 1) THEN
      w(j) = sgn * ber(j) / x2 ** (2*j+1)
      sgn = - sgn
    ELSE
      w(j) = w(j) * (1.D0 - di - 2.D0 * dj) / x2
    END IF
    pol(i) = pol(i) + w(j)
  END DO
END DO

40 psi = LOG(x2) - 0.5D0 / x2
sgn = - 1.D0
DO i = 1, in
  di = 2 * i
  dum = ber(i) / x2 ** (2*i) / di
  psi = psi + sgn * dum
  sgn = - sgn
END DO

!     Calculate desirable polygamma function using 6.4.6 from page 260.

IF (indx == 0) RETURN
IF (PRESENT(pol)) THEN
  sgn = 1.D0
  DO i = 1, nn
    ds = 0.D0
    DO j = 1, indx
      dj = indx - j
      dum = 1.D0 / (x + dj)
      dj = dum
      DO jj = 1, i
        di = jj
        dj = dj * di * dum
      END DO
      ds = ds + dj
    END DO
    pol(i) = pol(i) + sgn * ds
    sgn = - sgn
  END DO
END IF

DO i = 1, indx
  dum = i - 1
  psi = psi - 1.D0 / (x + dum)
END DO

RETURN
END SUBROUTINE polg

PROGRAM drive
IMPLICIT NONE

INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15, 60)
REAL (dp)          :: y, rho, tol = 1.D-04

INTERFACE
  SUBROUTINE rhohat(rho, y, tol)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)
    REAL (dp), INTENT(IN)  :: y, tol
    REAL (dp), INTENT(OUT) :: rho
  END SUBROUTINE rhohat
END INTERFACE

DO
  WRITE(*, '(a)', ADVANCE='NO') ' Enter value of y: '
  READ(*, *) y
  CALL rhohat(rho, y, tol)
  WRITE(*, '(a, f10.6)') ' RHO = ', rho
  WRITE(*, *)
END DO

STOP
END PROGRAM drive


      PROGRAM xodeint
C     driver for routine odeint
      INTEGER KMAXX,NMAX,NVAR
      PARAMETER (KMAXX=200,NMAX=50,NVAR=4)
      INTEGER i,kmax,kount,nbad,nok,nrhs
      REAL bessj,bessj0,bessj1
      REAL dxsav,eps,h1,hmin,x1,x2,x,y,ystart(NVAR)
      COMMON /path/ kmax,kount,dxsav,x(KMAXX),y(NMAX,KMAXX)
      COMMON nrhs
      EXTERNAL derivs,rkqs
      nrhs=0
      x1=1.0
      x2=10.0
      ystart(1)=bessj0(x1)
      ystart(2)=bessj1(x1)
      ystart(3)=bessj(2,x1)
      ystart(4)=bessj(3,x1)
      eps=1.0e-4
      h1=.1
      hmin=0.0
      kmax=100
      dxsav=(x2-x1)/20.0
      call odeint(ystart,NVAR,x1,x2,eps,h1,hmin,nok,nbad,derivs,rkqs)
      write(*,'(/1x,a,t30,i3)') 'Successful steps:',nok
      write(*,'(1x,a,t30,i3)') 'Bad steps:',nbad
      write(*,'(1x,a,t30,i3)') 'Function evaluations:',nrhs
      write(*,'(1x,a,t30,i3)') 'Stored intermediate values:',kount
      write(*,'(/1x,t9,a,t20,a,t33,a)') 'X','Integral','BESSJ(3,X)'
      do 11 i=1,kount
        write(*,'(1x,f10.4,2x,2f14.6)') x(i),y(4,i),bessj(3,x(i))
11    continue
      END
      SUBROUTINE derivs(x,y,dydx)
      INTEGER nrhs
      REAL x,y(*),dydx(*)
      COMMON nrhs
      nrhs=nrhs+1
      dydx(1)=-y(2)
      dydx(2)=y(1)-(1.0/x)*y(2)
      dydx(3)=y(2)-(2.0/x)*y(3)
      dydx(4)=y(3)-(3.0/x)*y(4)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xodeint.for


 SUBROUTINE shape9(weigh,posgp,shape,deriv,nnode,ngaus)
 !***********************************************************************
 !
 !     gauss points, weights, shape functions and derivatives for
 !     one-dimensinal elements (beams and 2-d shells)
 !***********************************************************************
 IMPLICIT NONE
 INTEGER (kind=4), INTENT(IN) :: nnode,ngaus
 REAL (kind=8), INTENT(OUT) :: weigh(:),posgp(:),shape(:,:),deriv(:,:)

 !     gauss points weight and possitions

 SELECT CASE (ngaus)
 CASE(1)
   weigh(1) =  2d0
   posgp(1) =  0d0
   SELECT CASE (nnode)
   CASE(2) !   two nodes, one gauss point
     shape(1,1) =  0.5d0
     shape(2,1) =  0.5d0
     deriv(1,1) = -0.5d0
     deriv(2,1) =  0.5d0
   END SELECT
 CASE(2)
   weigh(1:2) =  1d0
   posgp(1) = -1d0/SQRT(3d0)
   posgp(2) =  1d0/SQRT(3d0)
   SELECT CASE (nnode)
   CASE (2) !     two nodes, two gauss points
     shape(1,1) =  0.5d0*(1d0-posgp(1))
     shape(2,1) =  0.5d0*(1d0+posgp(1))
     shape(1,2) =  0.5d0*(1d0-posgp(2))
     shape(2,2) =  0.5d0*(1d0+posgp(2))
     deriv(1,1) = -0.5d0
     deriv(2,1) =  0.5d0
     deriv(1,2) = -0.5d0
     deriv(2,2) =  0.5d0
   CASE (3)  !     three nodes, two gauss points
     shape(1,1) = -0.5d0*(1d0-posgp(1))*posgp(1)
     shape(2,1) =  1d0-posgp(1)**2
     shape(3,1) =  0.5d0*(1d0+posgp(1))*posgp(1)
     shape(1,2) = -0.5d0*(1d0-posgp(2))*posgp(2)
     shape(2,2) =  1d0-posgp(2)**2
     shape(3,2) =  0.5d0*(1d0+posgp(2))*posgp(2)
     deriv(1,1) =  posgp(1)-0.5d0
     deriv(2,1) = -posgp(1)*2d0
     deriv(3,1) =  posgp(1)+0.5d0
     deriv(1,2) =  posgp(2)-0.5d0
     deriv(2,2) = -posgp(2)*2d0
     deriv(3,2) =  posgp(2)+0.5d0
   END SELECT

 CASE(3)     !Three Gauss points
   weigh(1) =  5d0/9d0
   weigh(2) =  8d0/9d0
   weigh(3) =  5d0/9d0
   posgp(1) = -0.774596669241483d0
   posgp(2) =  0d0
   posgp(3) =  0.774596669241483d0
   SELECT CASE (nnode)
   CASE (3)  !     three nodes, three gauss points
     shape(1,1) = -0.5d0*(1d0-posgp(1))*posgp(1)
     shape(2,1) =  1d0-posgp(1)**2
     shape(3,1) =  0.5d0*(1d0+posgp(1))*posgp(1)
     shape(1,2) = -0.5d0*(1d0-posgp(2))*posgp(2)
     shape(2,2) =  1d0-posgp(2)**2
     shape(3,2) =  0.5d0*(1d0+posgp(2))*posgp(2)
     shape(1,3) = -0.5d0*(1d0-posgp(3))*posgp(3)
     shape(2,3) =  1d0-posgp(3)**2
     shape(3,3) =  0.5d0*(1d0+posgp(3))*posgp(3)
     deriv(1,1) =  posgp(1)-0.5d0
     deriv(2,1) = -posgp(1)*2d0
     deriv(3,1) =  posgp(1)+0.5d0
     deriv(1,2) =  posgp(2)-0.5d0
     deriv(2,2) = -posgp(2)*2d0
     deriv(3,2) =  posgp(2)+0.5d0
     deriv(1,3) =  posgp(3)-0.5d0
     deriv(2,3) = -posgp(3)*2d0
     deriv(3,3) =  posgp(3)+0.5d0
   END SELECT
 END SELECT
 RETURN
 END SUBROUTINE shape9


!##############################################################################
! PROGRAM multi_interpol
!
! ## Multidimensional interpolation methods (linear and splines)
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program multi_interpol

    use toolbox

    implicit none
    integer, parameter :: nx = 10, nz = 20, nerr = 1000
    real*8, parameter :: x_l = -1d0, x_r = 2d0
    real*8, parameter :: z_l = 0.5d0, z_r = 8d0
    real*8 :: xi(0:nx), zi(0:nz), yi(0:nx, 0:nz)
    real*8 :: xerr(0:nerr), zerr(0:nerr), yreal(0:nerr, 0:nerr)
    real*8 :: y_bi(0:nerr, 0:nerr), y_tr(0:nerr, 0:nerr), y_sp(0:nerr, 0:nerr)
    real*8 :: varphix, varphiz, coeff(nx+3, nz+3)
    integer :: ix, iz, ixl, ixr, izl, izr

    ! get nodes and data for interpolation
    call grid_Cons_Equi(xi, x_l, x_r)
    call grid_Cons_Equi(zi, z_l, z_r)
    do ix = 0, nx
        do iz = 0, nz
            yi(ix, iz) = xi(ix)**2 + sqrt(zi(iz))
        enddo
    enddo

    ! get nodes and data for calculation of errors
    call grid_Cons_Equi(xerr, x_l, x_r)
    call grid_Cons_Equi(zerr, z_l, z_r)
    do ix = 0, nerr
        do iz = 0, nerr
            yreal(ix, iz) = xerr(ix)**2 + sqrt(zerr(iz))
        enddo
    enddo

    ! piecewise linear interpolation
    do ix = 0, nerr
        do iz = 0, nerr
            call linint_Equi(xerr(ix), x_l, x_r, nx, ixl, ixr, varphix)
            call linint_Equi(zerr(iz), z_l, z_r, nz, izl, izr, varphiz)

            ! bilinear
            y_bi(ix, iz) = varphix*varphiz*yi(ixl, izl) &
                         + (1d0-varphix)*varphiz*yi(ixr, izl) &
                         + varphix*(1d0-varphiz)*yi(ixl, izr) &
                         + (1d0-varphix)*(1d0-varphiz)*yi(ixr, izr)

            ! on triangles
            if(varphix <= varphiz)then
                y_tr(ix, iz) = varphix*yi(ixl, izl) &
                             + (varphiz-varphix)*yi(ixr, izl) &
                             + (1d0-varphiz)*yi(ixr, izr)
            else
                y_tr(ix, iz) = varphiz*yi(ixl, izl) &
                             + (varphix-varphiz)*yi(ixl, izr) &
                             + (1d0-varphix)*yi(ixr, izr)
            endif
        enddo
    enddo

    ! cubic spline interpolation
    call spline_interp(yi, coeff)
    do ix = 0, nerr
        do iz = 0, nerr
            y_sp(ix, iz) = spline_eval((/xerr(ix), zerr(iz)/), &
                                coeff, (/x_l, z_l/), (/x_r, z_r/))
        enddo
    enddo

    ! write the maximum error to the screen
    write(*,'(a,f15.10)')'Maximum Error Bilinear:   ', &
                                maxval(abs(y_bi/yreal-1d0))*100d0
    write(*,'(a,f15.10)')'Maximum Error Triangular: ', &
                                maxval(abs(y_tr/yreal-1d0))*100d0
    write(*,'(a,f15.10)')'Maximum Error Spline:     ', &
                                maxval(abs(y_sp/yreal-1d0))*100d0

end program


module mod_legendre
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: XI_DIR,ETA_DIR,ZETA_DIR, &
                              ZERO, ONE, TWO, THREE, FOUR, FIVE, EIGHTH, HALF
    use mod_ordering,   only: xi_order_2d, eta_order_2d, &
                              xi_order_3d, eta_order_3d, zeta_order_3d
    use ieee_arithmetic,    only: ieee_is_nan

    implicit none

contains

    !> Compute value of hierarchical Legendre polynomial expansion.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function legendre_val(space_dim,currentmode,xpos,ypos,zpos) result(polyval)
        integer(ik),    intent(in)  :: space_dim
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xpos
        real(rk),       intent(in)  :: ypos
        real(rk),       intent(in)  :: zpos

        real(rk)                    :: polyval

        select case (space_dim)
            case (1)    ! 1D
                polyval = legendre_val1D(currentmode,xpos)
            case (2)    ! 2D
                polyval = legendre_val2D(currentmode,xpos,ypos)
            case (3)    ! 3D
                polyval = legendre_val3D(currentmode,xpos,ypos,zpos)
            case default
                print*, "Error - legendre_val: valid space dimensions are (1,2,3)"
                stop
        end select

    end function legendre_val
    !*****************************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !!
    !!
    !!
    !-----------------------------------------------------------------------------------------
    recursive function legendre_val1D(nterm,pos) result(polyval)
    !   Compute the value of the nterm
    !   legendre polynomial at the location pos
    !   between -1 and 1
    !   Edit list:  Nathan A. Wukie - 2/11/2015
        integer(ik),    intent(in) :: nterm
        real(rk),       intent(in) :: pos

        real(rk)                   :: polyval, polyval_nm1, polyval_nm2

        select case (nterm)
            ! Start recursion terms
            case (1)
                polyval = ONE
            case (2)
                polyval = pos
            case (3 :)
                ! Recursive definition for norder >= 2
                polyval_nm1=legendre_val1D(nterm-1,pos)
                polyval_nm2=legendre_val1D(nterm-2,pos)
                polyval = ((TWO*real(nterm-1,rk)-ONE)*pos*polyval_nm1 - &
                          ((real(nterm-1,rk)-ONE))*polyval_nm2)/real(nterm-1,rk)
        end select

    end function legendre_val1D
    !****************************************************************************************

    !>  A set of 2D, Lagrange polynomials is associated with the coordinates
    !!  in 'nodes'. This function computes the value of the Lagrange polynomial
    !!  associated with the 'currentnode' at the coordinate '(xpos,ypos)'.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !!
    !----------------------------------------------------------------------------------------
    function legendre_val2D(currentmode,xi,eta) result(polyval)
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  ::eta

        real(rk)    :: polyval, xi_polyval, eta_polyval
        integer(ik) :: xi_mode, eta_mode

        ! compute current x/y-node indices of 1D tensor product polynomials
        ! Example: for a 2D lagrange polynomial L(x,y)=L(x)*L(y), compute the
        ! x and y indices
        xi_mode  = xi_order_2d( currentmode)
        eta_mode = eta_order_2d(currentmode)

        xi_polyval  = legendre_val1D(xi_mode,  xi)
        eta_polyval = legendre_val1D(eta_mode,eta)

        polyval = xi_polyval*eta_polyval

    end function legendre_val2D
    !*****************************************************************************************

    !>  A set of 3D, Lagrange polynomials is associated with the coordinates
    !!  in 'nodes'. This function computes the value of the Lagrange polynomial
    !!  associated with the 'currentnode' at the coordinate '(xpos,ypos,zpos)'.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function legendre_val3D(currentmode,xi,eta,zeta) result(polyval)
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        real(rk),       intent(in)  :: zeta

        real(rk)    :: polyval, xi_polyval, eta_polyval, zeta_polyval
        integer(ik) :: xi_mode, eta_mode, zeta_mode

        ! compute current x/y-node indices of 1D tensor product polynomials
        ! Example: for a 2D lagrange polynomial L(x,y)=L(x)*L(y), compute the
        ! x and y indices
        xi_mode   = xi_order_3d(  currentmode)
        eta_mode  = eta_order_3d( currentmode)
        zeta_mode = zeta_order_3d(currentmode)

        xi_polyval   = legendre_val1D(xi_mode,  xi)
        eta_polyval  = legendre_val1D(eta_mode, eta)
        zeta_polyval = legendre_val1D(zeta_mode,zeta)

        polyval = xi_polyval*eta_polyval*zeta_polyval

    end function legendre_val3D
    !*****************************************************************************************

    !> Compute directional derivative of legendre polynomial.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function dlegendre_val(space_dim,currentmode,xi,eta,zeta,dir) result(dpolyval)
        integer(ik),    intent(in)  :: space_dim
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        real(rk),       intent(in)  :: zeta
        integer(ik),    intent(in)  :: dir

        real(rk)    :: dpolyval

        select case (space_dim)
            case (1)    ! 1D
                dpolyval = dlegendre_val1D(currentmode,xi)
            case (2)    ! 2D
                dpolyval = dlegendre_val2D(currentmode,xi,eta,dir)
            case (3)    ! 3D
                dpolyval = dlegendre_val3D(currentmode,xi,eta,zeta,dir)
            case default
                print*, "Error - dlegendre_val: Valid space dimensions are (1,2,3)"
                stop
        end select

    end function dlegendre_val
    !*****************************************************************************************

    !>  Compute the first derivative of the nterm Legendre polynomial at the location
    !!  'pos' between -1 and 1.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !-----------------------------------------------------------------------------------------
    recursive function dlegendre_val1D(nterm,pos) result(dpolyval)
        integer(ik), intent(in)    :: nterm
        real(rk),    intent(in)    :: pos

        real(rk)                   :: dpolyval

        select case (nterm)
            ! Trivial evaluations
            case (1)
                dpolyval = ZERO
            case (2)
                dpolyval = ONE
            case (3 :)
                ! Recursive definition
                dpolyval = real(nterm-1,rk)*legendre_val1D(nterm-1,pos) + pos*dlegendre_val1D(nterm-1,pos)

        end select

    end function dlegendre_val1D
    !*****************************************************************************************

    !>  A set of 1D-Lagrange polynomials is associated with the coordinates
    !!  in 'nodes'. This function compute the derivative of the Lagrange polynomial
    !!  associated with the 'currentnode' at the location 'pos'.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !-----------------------------------------------------------------------------------------
    function dlegendre_val2D(currentmode,xi,eta,dir) result(dpolyval)
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        integer(ik),    intent(in)  :: dir

        integer(ik) :: xi_mode, eta_mode
        real(rk)    :: dpolyval
        real(rk)    :: xi_val, eta_val, dxi_val, deta_val

        xi_mode  = xi_order_2d(currentmode)
        eta_mode = eta_order_2d(currentmode)

        select case (dir)
            case (XI_DIR)
                dxi_val = dlegendre_val1D(xi_mode,xi)
                eta_val = legendre_val1D(eta_mode,eta)

                dpolyval = dxi_val*eta_val

            case (ETA_DIR)
                xi_val   = legendre_val1D(xi_mode,xi)
                deta_val = dlegendre_val1D(eta_mode,eta)

                dpolyval = xi_val*deta_val

            case (ZETA_DIR)
                ! By definition of 2D polynomial, no derivative in ZETA dimension
                dpolyval = ZERO

            case default
                print*, "valid derivative directions are - 'XI_DIR', 'ETA_DIR', 'ZETA_DIR'"
                stop
        end select

    end function dlegendre_val2D
    !*****************************************************************************************

    !>  A set of 3D-Lagrange polynomials is associated with the coordinates
    !!  in 'nodes'. This function computes the derivative of the Lagrange polynomial
    !!  associated with the 'currentnode' at the location 'pos' my multiplying the
    !!  1D derivatives, since the 3D modes are constructed from a tensor product of 1D modes
    !!
    !!  @author Nathan A. Wukie
    !!  @date   3/20/2016
    !!
    !----------------------------------------------------------------------------------------
    function dlegendre_val3D(currentmode,xi,eta,zeta,dir) result(dpolyval)
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        real(rk),       intent(in)  :: zeta
        integer(ik),    intent(in)  :: dir

        integer(ik) :: xi_mode, eta_mode, zeta_mode
        real(rk)    :: dpolyval
        real(rk)    :: xi_val, eta_val, zeta_val, dxi_val, deta_val, dzeta_val

        xi_mode   = xi_order_3d(  currentmode)
        eta_mode  = eta_order_3d( currentmode)
        zeta_mode = zeta_order_3d(currentmode)

        select case (dir)
            case (XI_DIR)
                dxi_val   = dlegendre_val1D(xi_mode,xi)
                eta_val   = legendre_val1D(eta_mode,eta)
                zeta_val  = legendre_val1D(zeta_mode,zeta)

                dpolyval  = dxi_val*eta_val*zeta_val
            case (ETA_DIR)
                xi_val    = legendre_val1D(xi_mode,xi)
                deta_val  = dlegendre_val1D(eta_mode,eta)
                zeta_val  = legendre_val1D(zeta_mode,zeta)

                dpolyval  = xi_val*deta_val*zeta_val
            case (ZETA_DIR)
                xi_val    = legendre_val1D(xi_mode,xi)
                eta_val   = legendre_val1D(eta_mode,eta)
                dzeta_val = dlegendre_val1D(zeta_mode,zeta)

                dpolyval  = xi_val*eta_val*dzeta_val
            case default
                print*, "valid derivative directions are - 'XI_DIR', 'ETA_DIR', 'ZETA_DIR'"
                stop
        end select

    end function dlegendre_val3D
    !*****************************************************************************************

    !>  Second/mixed derivatives of modes in legendre tensor product basis.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   8/7/2017
    !!
    !-----------------------------------------------------------------------------------------
    function ddlegendre_val(space_dim,currentmode,xi,eta,zeta,partial1,partial2) result(res)
        integer(ik),    intent(in)  :: space_dim
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        real(rk),       intent(in)  :: zeta
        integer(ik),    intent(in)  :: partial1
        integer(ik),    intent(in)  :: partial2

        real(rk)    :: res

        select case (space_dim)
            case (1)    ! 1D
                res = ddlegendre_val1D(currentmode,xi)
            case (2)    ! 2D
                res = ddlegendre_val2D(currentmode,xi,eta,partial1,partial2)
            case (3)    ! 3D
                res = ddlegendre_val3D(currentmode,xi,eta,zeta,partial1,partial2)
            case default
                print*, "Error - ddlegendre_val: Valid space dimensions are (1,2,3)"
                stop
        end select

    end function ddlegendre_val
    !*****************************************************************************************

    !>  Compute the second derivative of the nterm Legendre polynomial at the location
    !!  'pos' between -1 and 1.
    !!
    !!  The Legendre polynomials satisfy the Legendre equation:
    !!      ddx( (1-x^2)*ddx(Pn) )  +  n*(n+1)*Pn = 0
    !!
    !!  Applying the chain rule:
    !!      ddx(1 - x^2) * ddx(Pn)  -  2*x* ddx(ddx(Pn))  +  n*(n+1)*Pn = 0
    !!
    !!  Rearranging to solve for the second derivative: ddx(ddx(Pn))
    !!      ddx(ddx(Pn)) = [2*x*ddx(Pn)  -  n*(n+1)*Pn]/(1-x^2)
    !!
    !!
    !!  @author Nathan A. Wukie
    !!  @date   8/07/2017
    !!
    !-----------------------------------------------------------------------------------------
    recursive function ddlegendre_val1d(nterm,pos) result(res)
        use mod_constants,  only: ZERO, ONE, TWO, THREE, SEVEN, EIGHT
        integer(ik), intent(in)    :: nterm
        real(rk),    intent(in)    :: pos

        real(rk)    :: res

        ! DANGEROUS AT (pos=1)
        !res = (TWO*pos*dlegendre_val1D(nterm,pos) - real(nterm-1,rk)*(real(nterm-1,rk) + ONE)*legendre_val1D(nterm,pos))/(ONE-pos*pos)

        select case(nterm)
            case(1)
                res = ZERO
            case(2)
                res = ZERO
            case(3)
                res = THREE
            case(4)
                res = 15._rk*pos
            case(5)
                res = (15._rk/TWO)*(SEVEN*pos*pos - ONE)
            case(6)
                res = (105_rk/TWO)*pos*(THREE*pos*pos - ONE)
            case(7)
                res = (105_rk/EIGHT)*(33._rk*pos*pos*pos*pos - 18._rk*pos*pos + ONE)
            case default
                print*, "Error: ddlegendre_val1d is only defined through order 6"
                stop
        end select

    end function ddlegendre_val1d
    !*****************************************************************************************

    !>  A set of 1D-Lagrange polynomials is associated with the coordinates
    !!  in 'nodes'. This function compute the derivative of the 2D Legendre modal tensor
    !!  product associated with the 'currentnode' at the location 'pos'.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   8/7/2017
    !!
    !-----------------------------------------------------------------------------------------
    function ddlegendre_val2d(currentmode,xi,eta,partial1,partial2) result(res)
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        integer(ik),    intent(in)  :: partial1
        integer(ik),    intent(in)  :: partial2

        integer(ik) :: xi_mode, eta_mode
        real(rk)    :: term1, term2, res

        !
        ! Check valid input for derivatives
        !
        if ((partial1 /= XI_DIR) .and. (partial1 /= ETA_DIR) .and. (partial1 /= ZETA_DIR) .or. &
            (partial2 /= XI_DIR) .and. (partial2 /= ETA_DIR) .and. (partial2 /= ZETA_DIR) ) then
            print*, "valid derivative directions are - 'XI_DIR', 'ETA_DIR', 'ZETA_DIR'"
            stop
        end if

        !
        ! Get indices of terms that construct tensor product mode
        !
        xi_mode  = xi_order_2d(currentmode)
        eta_mode = eta_order_2d(currentmode)

        !
        ! Pure second derivative
        !
        if (partial1 == partial2) then

            select case (partial1)
                case (XI_DIR)
                    term1 = ddlegendre_val1D(xi_mode,xi)
                    term2 =   legendre_val1D(eta_mode,eta)

                case (ETA_DIR)
                    term1 =   legendre_val1D(xi_mode,xi)
                    term2 = ddlegendre_val1D(eta_mode,eta)
            end select

        !
        ! Mixed derivative:  dd(phi)/dxideta = [d(phi)/dxi][d(phi)/deta]
        !
        else
            term1 = dlegendre_val1D(xi_mode,xi)
            term2 = dlegendre_val1D(eta_mode,eta)

        end if

        res = term1 * term2

        ! By definition of 2D polynomial, no derivative in ZETA dimension
        if ((partial1 == ZETA_DIR) .or. (partial2 == ZETA_DIR)) res = ZERO

    end function ddlegendre_val2d
    !*****************************************************************************************

    !>  A set of 1D-Legendre polynomials is associated with the coordinates
    !!  in 'nodes'. This function compute the derivative of the 3D Legendre modal tensor
    !!  product associated with the 'currentnode' at the location 'pos'.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   8/7/2016
    !!
    !-----------------------------------------------------------------------------------------
    function ddlegendre_val3d(currentmode,xi,eta,zeta,partial1,partial2) result(res)
        integer(ik),    intent(in)  :: currentmode
        real(rk),       intent(in)  :: xi
        real(rk),       intent(in)  :: eta
        real(rk),       intent(in)  :: zeta
        integer(ik),    intent(in)  :: partial1
        integer(ik),    intent(in)  :: partial2

        integer(ik) :: xi_mode, eta_mode, zeta_mode
        real(rk)    :: term1, term2, term3, res

        xi_mode   = xi_order_3d(currentmode)
        eta_mode  = eta_order_3d(currentmode)
        zeta_mode = zeta_order_3d(currentmode)

        !
        ! Check valid input for derivatives
        !
        if ((partial1 /= XI_DIR) .and. (partial1 /= ETA_DIR) .and. (partial1 /= ZETA_DIR) .or. &
            (partial2 /= XI_DIR) .and. (partial2 /= ETA_DIR) .and. (partial2 /= ZETA_DIR) ) then
            print*, "valid derivative directions are - 'XI_DIR', 'ETA_DIR', 'ZETA_DIR'"
            stop
        end if

        !
        ! Pure second derivative
        !
        if (partial1 == partial2) then

            select case (partial1)
                case (XI_DIR)
                    term1 = ddlegendre_val1D(xi_mode,xi)
                    term2 =   legendre_val1D(eta_mode,eta)
                    term3 =   legendre_val1D(zeta_mode,zeta)

                case (ETA_DIR)
                    term1 =   legendre_val1D(xi_mode,xi)
                    term2 = ddlegendre_val1D(eta_mode,eta)
                    term3 =   legendre_val1D(zeta_mode,zeta)

                case (ZETA_DIR)
                    term1 =   legendre_val1D(xi_mode,xi)
                    term2 =   legendre_val1D(eta_mode,eta)
                    term3 = ddlegendre_val1D(zeta_mode,zeta)

            end select

        !
        ! Mixed derivative:
        !   ex:  dd(phi)/dxideta   = [d(phi)/dxi] * [d(phi)/deta] * [phi(zeta)]
        !   ex:  dd(phi)/detadzeta = [phi(xi)]  *  [d(phi)/deta] * [d(phi)/dzeta]
        !
        else

            select case(partial1)
                case (XI_DIR)
                    term1 = dlegendre_val1D(xi_mode,xi)
                case (ETA_DIR)
                    term1 = dlegendre_val1D(eta_mode,eta)
                case (ZETA_DIR)
                    term1 = dlegendre_val1D(zeta_mode,zeta)
            end select

            select case(partial2)
                case (XI_DIR)
                    term2 = dlegendre_val1D(xi_mode,xi)
                case (ETA_DIR)
                    term2 = dlegendre_val1D(eta_mode,eta)
                case (ZETA_DIR)
                    term2 = dlegendre_val1D(zeta_mode,zeta)
            end select

            ! Determine third term by knowledge of first two terms in derivative
            select case(partial1 + partial2)
                case (XI_DIR + ETA_DIR)
                    term3 = legendre_val1D(zeta_mode,zeta)
                case (XI_DIR + ZETA_DIR)
                    term3 = legendre_val1D(eta_mode,eta)
                case (ETA_DIR + ZETA_DIR)
                    term3 = legendre_val1D(xi_mode,xi)
            end select

        end if

        ! Compute output
        res = term1 * term2 * term3

        if (ieee_is_nan(res)) print*, 'term ', currentmode, ' is nan'

    end function ddlegendre_val3d
    !*****************************************************************************************

end module mod_legendre


module fornberg_weights_module
  implicit none
  integer, parameter, private :: dp_t = kind(1.0d0)
contains
  subroutine weights(c, z, x)
    real(kind=dp_t), intent(in) :: z
    real(kind=dp_t), dimension(0:), intent(in) :: x
    real(kind=dp_t), dimension(0:,0:), intent(out) :: c
    real(kind=dp_t) :: c1, c2, c3, c4, c5
    integer :: i, j, k, mn
    c1 = 1.0_dp_t
    c4 = x(0) - z
    c(:,:) = 0.0_dp_t
    c(0,0) = 1.0_dp_t
    do i = 1, ubound(x,dim=1)
       mn = min(i, ubound(c,dim=2))
       c2 = 1.0_dp_t
       c5 = c4
       c4 = x(i) - z
       do j = 0, i - 1
          c3 = x(i) - x(j)
          c2 = c2*c3
          if ( j == i-1 ) then
             do k = mn, 1, -1
                c(i,k) = c1*(k*c(i-1,k-1) - c5*c(i-1,k))/c2
             end do
             c(i,0) = -c1*c5*c(i-1,0)/c2
          end if
          do k = mn, 1, -1
             c(j,k) = (c4*c(j,k) - k*c(j,k-1))/c3
          end do
          c(j,0) = c4*c(j,0)/c3
       end do
       c1 = c2
    end do
  end subroutine weights
end module fornberg_weights_module

program main
  use fornberg_weights_module
  implicit none
  integer :: i
  integer, parameter :: dp_t = kind(1.0d0)
  real(kind(0.0d0)) :: z, x(0:2), c(0:2,0:2)
  z = 0
  x = (/-0.5_dp_t, 0.0_dp_t, 1.0_dp_t/)
  call weights(c, z, x)
  do i = lbound(c,dim=2), ubound(c,dim=2)
     print *, '*', i, c(:,i)
  end do
end program main


module mo_likelihood

  USE mo_kind,   only: i4, dp
  USE mo_moment, only: stddev

  Implicit NONE

  PRIVATE

  PUBLIC :: data
  PUBLIC :: model
  PUBLIC :: likelihood_dp,        loglikelihood_dp        ! "real" likelihood  (sigma is an error model or given)
  PUBLIC :: likelihood_stddev_dp, loglikelihood_stddev_dp ! "faked" likelihood (sigma is computed by obs vs model)
  PUBLIC :: setmeas

  INTERFACE data
     MODULE PROCEDURE data_dp
  END INTERFACE data

  INTERFACE model
     MODULE PROCEDURE model_dp
  END INTERFACE model

  INTERFACE setmeas
     MODULE PROCEDURE setmeas_dp
  END INTERFACE setmeas

  REAL(DP),DIMENSION(100,2)  :: meas                   ! measurements
  REAL(DP),PARAMETER         :: stddev_global=0.5_dp   ! standard deviation of measurement error

  ! ------------------------------------------------------------------

CONTAINS

  ! -------------------------------
  ! A Likelihood function: "real" likelihood  (sigma is an error model or given)
  ! -------------------------------
  function likelihood_dp(paraset)
    REAL(DP), DIMENSION(:), INTENT(IN)            :: paraset          ! parameter set
    REAL(DP)                                      :: likelihood_dp

    ! local
    REAL(DP), DIMENSION(size(meas,1))   :: errors

    errors  = model(paraset)-data()
    likelihood_dp = exp(-0.5_dp * sum( errors(:) * errors(:) / stddev_global**2 ))

  end function likelihood_dp

  ! -------------------------------
  ! A Log-Likelihood function: "real" likelihood  (sigma is an error model or given)
  ! -------------------------------
  function loglikelihood_dp(paraset)
    REAL(DP), DIMENSION(:), INTENT(IN)            :: paraset          ! parameter set
    REAL(DP)                                      :: loglikelihood_dp

    ! local
    REAL(DP), DIMENSION(size(meas,1))   :: errors

    errors(:) = model(paraset)-data()
    loglikelihood_dp = -0.5_dp * sum( errors(:) * errors(:) / stddev_global**2 )

  end function loglikelihood_dp

  ! -------------------------------
  ! A Likelihood function: "faked" likelihood (sigma is computed by obs vs model)
  ! -------------------------------
  function likelihood_stddev_dp(paraset,stddev_in,stddev_new,likeli_new)
    REAL(DP), DIMENSION(:), INTENT(IN)            :: paraset          ! parameter set
    REAL(DP),               INTENT(IN)            :: stddev_in        ! standard deviation of data
    REAL(DP),               INTENT(OUT), OPTIONAL :: stddev_new       ! standard deviation of errors using paraset
    REAL(DP),               INTENT(OUT), OPTIONAL :: likeli_new       ! likelihood using stddev_new,
    !                                                                 ! i.e. using new parameter set
    REAL(DP)                                      :: likelihood_stddev_dp

    ! local
    REAL(DP), DIMENSION(size(meas,1))   :: errors
    REAL(DP)                            :: stddev_err

    errors  = model(paraset)-data()
    likelihood_stddev_dp = exp(-0.5_dp * sum( errors(:) * errors(:) / stddev_in**2 ))

    ! optional out
    stddev_err = stddev(errors, ddof=1)
    if (present( stddev_new )) then
       stddev_new = stddev_err
    end if
    if (present( likeli_new )) then
       likeli_new = exp(-0.5_dp * sum( errors(:) * errors(:) / stddev_err**2 ))
    end if

  end function likelihood_stddev_dp

  ! -------------------------------
  ! A Log-Likelihood_stddev function: "faked" likelihood (sigma is computed by obs vs model)
  ! -------------------------------
  function loglikelihood_stddev_dp(paraset,stddev_in,stddev_new,likeli_new)
    REAL(DP), DIMENSION(:), INTENT(IN)            :: paraset          ! parameter set
    REAL(DP),               INTENT(IN)            :: stddev_in        ! standard deviation of data
    REAL(DP),               INTENT(OUT), OPTIONAL :: stddev_new       ! standard deviation of errors using paraset
    REAL(DP),               INTENT(OUT), OPTIONAL :: likeli_new       ! likelihood using stddev_new,
    !                                                                 ! i.e. using new parameter set
    REAL(DP)                                      :: loglikelihood_stddev_dp

    ! local
    REAL(DP), DIMENSION(size(meas,1))   :: errors
    REAL(DP)                            :: stddev_err

    errors(:) = model(paraset)-data()
    loglikelihood_stddev_dp = -0.5_dp * sum( errors(:) * errors(:) / stddev_in**2 )

    ! optional out
    stddev_err = stddev(errors, ddof=1)
    if (present( stddev_new )) then
       stddev_new = stddev_err
    end if
    if (present( likeli_new )) then
       likeli_new = -0.5_dp * sum( errors(:) * errors(:) / stddev_err**2 )
    end if

  end function loglikelihood_stddev_dp

  ! -------------------------------
  ! A Model: p1*x^2 + p2*x + p3
  ! -------------------------------
  function model_dp(paraset)

    use mo_kind, only: dp
    !! !$ USE omp_lib,    only: OMP_GET_THREAD_NUM

    REAL(DP), DIMENSION(:), INTENT(IN)     :: paraset
    REAL(DP), DIMENSION(size(meas,1))      :: model_dp

    integer(i4) :: i, n
    ! for OMP
    !! !$  integer(i4)                           :: n_threads, is_thread

    n = size(meas,1)

    !! !$ is_thread = OMP_GET_THREAD_NUM()
    !! !$ write(*,*) 'OMP_thread: ', is_thread

    !$OMP parallel default(shared) &
    !$OMP private(i)
    !$OMP do
    do i=1, n
       !! !$ if (is_thread /= 0) write(*,*) '    OMP_thread-1: ', is_thread
       model_dp(i) = paraset(1) * meas(i,1) * meas(i,1) + paraset(2) * meas(i,1) + paraset(3)
    end do
    !$OMP end do
    !$OMP end parallel

  end function model_dp

  ! -------------------------------
  ! Data generated with
  !     paraset(1) = 1.0
  !     paraset(2) = 2.0
  !     paraset(3) = 3.0
  ! plus additive, Gaussian distributed error with mu=0.0 and sigma=0.5
  ! -------------------------------
  function data_dp()
    use mo_kind
    REAL(DP), DIMENSION(size(meas,1))      :: data_dp

    data_dp = meas(:,2)

  end function data_dp

  subroutine setmeas_dp()

    integer(i4) :: i

    do i=1,100
       meas(i,1) = real(i,dp)
    end do

    meas(:,2) = (/ 5.49537_dp, 10.7835_dp, 17.6394_dp, 26.8661_dp, 36.9247_dp, 50.9517_dp, 66.2058_dp, &
         82.9703_dp, 101.26_dp, 123.076_dp, 145.457_dp, 171.078_dp, 198.349_dp, 227.23_dp, 257.922_dp, &
         290.098_dp, 325.775_dp, 362.724_dp, 402.669_dp, 442.461_dp, 486.122_dp, 531.193_dp, &
         577.931_dp, 627.091_dp, 678.096_dp, 731.364_dp, 786.039_dp, 843.531_dp, 903.126_dp, &
         963.037_dp, 1025.85_dp, 1091.85_dp, 1158.47_dp, 1226.65_dp, 1298.25_dp, 1370.87_dp, &
         1444.96_dp, 1522.6_dp, 1602.6_dp, 1684.38_dp, 1765.15_dp, 1850.74_dp, 1937.85_dp, 2027.41_dp, &
         2118.44_dp, 2210.62_dp, 2306.9_dp, 2403.27_dp, 2501.83_dp, 2602.96_dp, 2705.29_dp, &
         2811.44_dp, 2917.82_dp, 3027.09_dp, 3137.64_dp, 3250.86_dp, 3366.67_dp, 3482.56_dp, &
         3602.37_dp, 3722.55_dp, 3845.8_dp, 3970.15_dp, 4098.15_dp, 4227.27_dp, 4357.77_dp, &
         4491.49_dp, 4626.23_dp, 4762.95_dp, 4901.15_dp, 5042.95_dp, 5184.86_dp, 5330.4_dp, &
         5478.11_dp, 5626.97_dp, 5776.94_dp, 5931.15_dp, 6085.9_dp, 6242.7_dp, 6402.17_dp, 6563.46_dp, &
         6726.37_dp, 6890.34_dp, 7058.4_dp, 7227.17_dp, 7397.09_dp, 7570.77_dp, 7745.95_dp, &
         7923.72_dp, 8102.21_dp, 8282.98_dp, 8465.42_dp, 8651.37_dp, 8838.43_dp, 9027.57_dp, &
         9219.21_dp, 9411.24_dp, 9606.31_dp, 9802.88_dp, 10002.3_dp, 10202.6_dp /)
  end subroutine setmeas_dp

end module mo_likelihood