c ----------------------------------------------------------------------
c
c Gaussian wake model applied to offshore wind farms (WindFarm object)
c by Juan P. Murcia <jumu@dtu.dk>
c
c Bastankhah, M., & Porte'-Agel, F. (2014). A new analytical model for
c wind-turbine wakes. Renewable Energy, 70, 116-123.
c
c ----------------------------------------------------------------------

c ----------------------------------------------------------------------
c get_RW(x,D,CT,ks)
c ----------------------------------------------------------------------
c Computes the wake radius at a location
c
c Inputs
c ----------
c x (float): Distance between turbines in the stream-wise direction
c D (float): Wind turbine diameter
c CT (float): Outputs WindTurbine object's thrust coefficient
c ks (float): Wake (linear) expansion coefficient
c
c Outputs
c ----------
c Rw (float): Wake radius at a location
      subroutine get_RW(n,x,D,CT,RW,ks)

      implicit none
      integer :: n
      real(kind=8) :: x(n),D,CT,RW(n),ks
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py real(kind=8) intent(in),dimension(n) :: x
cf2py real(kind=8) intent(in) :: D,CT
cf2py real(kind=8) optional,intent(in) :: ks = 0.030
cf2py real(kind=8) intent(out), depend(n),dimension(n) :: RW
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i
      real(kind=8) :: Area,a,k

      Area=pi*D*D/4.0d0
      ! axial velocity deficit at rotor disc
      a=(1.0d0-(sqrt(1.0d0-CT)))/2.0d0
      ! Near wake expansion ratio: k = D0/D from momentum balance
      k=sqrt((1.0d0-a)/(1.0d0-2.0d0*a))

      do i = 1, n
        ! Linear wake expansion:
        ! RW is defined as the sigma of the Gaussian wake deficit
        RW(i)=0.2d0*k*D + ks*x(i)
      end do
      end subroutine get_RW

c ----------------------------------------------------------------------
c get_dU(x,r,D,CT,ks)
c ----------------------------------------------------------------------
c Computes the wake velocity deficit at a location
c Bastankhah, M., & Porte'-Agel, F. (2014). A new analytical model for
c wind-turbine wakes. Renewable Energy, 70, 116-123.
c
c Inputs
c ----------
c x (float): Distance between turbines in the stream-wise direction
c r (array): Radial distance between the turbine and the location
c D (float): Wind turbine diameter
c ks (float): Wake (linear) expansion coefficient [-]
c CT (float): Outputs WindTurbine object's thrust coefficient
c
c Outputs
c ----------
c dU (float): Wake velocity deficit at a location normalized
c             by rotor averaged (equivalent) inflow velocity
      subroutine get_dU(n,x,r,D,CT,ks,dU)

      implicit none
      integer :: n
      real(kind=8) :: x(n),r(n),D,CT,ks,dU(n)
cf2py integer intent(hide),depend(x) :: n=len(x)
cf2py real(kind=8) intent(in),dimension(n) :: x
cf2py real(kind=8) intent(in),depend(n),dimension(n) :: r
cf2py real(kind=8) intent(in) :: D,CT,ks
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: dU
      ! internal variables
      integer :: i
      real(kind=8), dimension(n) :: RW, tm0, tm10,tm20

      call get_RW(n,x,D,CT,RW,ks)

      do i = 1, n
        tm0(i) = (RW(i)/D)**(2.0d0)
        if ( (x(i)<=2.d0*D).or.(1.0d0<=(CT/(8.0d0*tm0(i)))) ) then
          ! Null wake radius for locations in front of the rotor disc
          dU(i) = 0.0d0
        else
          tm10(i)=1.0d0 - ( (1.0d0 - (CT/(8.0d0*tm0(i))))**(0.5d0) )
          tm20(i)=exp(-(1.0d0/(2.0d0*tm0(i)))*((r(i)/D)**(2.0d0)))
          dU(i)=-tm10(i)*tm20(i)
        end if
      end do

      end subroutine get_dU

c ----------------------------------------------------------------------
c get_dUeq(x,y,z,DT,D,CT,ks)
c ----------------------------------------------------------------------
c Computes the rotor averaged (equivalent) wake velocity deficit at
c different turbine locations and diameters
c
c Inputs
c ----------
c x (array): Distance between turbines in the stream-wise direction
c y (array): Distance between turbines in the cross-flow direction
c z (array): Distance between turbines in the vertical direction
c DT (array): Wake operating turbines diameter
c D (float): Wake generating turbine diameter
c ks (float): Wake (linear) expansion coefficient [-]
c CT (float): Outputs WindTurbine object's thrust coefficient
c Ng (int): Polynomial order for Gauss-Legendre quadrature integration
c           in both radial and angular positions
c
c Outputs
c ----------
c dUeq (float): Wake velocity deficit at a location normalized by
c               inflow velocity
      subroutine get_dUeq(n,x,y,z,DT,D,CT,ks,Ng,dUeq)

      implicit none
      integer :: n,Ng
      real(kind=8) :: x(n),y(n),z(n),DT(n),D,CT,ks
      real(kind=8) :: dUeq(n)
cf2py integer intent(hide),depend(x) :: n = len(x)
cf2py real(kind=8) intent(in),dimension(n) :: x
cf2py real(kind=8) intent(in),depend(n),dimension(n) :: y,z,DT
cf2py real(kind=8) intent(in) :: D,CT,ks
cf2py integer optional intent(in) :: Ng = 4
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: dUeq
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i,j,k
      real(kind=8) :: tm1,tm2,tm3,tm4
      real(kind=8), dimension(Ng) :: root,weight,r_pr,th_pr
      real(kind=8), dimension(1) :: x_e,r_e,dU
      real(kind=8), dimension(n) :: RT,r_R,th_R

      RT = DT/2.0d0
      ! Gauss-Legendre quadrature points and weights
      select case (ng)
       case ( 4 )
          root(1) = -0.3399810435848563d0
          root(2) = 0.3399810435848563d0
          root(3) = -0.8611363115940526d0
          root(4) = 0.8611363115940526d0

          weight(1) = 0.6521451548625461d0
          weight(2) = 0.6521451548625461d0
          weight(3) = 0.3478548451374538d0
          weight(4) = 0.3478548451374538d0
       case (5)
          root(1) = 0.0000000000000000d0
          root(2) = -0.5384693101056831d0
          root(3) = 0.5384693101056831d0
          root(4) = -0.9061798459386640d0
          root(5) = 0.9061798459386640d0

          weight(1) = 0.5688888888888889d0
          weight(2) = 0.4786286704993665d0
          weight(3) = 0.4786286704993665d0
          weight(4) = 0.2369268850561891d0
          weight(5) = 0.2369268850561891d0
       case (6)
          root(1) = 0.6612093864662645d0
          root(2) = -0.6612093864662645d0
          root(3) = -0.2386191860831969d0
          root(4) = 0.2386191860831969d0
          root(5) = -0.9324695142031521d0
          root(6) = 0.9324695142031521d0

          weight(1) = 0.3607615730481386d0
          weight(2) = 0.3607615730481386d0
          weight(3) = 0.4679139345726910d0
          weight(4) = 0.4679139345726910d0
          weight(5) = 0.1713244923791704d0
          weight(6) = 0.1713244923791704d0
       case (7)
          root(1) = 0.0000000000000000d0
          root(2) = 0.4058451513773972d0
          root(3) = -0.4058451513773972d0
          root(4) = -0.7415311855993945d0
          root(5) = 0.7415311855993945d0
          root(6) = -0.9491079123427585d0
          root(7) = 0.9491079123427585d0

          weight(1) = 0.4179591836734694d0
          weight(2) = 0.3818300505051189d0
          weight(3) = 0.3818300505051189d0
          weight(4) = 0.2797053914892766d0
          weight(5) = 0.2797053914892766d0
          weight(6) = 0.1294849661688697d0
          weight(7) = 0.1294849661688697d0
        case ( 8 )
          root(1) = -0.960289856497536d0
          root(2) = -0.796666477413627d0
          root(3) = -0.525532409916329d0
          root(4) = -0.183434642495650d0
          root(5) = 0.183434642495650d0
          root(6) = 0.525532409916329d0
          root(7) = 0.796666477413627d0
          root(8) = 0.960289856497536d0

          weight(1) = 0.101228536290374d0
          weight(2) = 0.222381034453375d0
          weight(3) = 0.313706645877888d0
          weight(4) = 0.362683783378363d0
          weight(5) = 0.362683783378363d0
          weight(6) = 0.313706645877888d0
          weight(7) = 0.222381034453375d0
          weight(8) = 0.101228536290374d0
      end select

      ! Location of the turbines in wake coordinates
      r_R  = (y**(2.0d0) + z**(2.0d0))**(0.5d0)
      th_R = modulo(atan2(z,y),2.0d0*pi)

      do i = 1, n
        dUeq(i) = 0.0d0
        if (x(i) > 0.0) then
          ! Location of evaluation points in the local rotor coordinates
          r_pr  = RT(i)*(root+1d0)/2.0d0!uniform in [0, RT]
          !th_pr = pi*(root+1d0)        !uniform in [0,2*pi]
          th_pr = pi*(root+1d0)-pi/2.d0 !uniform in [-pi/2,3/2*pi]
          ! Location of evaluation points in wake coordinates
          ! Evaluation of wake and sum of quadrature
          do j = 1, Ng
            do k = 1, Ng
              x_e = x(i)
              tm1 = (r_R(i))**(2.0d0)
              tm2 = (r_pr(k))**(2.0d0)
              tm3 = 2d0*r_R(i)*r_pr(k)*cos(th_R(i) - th_pr(j))
              r_e = sqrt( tm1+tm2+tm3)
              call get_dU(1,x_e,r_e,D,CT,ks,dU)
              tm4 = weight(j)*weight(k)*dU(1)*(root(k)+1d0)/4d0
              dUeq(i)=dUeq(i)+tm4
            end do
          end do
        end if
      end do

      end subroutine get_dUeq

c ----------------------------------------------------------------------
c gau_s(x,y,z,DT,P_c,CT_c,WS,ks)
c ----------------------------------------------------------------------
c SINGLE FLOW CASE
c Bastankhah, M., & Porte'-Agel, F. (2014). A new analytical model for
c wind-turbine wakes. Renewable Energy, 70, 116-123.
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (float): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (float): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c ks (float): Wake (linear) expansion coefficient [-]
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine gau_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,ks,Ng,rho,
     &WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,Ng
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),WS,WD,ks
      real(kind=8) :: rho,WS_CI(n),WS_CO(n),CT_idle(n),P(n),T(n),U(n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in) :: WS,WD,ks
cf2py integer optional intent(in) :: Ng = 4
cf2py real(kind=8) optional,intent(in) :: rho=1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI=4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO=25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle=0.053
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: P,T,U
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i,j,k,nDownstream(n),idT(n)
      real(kind=8) :: x(n),y(n),z(n),D,CT,dUeq(n),angle
      real(kind=8) :: x_l(n,n),y_l(n,n)

      ! Rotates the global coordinates to local flow coordinates
      angle = pi*(270.0d0-WD)/180.0d0
      do i=1,n
        do j=1,n
          x_l(i,j) = cos(angle)*x_g(i,j)+sin(angle)*y_g(i,j)
          y_l(i,j) = -sin(angle)*x_g(i,j)+cos(angle)*y_g(i,j)
        end do
        ! counts the number of turbines in front of turbine
        nDownstream(i) = count(x_l(i,:).lt.0)
      end do
      ! Indexes of ordered turbines from most upstream turbine
      call order_id(n,nDownstream,idT)
      ! Initializes the rotor averaged (equivalent) velocity
      U = WS
      ! Computes the rotor averaged (equivalent) velocity deficit
      do j=1,n
        i=idT(j)
        x = x_l(i,:)
        y = y_l(i,:)
        z = z_g(i,:)
        D = DT(i)
        if ((U(i) >= WS_CI(i)).and.(U(i) <= WS_CO(i))) then
          call interp_l(CT_c(i,:,1),CT_c(i,:,2),nCT,U(i),CT)
        else
          CT = CT_idle(i)
        end if
        call get_dUeq(n,x,y,z,DT,D,CT,ks,Ng,dUeq)
        U = U + U(i)*dUeq
      end do
      ! Calculates the power and thrust
      do k=1,n
        if ((U(k) >= WS_CI(k)).and.(U(k) <= WS_CO(k))) then
          call interp_l(P_c(k,:,1),P_c(k,:,2),nP,U(k),P(k))
          call interp_l(CT_c(k,:,1),CT_c(k,:,2),nCT,U(k),CT)
        else
          P(k)=0.0d0
          CT = CT_idle(k)
        end if
        T(k) = CT*0.5d0*rho*U(k)*U(k)*pi*DT(k)*DT(k)/4.0d0
      end do

      end subroutine gau_s

c ----------------------------------------------------------------------
c gau(x,y,z,DT,P_c,CT_c,WS,WD,ks)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES
c Bastankhah, M., & Porte'-Agel, F. (2014). A new analytical model for
c wind-turbine wakes. Renewable Energy, 70, 116-123.
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c ks (array): Linear wake expansion [-]
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine gau(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,ks,
     &Ng,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,Ng
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,WD,ks
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,WD,ks
cf2py integer optional intent(in) :: Ng = 4
cf2py real(kind=8) optional,intent(in) :: rho=1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI=4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO=25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle=0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i

      do i=1,nF
        call gau_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD(i),ks(i),
     &       Ng,rho,WS_CI,WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine gau

c ----------------------------------------------------------------------
c gau_av(x,y,z,DT,P_c,CT_c,WS,WD,ks,AV)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES with wt available
c Bastankhah, M., & Porte'-Agel, F. (2014). A new analytical model for
c wind-turbine wakes. Renewable Energy, 70, 116-123.
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c ks (array): Linear wake expansion [-]
c AV (array): Wind turbine available per flow [nF,n]
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine gau_av(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,ks,AV,
     &Ng,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,Ng,AV(nf,n)
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,WD,ks
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,WD,ks
cf2py integer intent(in),dimension(nF,n) :: AV
cf2py integer optional intent(in) :: Ng = 4
cf2py real(kind=8) optional,intent(in) :: rho=1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI=4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO=25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle=0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i,j
      real(kind=8) :: CT_c_AV(n,nCT,2), P_c_AV(n,nCT,2)

      do i=1,nF
        CT_c_AV = CT_c
        P_c_AV  = P_c
        ! Re-defines the trust curve for non available turbines
        do j=1,n
          if (AV(i,j)==0) then
            CT_c_AV(j,:,2) = CT_idle(j)
            P_c_AV(j,:,2) = 0.0d0
          end if
        end do
        call gau_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c_AV,CT_c_AV,WS(i),WD(i),
     &       ks(i),Ng,rho,WS_CI,WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine gau_av

c ----------------------------------------------------------------------
c gau_GA(x,y,z,DT,P_c,CT_c,WS,WD,ks,STD_WD,Nga)
c ----------------------------------------------------------------------
c GAUSSIAN AVERAGE
c Gauss-Hermite quadrature for normally distributed wind direction
c uncertainty (inside Reynolds averaging time), for a global/unique wind
c direction uncertainty
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c ks (array): Linear wake expansion [-]
c STD_WD(array): Standard deviation of wind direction uncertainty
c Nga (int): Number of quadrature points for Gaussian averaging
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine gau_GA(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,
     &ks,STD_WD,Nga,Ng,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,Ng,Nga
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,WD,ks,STD_WD
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,ks,WD,STD_WD
cf2py integer optional,intent(in) :: Nga = 4
cf2py integer optional intent(in) :: Ng = 4
cf2py real(kind=8) optional,intent(in) :: rho=1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI=4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO=25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle=0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i,j
      real(kind=8) :: WD_aux
      real(kind=8), dimension(n) :: P_aux,T_aux,U_aux
      real(kind=8), dimension(Nga) :: root,weight

      ! Gauss-Hermite quadrature points and weights
      select case (Nga)
        case ( 1 )
          root(1) = 0.0d0
          weight(1) = sqrt(pi)
        case ( 4 )
          root(1) = -1.650680123885785d0
          root(2) = -0.524647623275290d0
          root(3) = 0.524647623275290d0
          root(4) = 1.650680123885785d0

          weight(1) = 0.081312835447245d0
          weight(2) = 0.804914090005513d0
          weight(3) = 0.804914090005513d0
          weight(4) = 0.081312835447245d0
        case ( 5 )
          root(1) = -2.020182870456086d0
          root(2) = -0.958572464613819d0
          root(3) = 0.000000000000000d0
          root(4) = 0.958572464613819d0
          root(5) = 2.020182870456086d0

          weight(1) = 0.019953242059046d0
          weight(2) = 0.393619323152241d0
          weight(3) = 0.945308720482942d0
          weight(4) = 0.393619323152241d0
          weight(5) = 0.019953242059046d0
        case ( 6 )
          root(1) = -2.350604973674492d0
          root(2) = -1.335849074013697d0
          root(3) = -0.436077411927617d0
          root(4) = 0.436077411927617d0
          root(5) = 1.335849074013697d0
          root(6) = 2.350604973674492d0

          weight(1) = 0.004530009905509d0
          weight(2) = 0.157067320322856d0
          weight(3) = 0.724629595224392d0
          weight(4) = 0.724629595224392d0
          weight(5) = 0.157067320322856d0
          weight(6) = 0.004530009905509d0
        case ( 7 )
          root(1) = -2.651961356835233d0
          root(2) = -1.673551628767471d0
          root(3) = -0.816287882858965d0
          root(4) = 0.000000000000000d0
          root(5) = 0.816287882858965d0
          root(6) = 1.673551628767471d0
          root(7) = 2.651961356835233d0

          weight(1) = 0.000971781245100d0
          weight(2) = 0.054515582819127d0
          weight(3) = 0.425607252610128d0
          weight(4) = 0.810264617556807d0
          weight(5) = 0.425607252610128d0
          weight(6) = 0.054515582819127d0
          weight(7) = 0.000971781245100d0
        case ( 8 )
          root(1) = -2.930637420257244d0
          root(2) = -1.981656756695843d0
          root(3) = -1.157193712446780d0
          root(4) = -0.381186990207322d0
          root(5) = 0.381186990207322d0
          root(6) = 1.157193712446780d0
          root(7) = 1.981656756695843d0
          root(8) = 2.930637420257244d0

          weight(1) = 0.000199604072211d0
          weight(2) = 0.017077983007413d0
          weight(3) = 0.207802325814892d0
          weight(4) = 0.661147012558241d0
          weight(5) = 0.661147012558241d0
          weight(6) = 0.207802325814892d0
          weight(7) = 0.017077983007413d0
          weight(8) = 0.000199604072211d0
      end select

      do i=1,nF
        P(i,:)=0.0d0
        T(i,:)=0.0d0
        U(i,:)=0.0d0
        do j=1,Nga
          WD_aux = WD(i)+sqrt(2.0d0)*STD_WD(i)*root(j)
          call gau_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD_aux,
     &     ks(i),Ng,rho,WS_CI,WS_CO,CT_idle,P_aux,T_aux,U_aux)
          P(i,:)=P(i,:)+weight(j)*P_aux*(1.0d0/sqrt(pi))
          T(i,:)=T(i,:)+weight(j)*T_aux*(1.0d0/sqrt(pi))
          U(i,:)=U(i,:)+weight(j)*U_aux*(1.0d0/sqrt(pi))
        end do
      end do

      end subroutine gau_GA

c ----------------------------------------------------------------------
c gau_mult_wd(x,y,z,DT,P_c,CT_c,WS,WD,ks)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES with individual wind direction for each turbine
c and optional individual Gaussian averaging
c
c Inputs
c ----------
c x_g (array): Distance between turbines in the global coordinates
c y_g (array): Distance between turbines in the global coordinates
c z_g (array): Distance between turbines in the global coordinates
c DT (array): Turbines diameter
c P_c (array): Power curves
c CT_c (array): Thrust coefficient curves
c WS (array): Undisturbed rotor averaged (equivalent) wind speed at hub
c             height [m/s]
c WD (array): Undisturbed wind direction at hub height [deg.]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c ks (array): Linear wake expansion [-]
c
c rho (float): Air density at which the power curve is valid [kg/m^3]
c WS_CI (array): Cut in wind speed [m/s] for each turbine
c WS_CO (array): Cut out wind speed [m/s] for each turbine
c CT_idle (array): Thrust coefficient at rest [-] for each turbine
c
c Outputs
c ----------
c P (array): Power production of the wind turbines (nWT,1) [W]
c T (array): Thrust force of the wind turbines (nWT,1) [N]
c U (array): Rotor averaged (equivalent) Wind speed at hub height
c            (nWT,1) [m/s]
      subroutine gau_mult_wd(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,
     &ks,STD_WD,Nga,Ng,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,Ng,Nga
      real(kind=8) :: x_g(n,n),y_g(n,n),z_g(n,n),DT(n),P_c(n,nP,2)
      real(kind=8) :: CT_c(n,nCT,2),rho,WS_CI(n),WS_CO(n),CT_idle(n)
      real(kind=8),dimension(nF) :: WS,ks
      real(kind=8),dimension(nF,n) :: WD,STD_WD
      real(kind=8) :: P(nF,n),T(nF,n),U(nF,n)
cf2py integer intent(hide),depend(DT) :: n = len(DT)
cf2py integer intent(hide),depend(P_c) :: nP = size(P_c,2)
cf2py integer intent(hide),depend(CT_c) :: nCT = size(CT_c,2)
cf2py integer intent(hide),depend(WS) :: nF = len(WS)
cf2py real(kind=8) intent(in),dimension(n) :: DT
cf2py real(kind=8) intent(in),depend(n),dimension(n,n) :: x_g,y_g,z_g
cf2py real(kind=8) intent(in),dimension(n,nP,2) :: P_c
cf2py real(kind=8) intent(in),dimension(n,nCT,2) :: CT_c
cf2py real(kind=8) intent(in),dimension(nF) :: WS,ks
cf2py real(kind=8) intent(in),dimension(nF,n) :: WD
cf2py real(kind=8) optional,intent(in),dimension(nF,n) :: STD_WD = 0.0
cf2py integer optional intent(in) :: Nga = 1
cf2py integer optional intent(in) :: Ng = 4
cf2py real(kind=8) optional,intent(in) :: rho=1.225
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CI=4.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: WS_CO=25.0
cf2py real(kind=8) optional,intent(in),dimension(n) :: CT_idle=0.053
cf2py real(kind=8) intent(out),depend(n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i,j
      real(kind=8), dimension(n) :: P_aux,T_aux,U_aux

      do j=1,n
        do i=1,nF
          call gau_GA(n,nP,nCT,1,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD(i,j),
     &ks(i),STD_WD(i,j),Nga,Ng,rho,
     &WS_CI,WS_CO,CT_idle,P_aux,T_aux,U_aux)

          P(i,j)=P_aux(j)
          T(i,j)=T_aux(j)
          U(i,j)=U_aux(j)
        end do
      end do

      end subroutine gau_mult_wd

c ----------------------------------------------------------------------
c Additional routines
c ----------------------------------------------------------------------

c ----------------------------------------------------------------------
c Find the lower location index of a point in an ordered array
c ----------------------------------------------------------------------
      subroutine loc_in_list(n,xa,x,j)
      implicit none
      integer j,n
      real(kind=8) x,xa(n)
cf2py integer intent(hide),depend(xa) :: n = len(xa)
cf2py real(kind=8) intent(in),dimension(n) :: xa
cf2py real(kind=8) intent(in) :: x
cf2py integer intent(out) :: j
      ! internal variables
      integer j_low,j_mid,j_up
      j_low=0
      j_up=n+1
      ! bisecting loop
      do while (j_up-j_low.gt.1)
        j_mid=(j_up+j_low)/2
        if((xa(n).ge.xa(1)).eqv.(x.ge.xa(j_mid)))then
          j_low=j_mid
        else
          j_up=j_mid
        end if
      end do
      ! check for cases
      if(x.eq.xa(1))then
        j=1
      else if(x.eq.xa(n))then
        j=n-1
      else
        j=j_low
      end if
      end subroutine loc_in_list

c ----------------------------------------------------------------------
c Linear interpolation
c ----------------------------------------------------------------------
      subroutine interp_l(xa,ya,n,x,y)
      implicit none
      integer n
      real(kind=8) x,y,xa(n),ya(n)
cf2py integer intent(hide),depend(xa) :: n = len(xa)
cf2py real(kind=8) intent(in),dimension(n) :: xa
cf2py real(kind=8) intent(in),depend(n),dimension(n) :: ya
cf2py real(kind=8) intent(in) :: x
cf2py real(kind=8) intent(out) :: y
      ! internal variables
      integer j
      call loc_in_list(n,xa,x,j)
      y = ((ya(j+1)-ya(j))/(xa(j+1)-xa(j)))*(x-xa(j)) + ya(j)
      end subroutine interp_l

c ----------------------------------------------------------------------
c Finds the index that order an array from lower to higher values
c only for integers
c
c Knuth, D. E. "Sorting and Searching, vol. 3 of The Art of Computer
c Programming, section 6.2. 2." (1997): 430-31.
c ----------------------------------------------------------------------
      subroutine order_id(n,a,id)
      integer n,a(n),id(n)
cf2py integer intent(hide),depend(a) :: n = len(a)
cf2py integer intent(in),dimension(n) :: a
cf2py integer intent(out),depend(n),dimension(n) :: id
      ! internal variables
      integer i,j,inc,v,w
      do i=1,n
        id(i)=i
      end do
      ! Determine starting increment
      inc=1
      do while (inc.le.n)
        inc=3*inc+1
      end do
      ! Partial sorts loop
      do while (inc.gt.1)
        inc=inc/3
        do i=inc+1,n
          v=a(i)
          w=id(i)
          j=i
          do while (a(j-inc).gt.v)
            a(j)=a(j-inc)
            id(j)=id(j-inc)
            j=j-inc
            if(j.le.inc) exit
          end do
          a(j)=v
          id(j)=w
        end do
      end do
      end subroutine order_id


SUBROUTINE DiffXXEvenCurvilinear(var,varXX,Nxg,Nyg,Nzg,CompGrid,kappa)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: Nxg, Nyg, Nzg, order, kappa, i,j,k
REAL(KIND=long), DIMENSION(Nzg,Nxg,Nyg) :: var, varXX, vare, varn, varee, varnn, varen
REAL(KIND=long), DIMENSION(2*kappa+1,2*kappa+1,2) :: DiffStencilArray
REAL(KIND=long) :: ex, exx, nx, nxx ,DMe, DMn, DM2en, DM2e, DM2n

DiffStencilArray = CompGrid%CurvilinearStuff%DiffStencils%StencilG

CALL DiffXuniform3D(var,vare,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffYuniform3D(var,varn,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffXuniform3D(var,varee,2,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffYuniform3D(var,varnn,2,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
! mixed
CALL DiffYuniform3D(vare,varen,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?

DO i = 1, Nxg
	DO j = 1, Nyg
		ex   = CompGrid%CurvilinearStuff%ex(i,j)
		nx   = CompGrid%CurvilinearStuff%nx(i,j)
		exx  = CompGrid%CurvilinearStuff%exx(i,j)
		nxx  = CompGrid%CurvilinearStuff%nxx(i,j)
		DO k = 1, Nzg
			DMe  = vare(k,i,j)
			DM2e = varee(k,i,j)
			DMn  = varn(k,i,j)
			DM2n = varnn(k,i,j)
			DM2en = varen(k,i,j)
			varXX(k,i,j) = exx*DMe+nxx*DMn+two*ex*nx*DM2en+ex**2*DM2e+nx**2*DM2n
		END DO
	END DO
END DO
END SUBROUTINE DiffXXEvenCurvilinear


*----------------------------------------------------------------------*
      subroutine mat_svd_traf(ndim,mat,mat2,
     &                       icnt_sv,icnt_sv0,
     &                       xmax,xmin,bins)
*----------------------------------------------------------------------*
*     Perform an SVD and similarity transform the matrix
*     by the right-hand unitary matrix.
*     On output, mat2 contains the transformed matrix
*     and mat the unitary matrix
*
*     matthias, nov 2013
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'routes.h'
      include 'def_filinf.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00
      integer, intent(in) ::
     &     ndim
      integer, intent(inout) ::
     &     icnt_sv, icnt_sv0, bins(17)
      real(8), intent(inout), target ::
     &     mat(ndim,ndim), mat2(ndim,ndim), xmax, xmin
      real(8) ::
     &     dum1, cur_sv, singval(ndim), vt(ndim,ndim)
      real(8), pointer::
     &     wrk(:)

      type(filinf) ::
     &     ffsv
      integer ::
     &     idx, info, idx2, luinp, iostatus, lwrk, ifree
      logical ::
     &     l_exist, sv_above, read_file, symmetrize

      if (ndim.eq.0) return

      ifree = mem_setmark('mat_svd_traf')

      info = 0
      lwrk = max(1024,ndim**2)
      ifree = mem_alloc_real(wrk, lwrk,'wrk')

      if (jac_fix) then
        inquire(file='SINGVALS2',exist=l_exist)
        call file_init(ffsv,'SINGVALS2',ftyp_sq_frm,0)
        call file_open(ffsv)
        luinp = ffsv%unit
        read_file = l_exist
        if (l_exist) then
          do idx = 1, icnt_sv + 1
            read(luinp,*,iostat=iostatus) idx2, sv_above
          end do
          read_file = iostatus.ge.0
          rewind luinp
          do idx = 1, icnt_sv
            read(luinp,*) idx2, sv_above
          end do
        end if
      end if

      if (ntest.ge.100) then
        write(lulog,'(x,a)') '--------------------'
        write(lulog,'(x,a)') 'mat_svd_traf at work'
        write(lulog,'(x,a)') '--------------------'
        write(lulog,*) 'input matrix:'
        call wrtmat2(mat,ndim,ndim,ndim,ndim)
      end if

      ! for testing: but as already noted by MH, this does not
      !   lead to improvements, on the contrary actually ...  AK
      symmetrize = .false.  ! so leave .false.
      if (symmetrize) then
        ! symmetrize
        do idx = 1, ndim
          do idx2 = 1,idx-1
            mat(idx2,idx) = 0.5d0 *
     &                     (mat(idx2,idx) + mat(idx,idx2))
            mat(idx,idx2) = mat(idx2,idx)
          end do
        end do
        if (ntest.ge.100) then
          write(lulog,*) 'symmetrized matrix:'
          call wrtmat2(mat,ndim,ndim,ndim,ndim)
        end if
      end if

      ! copy matrix and perform SVD
      mat2 = mat
      call dgesvd('N','S',ndim,ndim,
     &     mat,ndim,singval,
     &     dum1,1,vt,ndim,
     &     wrk,lwrk,info)
      if (info.ne.0) call quit(1,'mat_svd_traf','SVD in trouble.')
      ! transpose V^T:
      do idx = 1, ndim
        mat(1:ndim,idx) = vt(idx,1:ndim)
      end do

c      ! symmetrize
c      do idx = 1, ndim
c        do idx2 = 1,ndim
c          mat2(idx2,idx) = mat(idx,idx2)
c        end do
c      end do
c      do idx = 1, ndim
c        do idx2 = 1,ndim
c          mat2(idx2,idx) = 0.5d0 *
c     &                    (mat(idx2,idx) + mat2(idx2,idx))
c        end do
c      end do
c      if (ntest.ge.100) then
c        write(lulog,*) 'symmetrized matrix:'
c        call wrtmat2(mat2,ndim,ndim,ndim,ndim)
c      end if
c
c      ! calculate U and eigenvalues:
c      call rs(ndim,ndim,mat2,eigr,1,mat,scr1,scr2,info)
c
c      if (info.ne.0) then
c        call warn('mat_svd_traf','Some problem in rs.f')
c      end if

      if (ntest.ge.100) then
        write(lulog,*) 'unitary matrix V:'
        call wrtmat2(mat,ndim,ndim,ndim,ndim)
        write(lulog,*) 'singular values:'
      end if

      ! exclude eigenvalues below threshold or as given by SINGVALS2
      do idx = 1, ndim
        icnt_sv = icnt_sv + 1
        sv_above = .false.
        if (jac_fix.and.read_file) read(luinp,*) idx2, sv_above

        ! binning of eigenvalue
        cur_sv = singval(idx)
        dum1 = cur_sv
        do idx2 = 1, 17 !9
          if (dum1.ge.1d0) then
            bins(idx2) = bins(idx2) + 1
            exit
c          else if (dum1.le.-1d0) then
c            bins(17-idx2) = bins(17-idx2) + 1
c            exit
          end if
          dum1 = dum1*10d0
          if (idx2.eq.17) bins(idx2) = bins(idx2) + 1
c          if (idx2.eq.9) bins(idx2) = bins(idx2) + 1
        end do

        if (.not.(jac_fix.and.read_file).and.
     &      singval(idx).gt.jac_thresh
     &      .or.sv_above) then
          sv_above = .true.
          if (abs(singval(idx)).lt.abs(xmin)) xmin = singval(idx)
        else
          sv_above = .false.
          icnt_sv0 = icnt_sv0 + 1
          if (abs(singval(idx)).gt.abs(xmax)) xmax = singval(idx)
          mat(1:ndim,idx) = 0d0
          singval(idx) = 0d0
        end if
        if (ntest.ge.10) write(lulog,'(x,a,i8,x,f24.12,3x,L1)') 'ev #',
     &                 icnt_sv,cur_sv,sv_above
        if (jac_fix.and..not.read_file) write(luinp,*) icnt_sv, sv_above
      end do

      if (ntest.ge.100) then
        write(lulog,'(a,f5.2,a)') 'truncated matrix V:'
        call wrtmat2(mat,ndim,ndim,ndim,ndim)
      end if

c      ! write diagonalized matrix
c      mat2(1:ndim,1:ndim) = 0d0
c      do idx = 1, ndim
c        mat2(idx,idx) = eigr(idx)
c      end do

      ! explicitly compute similarity transformed matrix
      call dgemm('t','n',ndim,ndim,ndim,
     &            1d0,mat,ndim,
     &            mat2,ndim,
     &            0d0,vt,ndim)
      call dgemm('n','n',ndim,ndim,ndim,
     &            1d0,vt,ndim,
     &            mat,ndim,
     &            0d0,mat2,ndim)

      if (ntest.ge.100) then
        write(lulog,'(a,f5.2,a)') 'transformed matrix:'
        call wrtmat2(mat2,ndim,ndim,ndim,ndim)
      end if

      if (jac_fix) call file_close_keep(ffsv)

      ifree = mem_flushmark()

      return
      end


SUBROUTINE periodic_tdma_solver(a,b,c,d,X,N)
	IMPLICIT NONE
	integer, intent(in)::N
	double precision, intent(in), dimension(1:N)::a,b,c,d
	double precision, intent(out),dimension(1:N)::X
	double precision, allocatable,dimension(:) :: p , q , r , w , u , x1
	INTEGER :: i,j
	double precision::sum1=0.0d0,maxerror
	character(80)::str
	double precision, allocatable, dimension(:)::error

	allocate(p(2:N),q(1:N),r(1:N-2),w(1:N-2),u(1:N-1),x1(1:N),error(1:N))

	q(1) = b(1)
	w(1) = a(1) / b(1)
	u(1) = c(1) / b(1)
	r(1) = c(N)
	sum1 = r(1) * w(1)

	DO i = 2 , N-2
	  p(i) = a(i)
	  q(i) = b(i) - p(i) * u(i-1)
	  u(i) = c(i) / q(i)
	  w(i) = - p(i) * w(i-1) / q(i)
	  r(i) = - r(i-1) * u(i-1)
	  sum1  = sum1 + r(i) * w(i)
	ENDDO

	i = N-1
	p(i) = a(i)
	q(i) = b(i) - p(i) * u(i-1)
	u(i) = (c(i) - p(i) * w(i-1)) / q(i)
	p(N) = a(N) - r(N-2) * u(N-2)
	q(N) = b(N) - sum1 - p(N) * u(N-1)
	x1(1) = d(1) / q(1)
!
	DO i = 2 , N-1
	  x1(i) = (d(i) - p(i) * x1(i-1)) / q(i)
	ENDDO
	sum1 = 0.0d0
	DO i = 1 , N-2
	  sum1 = sum1 + r(i) * x1(i)
	ENDDO
	x1(N) = (d(N) - sum1 - p(N) * x1(N-1)) / q(N)
	X(N) = x1(N)

	X(N-1) = x1(N-1) - u(N-1) * X(N)

	DO i = N-2 , 1 , -1
	  X(i) = x1(i) - u(i) * X(i+1) - w(i) * X(N)
	ENDDO

	deallocate(x1,p,q,u,w,r,error)

END SUBROUTINE periodic_tdma_solver

subroutine Periodic_OUCS3(temp,tempzi,N,dzi)
	implicit none

	integer::i,j,k,N
	double precision::alpha1=0.0d0
	double precision::b2=1.0d0
	double precision,dimension(-2:2)::Const
	double precision::term1,term2,beta,b1,b3, dzi
	double precision,dimension(1:N)::an,bn,cn,Rn
	double precision,intent(in),dimension(0:N)::temp
	double precision,intent(out),dimension(0:N)::tempzi

	Const(-2)=-0.183205192/4.0d0+alpha1/300.0d0
	Const( 2)= 0.183205192/4.0d0+alpha1/300.0d0
	Const(-1)=-1.57557379/2.0d0+alpha1/30.0d0
	Const( 1)= 1.57557379/2.0d0+alpha1/30.0d0
	Const( 0)=-11.0d0*alpha1/150.0d0

	b2= 1.0d0
	b1= 0.3793894912d0-alpha1/60.0d0
	b3= 0.3793894912d0+alpha1/60.0d0

	an=b1
	bn=b2
	cn=b3

	do j=2,N-2
	  Rn(j)=(Const(-2)*temp(j-2)+Const(-1)*temp(j-1)+Const(0)*temp(j)&
                     &+Const(1)*temp(j+1)+Const(2)*temp(j+2))/dzi
        enddo
        Rn(1)  =(Const(-2)*temp(N-1)+Const(-1)*temp(N)+Const(0)*temp(1)&
                     &+Const(1)*temp(2)+Const(2)*temp(3))/dzi
        Rn(N)  =(Const(-2)*temp(N-2)+Const(-1)*temp(N-1)+Const(0)*temp(N)&
                     &+Const(1)*temp(1)+Const(2)*temp(2))/dzi
        Rn(N-1)=(Const(-2)*temp(N-3)+Const(-1)*temp(N-2)+Const(0)*temp(N-1)&
                     &+Const(1)*temp(0)+Const(2)*temp(1))/dzi
	call periodic_tdma_solver(an,bn,cn,Rn,tempzi(1:N),N)
        tempzi(0)=tempzi(N)
end subroutine Periodic_OUCS3

subroutine Periodic_O3CS(temp,tempzi3,N,dzi3)     ! for 3rd derivative
	implicit none

	integer::i,j,k,N
	double precision::alpha1=0.0d0
	double precision::b2=1.0d0
	double precision,dimension(-2:2)::Const
	double precision::term1,term2,beta,b1,b3, dzi3
	double precision,dimension(1:N)::an,bn,cn,Rn
	double precision,intent(in),dimension(0:N)::temp
	double precision,intent(out),dimension(0:N)::tempzi3

	Const(-2)= -0.957036d0      !+alpha1/300.0d0
	Const( 2)=  0.957036d0      !+alpha1/300.0d0
	Const(-1)=  1.914072d0      !+alpha1/30.0d0
	Const( 1)= -1.914072d0      !+alpha1/30.0d0
	Const( 0)=  0d0             !-11.0d0*alpha1/150.0d0

	b2= 1.0d0
	b1= 0.457036d0         !-alpha1/60.0d0
	b3= 0.457036d0         !+alpha1/60.0d0

	an=b1
	bn=b2
	cn=b3

	do j=2,N-2
	  Rn(j)=(Const(-2)*temp(j-2)+Const(-1)*temp(j-1)+Const(0)*temp(j)&
                     &+Const(1)*temp(j+1)+Const(2)*temp(j+2))/dzi3
        enddo
        Rn(1)  =(Const(-2)*temp(N-1)+Const(-1)*temp(N)+Const(0)*temp(1)&
                     &+Const(1)*temp(2)+Const(2)*temp(3))/dzi3
        Rn(N)  =(Const(-2)*temp(N-2)+Const(-1)*temp(N-1)+Const(0)*temp(N)&
                     &+Const(1)*temp(1)+Const(2)*temp(2))/dzi3
        Rn(N-1)=(Const(-2)*temp(N-3)+Const(-1)*temp(N-2)+Const(0)*temp(N-1)&
                     &+Const(1)*temp(0)+Const(2)*temp(1))/dzi3
	call periodic_tdma_solver(an,bn,cn,Rn,tempzi3(1:N),N)
        tempzi3(0)=tempzi3(N)
end subroutine Periodic_O3CS


      constant nx, ny, nz, nbdy;

      do j = 4,ny+nbdy-2
         do i = 4,nx+nbdy-3
            do k = 4,nz+nbdy-3
            ab(k,i,j) = (f60 * (a(k,i,j-1) + a(k,i,j)) + f61 * (a(k,i,j-2) + a(k,i,j+1)) + f62 * (a(k,i,j-3) + a(k,i,j+2))) * thirddtbydy * uyb(k,i,j)
            end do
         end do
      end do

      do j = 4,ny+nbdy-3
         do i = 4,nx+nbdy-2
            do k = 4,nz+nbdy-3
               al(k,i,j) = (f60 * (a(k,i-1,j) + a(k,i,j)) + f61
     * (a(k,i-2,j) + a(k,i+1,j)) + f62 * (a(k,i-3,j) + a(k,i+2,j)))
     * thirddtbydx * uxl(k,i,j)
            end do
         end do
      end do

      do j = 4,ny+nbdy-3
         do i = 4,nx+nbdy-3
            do k = 4,nz+nbdy-2
               af(k,i,j) = (f60 * (a(k-1,i,j) + a(k,i,j)) + f61
     * (a(k-2,i,j) + a(k+1,i,j)) + f62 * (a(k-3,i,j) + a(k+2,i,j)))
      * thirddtbydz * uzf(k,i,j)
            end do
         end do
      end do

      do j = 4,ny+nbdy-3
         do i = 4,nx+nbdy-3
            do k = 4,nz+nbdy-3
               athird(k,i,j) = a(k,i,j) + (al(k,i+1,j) - al(k,i,j))
      + (ab(k,i,j+1) - ab(k,i,j)) + (af(k+1,i,j) - af(k,i,j))
            end do
         end do
      end do

        do j = 7,ny+nbdy-5
         do i = 7,nx+nbdy-6
            do k = 7,nz+nbdy-6
               abthird(k,i,j) = (f60 * (athird(k,i,j-1) + athird(k,i,j))
                   + f61 * (athird(k,i,j-2) + athird(k,i,j+1))
                   + f62 * (athird(k,i,j-3) + athird(k,i,j+2)))
                   * halfdtbydx * uybthird(k,i,j)
            end do
         end do
      end do

      do j = 7,ny+nbdy-6
         do i = 7,nx+nbdy-5
            do k = 7,nz+nbdy-6
               althird(k,i,j) = (f60 * (athird(k,i-1,j) + athird(k,i,j))
                   + f61 * (athird(k,i-2,j) + athird(k,i+1,j))
                   + f62 * (athird(k,i-3,j) + athird(k,i+2,j)))
                   * halfdtbydx * uxlthird(k,i,j)
            end do
         end do
      end do

      do j = 7,ny+nbdy-6
         do i = 7,nx+nbdy-6
            do k = 7,nz+nbdy-5
               afthird(k,i,j) = (f60 * (athird(k-1,i,j) + athird(k,i,j))
                   + f61 * (athird(k-2,i,j) + athird(k+1,i,j))
                   + f62 * (athird(k-3,i,j) + athird(k+2,i,j)))
                   * halfdtbydx * uzfthird(k,i,j)
            end do
         end do
      end do

      do j = 7,ny+nbdy-6
         do i = 7,nx+nbdy-6
            do k = 7,nz+nbdy-6
               ahalf(k,i,j) = a(k,i,j) + (althird(k,i+1,j)
                   - althird(k,i,j))
                   + (abthird(k,i,j+1) - abthird(k,i,j))
                   + (afthird(k+1,i,j) - afthird(k,i,j))
            end do
         end do
      end do


      SUBROUTINE frprmn(p,n,ftol,iter,fret)
      INTEGER iter,n,NMAX,ITMAX
      REAL fret,ftol,p(n),EPS,func
      EXTERNAL func
      PARAMETER (NMAX=50,ITMAX=200,EPS=1.e-10)
CU    USES dfunc,func,linmin
      INTEGER its,j
      REAL dgg,fp,gam,gg,g(NMAX),h(NMAX),xi(NMAX)
      fp=func(p)
      call dfunc(p,xi)
      do 11 j=1,n
        g(j)=-xi(j)
        h(j)=g(j)
        xi(j)=h(j)
11    continue
      do 14 its=1,ITMAX
        iter=its
        call linmin(p,xi,n,fret)
        if(2.*abs(fret-fp).le.ftol*(abs(fret)+abs(fp)+EPS))return
        fp=func(p)
        call dfunc(p,xi)
        gg=0.
        dgg=0.
        do 12 j=1,n
          gg=gg+g(j)**2
C         dgg=dgg+xi(j)**2
          dgg=dgg+(xi(j)+g(j))*xi(j)
12      continue
        if(gg.eq.0.)return
        gam=dgg/gg
        do 13 j=1,n
          g(j)=-xi(j)
          h(j)=g(j)+gam*h(j)
          xi(j)=h(j)
13      continue
14    continue
      pause 'frprmn maximum iterations exceeded'
      return
      END

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


      SUBROUTINE perturbation_step
      USE global
      IMPLICIT NONE
      REAL*8  ::X1(1,NX)
      INTEGER :: IC, CL0EH, CL0EC, CL0I, CL0V
!
!---------------------------------------------------------------------
!
      XC = aint(0.5*NX)      ! Center of the system lenght

!--------- HOT Electron density perturbation ------------------------------
      CL0EH = aint(0.5*L0EH)      ! Center of PERTURBATION WIDHT

!
      DO 121 IC=3, NXP2
          IF ((IC < XC-CL0EH) .OR. (IC > XC+CL0EH)) THEN
             NEH(1,IC) = N0EH;
          ELSE
             NEH(1,IC) = N0EH + N0EH*DNEH;
          END IF
  121 CONTINUE

! ---- Boundary condition -------
      NEH(1,1)      = NEH(1,NXP1)
      NEH(1,2)      = NEH(1,NXP2)
      NEH(1,NXP3)   = NEH(1,3)
      NEH(1,NXP4)   = NEH(1,4)
!
      NEH(2,:) = NEH(1,:)
!--------- COLD Electron density perturbation ------------------------------
      CL0EC = aint(0.5*L0EC)      ! Center of PERTURBATION WIDHT

!
      DO 11 IC=3, NXP2
          IF ((IC < XC-CL0EC) .OR. (IC > XC+CL0EC)) THEN
             NEC(1,IC) = N0EC;
          ELSE
             NEC(1,IC) = N0EC + N0EC*DNEC;
          END IF
  11  CONTINUE

! ---- Boundary condition -------
      NEC(1,1)      = NEC(1,NXP1)
      NEC(1,2)      = NEC(1,NXP2)
      NEC(1,NXP3)   = NEC(1,3)
      NEC(1,NXP4)   = NEC(1,4)
!
      NEC(2,:) = NEC(1,:)
! -------------- Ion density perturbation ----------------------------
      CL0I = aint(0.5*L0I)      ! Center of PERTURBATION WIDHT

!
      DO 191 IC=3, NXP2
          IF ((IC < XC-CL0I) .OR. (IC > XC+CL0I)) THEN
             NI(1,IC) = N0I;
          ELSE
             NI(1,IC) = N0I + N0I*DNI;
          END IF
  191 CONTINUE

! ---- Boundary condition -------
      NI(1,1)      = NI(1,NXP1)
      NI(1,2)      = NI(1,NXP2)
      NI(1,NXP3)   = NI(1,3)
      NI(1,NXP4)   = NI(1,4)
!
      NI(2,:) = NI(1,:)
! --------- Velocity perutrubation -----------------------------------
      CL0V = aint(0.5*L0V)      ! Center of PERTURBATION WIDHT

!
      DO 13 IC=3, NXP2
          IF ((IC < XC-CL0V) .OR. (IC > XC+CL0V)) THEN
             VX(1,IC) = VX0;
          ELSE
             VX(1,IC) = VX0 + DNV;
          END IF
  13  CONTINUE

! ---- Boundary condition -------
      VX(1,1)      = VX(1,NXP1)
      VX(1,2)      = VX(1,NXP2)
      VX(1,NXP3)   = VX(1,3)
      VX(1,NXP4)   = VX(1,4)
!
! ------- Calculating "Phi" form the initial purturbation -------------
          DO 553 IC = 3, NXP2
          PH(1,IC+1) = 2*PH(1,IC) - PH(1,IC-1) - DX*DX*(NI(1,IC) - NEH(1,IC)- NEC(1,IC))
  553     CONTINUE
! ---- Boundary condition -------
      PH(1,1)      = PH(1,NXP1)
      PH(1,2)      = PH(1,NXP2)
      PH(1,NXP3)   = PH(1,3)
      PH(1,NXP4)   = PH(1,4)
!
      PH(2,:) = PH(1,:)
!
      END SUBROUTINE perturbation_step


!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!subroutine Open_linearPk based on E. Komatsu's CRL routine which has been modified for use in CosmoSIS as we
!no longer read Pk from a file, all NR removed. EJ
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
MODULE LinearPk
  IMPLICIT none
  INTEGER :: jlo,ndata
  DOUBLE PRECISION, dimension(:), allocatable :: xa,ya,y2a
  DOUBLE PRECISION :: ak_min, ak_max
contains
  SUBROUTINE Open_LinearPk(aklin,pk_lin,n)
    IMPLICIT none
    integer, parameter :: dl=8
    real(dl),  dimension(:) :: aklin
    real(dl),  dimension(:) :: pk_lin
    integer n, ibcbeg,ibcend
    DOUBLE PRECISION :: ybcbeg,ybcend
    INTEGER :: i
    ndata=n
    ALLOCATE(xa(ndata),ya(ndata),y2a(ndata))
    xa=dlog(aklin)
    ya=dlog(pk_lin)
    !Natural spline settings
    ibcbeg = 2
    ybcbeg =0.0D+00
    ibcend = 2
    ybcend =0.0D+00
    CALL spline_cubic_set(ndata,xa,ya,ibcbeg,ybcbeg,ibcend,ybcend,y2a)
    ak_min=aklin(1)
    ak_max=aklin(ndata)
    return
  END SUBROUTINE Open_LinearPk
  SUBROUTINE Close_LinearPk
    DEALLOCATE(xa,ya,y2a)
    return
  END SUBROUTINE Close_LinearPk
END MODULE LinearPk
DOUBLE PRECISION FUNCTION Linear_Pk(ak)
  Use LinearPk
  IMPLICIT none
  DOUBLE PRECISION :: a,b,h,x,y,ak,ypval, yppval
  if (ak .le. ak_min .or. ak .ge. ak_max) then
        linear_pk = 0.0
        return
  endif
  x  = dlog(ak)
  CALL spline_cubic_val( ndata, xa, ya, y2a, x, y, ypval, yppval )
  Linear_Pk = dexp(y)
  return
END FUNCTION Linear_Pk


!********************************************************************************
!   TRUNC_EXP: Compare FPML against Polzers and AMVW on the truncated exponential.
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 11 Novemeber 2018
!********************************************************************************
! The speed and accuracy of FPML is compared against Polzeros and AMVW for
! computing the roots of the truncated exponential.
!********************************************************************************
program trunc_exp
    use fpml
    use poly_zeroes
    implicit none
    ! read in variables
    character(len=32)                           :: arg
    integer                                     :: flag, startDegree, endDegree, itnum
    ! testing variables
    integer                                     :: deg, it, j, clock_rate, clock_start, clock_stop
    real(kind=dp), dimension(:), allocatable    :: err
    real(kind=dp), dimension(:,:), allocatable  :: results
    ! FPML variables
    integer, parameter                          :: nitmax=30
    integer, dimension(:), allocatable          :: conv
    real(kind=dp), dimension(:), allocatable    :: berr, cond
    complex(kind=dp), dimension(:), allocatable :: p, roots
    ! Polzeros variables
    integer                                     :: iter
    logical, dimension(:), allocatable          :: h
    real(kind=dp), dimension(:), allocatable    :: radius
    complex(kind=dp), dimension(:), allocatable :: zeros
    ! AMVW variables
    real(kind=dp), dimension(:), allocatable    :: residuals
    complex(kind=dp), dimension(:), allocatable :: poly, eigs

    ! read in optional arguments
    call get_command_argument(1,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') startDegree
    else
        startDegree=10
    end if
    call get_command_argument(2,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') endDegree
    else
        endDegree=100
    end if
    call get_command_argument(3,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') itnum
    else
        itnum=512
    end if

    ! Testing: truncated exponential
    open(unit=1,file="data_files/trunc_exp.dat")
    write(1,'(A)') 'Degree, FPML_time, FPML_err, Polzeros_time, Polzeros_err, AMVW_time, AMVW_err'
    allocate(results(itnum,6))
    deg=startDegree
    do while(deg<=endDegree)
        write(1,'(I10)', advance='no') deg
        write(1,'(A)', advance='no') ','
        allocate(err(deg))
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
        allocate(zeros(deg), radius(deg), h(deg+1))
        allocate(poly(deg+1), eigs(deg), residuals(deg))
        ! polynomial
        p(1) = 1d0
        do j=2,deg+1
            p(j) = p(j-1)/dble(j-1)
        end do
        poly = (/ (p(deg-j+1), j=0,deg)/)
        do it=1,itnum
            ! FPML
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main(p, deg, roots, berr, cond, conv, nitmax)
            call system_clock(count=clock_stop)
            results(it,1) = dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,2) = maxval(berr)
            ! Polzeros
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call polzeros(deg, p, eps, big, small, nitmax, zeros, radius, h, iter)
            call system_clock(count=clock_stop)
            results(it,3)=dble(clock_stop-clock_start)/dble(clock_rate)
            call error(p, zeros, err, deg)
            results(it,4)=maxval(err)
            ! AMVW
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call z_poly_roots(deg, poly, eigs, residuals, flag)
            call system_clock(count=clock_stop)
            results(it,5)=dble(clock_stop-clock_start)/dble(clock_rate)
            call error(p, eigs, err, deg)
            results(it,6)=maxval(err)
        end do
        deallocate(err, p, roots, berr, cond, conv, zeros, radius, h, poly, eigs, residuals)
        ! write results to file
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,1))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,2))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,3))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,4))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,5))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)') sum(results(1:itnum,6))/itnum
        ! update deg
        deg=deg+2
    end do
    deallocate(results)
    ! close file
    close(1)
contains
    !************************************************
    !                   error                       *
    !************************************************
    ! Computes the relative backward error for
    ! each root approximation of p.
    !************************************************
    subroutine error(p, roots, err, deg)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        real(kind=dp), intent(out)      :: err(:)
        complex(kind=dp), intent(in)    :: p(:), roots(:)
        ! local variables
        integer                         :: j, k
        real(kind=dp)                   :: r, berr
        real(kind=dp), dimension(deg+1) :: alpha
        complex(kind=dp)                :: a, z

        ! main
        alpha = abs(p)
        alpha = (/ (alpha(j)*(3.8*(j-1)+1),j=1,deg+1)/)
        do j=1,deg
            z = roots(j)
            r = abs(z)
            if(r>1) then
                z = 1/z
                r = 1/r
                a = p(1)
                berr = alpha(1)
                do k=2,deg+1
                    a = z*a + p(k)
                    berr = r*berr + alpha(k)
                end do
            else
                a = p(deg+1)
                berr = alpha(deg+1)
                do k=deg,1,-1
                    a = z*a + p(k)
                    berr = r*berr + alpha(k)
                end do
            end if
            err(j) = abs(a)/berr
        end do
    end subroutine error
end program trunc_exp


module RCImagePrimitive
  use RCImageBasic

  implicit none

  type point
     integer :: x, y
  end type point

  private :: swapcoord

contains

  subroutine swapcoord(p1, p2)
    integer, intent(inout) :: p1, p2
    integer :: t

    t = p2
    p2 = p1
    p1 = t
  end subroutine swapcoord

  subroutine draw_line(img, from, to, color)
    type(rgbimage), intent(inout) :: img
    type(point), intent(in) :: from, to
    type(rgb), intent(in) :: color

    type(point) :: rfrom, rto
    integer :: dx, dy, error, ystep, x, y
    logical :: steep

    rfrom = from
    rto = to
    steep = (abs(rto%y - rfrom%y) > abs(rto%x - rfrom%x))
    if ( steep ) then
       call swapcoord(rfrom%x, rfrom%y)
       call swapcoord(rto%x, rto%y)
    end if
    if ( rfrom%x > rto%x ) then
       call swapcoord(rfrom%x, rto%x)
       call swapcoord(rfrom%y, rto%y)
    end if

    dx = rto%x - rfrom%x
    dy = abs(rto%y - rfrom%y)
    error = dx / 2
    y = rfrom%y

    if ( rfrom%y < rto%y ) then
       ystep = 1
    else
       ystep = -1
    end if

    do x = rfrom%x, rto%x
       if ( steep ) then
          call put_pixel(img, y, x, color)
       else
          call put_pixel(img, x, y, color)
       end if
       error = error - dy
       if ( error < 0 ) then
          y = y + ystep
          error = error + dx
       end if
    end do

  end subroutine draw_line

end module RCImagePrimitive


C==================================================================
C Sous routine ANA :
C    . Evaluation de la solution analytique du problème
C    . Sauvegarde dans uan.m
C
C Modifié le 11.04.97
C==================================================================
C
      SUBROUTINE ANA(hh,cond,rhoc,N,L,Tf,NT,dt,dx,
     #               ISAV,MUL,TFIN)
C
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 L,bm(200),C(200)
C
C     Initialisation
C     --------------
      H   = hh/cond
      eta = cond/rhoc
      NX  = N
      pi  = 4.0D0*DATAN(1.0D0)
C
C                         .On calcule la solution uniquement
C                          pour les pas sauvegardés
      dt  = DBLE(ISAV)*dt
      NT  = NT/ISAV
C                         .Nombre de termes (2° formule)
      NC  = 100
C                         .Nombre de bm à calculer
      NZ  = 150
C                         .Tolérence de bissection
      tol = 1.0D-09
C
C     Ouverture du fichier
C     --------------------
      OPEN(UNIT=2,FILE='uan.m',STATUS='UNKNOWN')
C
C     Recherche des zeros
C     -------------------
      WRITE(*,*)'Calcul de la solution analytique'
      WRITE(*,*)'Recherche des racines'
C
      DO i=1,NZ
C         WRITE(*,*)i
         x1=(DBLE(i)-1+1.0D-10)*pi/L
         x2=(DBLE(i)-1-1.0D-10)*pi/L+pi/L/2.0D0
         f1=fct(x1,L,H)
 10         IF (DABS(f1).LT.tol) GOTO 20
            x3=(x2+x1)/2.0D0
            f3=fct(x3,L,H)
            IF((f3*f1).GT.(0.0D0))THEN
               x1=x3
               f1=fct(x1,L,H)
            ELSE
               x2=x3
            ENDIF
            GOTO 10
 20      x1=(x1+x2)/2.0D0
         bm(i)=x1
C         WRITE(2,*)'bm(',i,')=',bm(i),';'
      ENDDO
C
C     Calcul de la solution analytique (montée)
C     -----------------------------------------
C     WRITE(*,*)'Calcul des pas de temps : h=h'
      DO k=1,NT+1
         WRITE(*,*)'k =',(k-1)*ISAV
         t=(k-1)*dt
         DO j=1,NX+1
            x=(j-1)*dx
            sum=0
            DO i=1,NZ
               sum=sum+1.0D0/(L*(bm(i)**2+H**2)+H)
     #                *cos(bm(i)*x)/cos(bm(i)*L)
     #                *exp(-bm(i)**2*eta*t)
            ENDDO
            ua=Tf-2*Tf*H*sum
            WRITE(2,*)'ua(',j,',',k,')=',ua,';'
         ENDDO
         WRITE(2,*)'t2(',k,')=',t,';'
      ENDDO
C
C     Calcul de la solution analytique (descente)
C     -------------------------------------------
C     WRITE(*,*)'Calcul des pas de temps : h=0'
C
C     -- Calcul de C0 --
      C0=0
      DO i=1,NZ
         C0=C0+1.0D0/(L*(bm(i)**2+H**2)+H)
     #        *exp(-(bm(i))**2*eta*TFIN)/cos(bm(i)*L)
     #        *sin(bm(i)*L)/bm(i)
      ENDDO
      C0=Tf+C0*(-2.0*Tf*H*1.0D0/L)
      WRITE(*,*)' .. C0 = ',C0
C
C     -- Calcul des Cn --
      DO nn=1,NC
         C(nn)=0.0D0
         DO i=1,NZ
            C(nn)=C(nn)+1.0D0/(L*(bm(i)**2+H**2)+H)
     #           *exp(-(bm(i))**2*eta*TFIN)/cos(bm(i)*L)
     #           *(-1.0D0)**(nn+1)*bm(i)*(L/DBLE(nn)/pi)**2
     #           *sin(bm(i)*L)
     #           /(1.0D0-(bm(i)*L/DBLE(nn)/pi)**2)
         ENDDO
         C(nn)=C(nn)*(-4.0D0*Tf*H/L)
      ENDDO
C
C     -- Pas de temps --
      DO k=NT+2,(MUL*NT)
         WRITE(*,*)'k =',(k-1)*ISAV
         t=(k-1)*dt
         DO j=1,NX+1
            x=(j-1)*dx
            ua=C0
            DO nn=1,NC
               ua=ua+C(nn)*cos(nn*pi*x/L)
     #              *exp(-(nn*pi/L)**2
     #              *eta*(t-TFIN))
            ENDDO
            WRITE(2,*)'ua(',j,',',k,')=',ua,';'
         ENDDO
         WRITE(2,*)'t2(',k,')=',t,';'
      ENDDO
C
C     Fermeture du fichier
C     --------------------
      CLOSE(UNIT=2)
C
      RETURN
      END
C
C----------------------------------------------------------
      REAL*8 FUNCTION fct(x,L,H)
      REAL*8 x,L,H
C
      fct=x*DTAN(x*L)-H
      RETURN
      END


    !--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves GrayScott equation in 3 dimensions
	! u_t=D_u*(u_{xx}+u_{yy}+u_{zz})^2-u*v^2-F*(1-u)
	! v_t=D_v*(v_{xx}+v_{yy}+v_{zz})^2+u*v^2-(F+k)*v
	!
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  A				=F
	!  B				=F+k
	! .. Scalars ..
	!  Ahat 			= Fourier transform of A
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  dt				= timestep
	!  modescalereal	= Number to scale after backward FFT
	!  myid				= Process id
	!  ierr				= error code
	!  p_row			= number of rows for domain decomposition
	!  p_col			= number of columns for domain decomposition
	!  filesize			= total filesize
	!  disp				= displacement to start writing data from
	!  ind				= index in array to write
	!  plotnum			= number of plot to save
	!  numberfile		= number of the file to be saved to disk
	!  stat				= error indicator when reading inputfile
	!  umean			= temporary for fix point iteration
	!  vmean			= temporary for fix point iteration
	! .. Arrays ..
	!  u 				= approximate solution u
	!  v				= approximate solution v
	!  uold 				= previous timestep of u
	!  vold				= previous timestep of v
	!  utemp 			= temporary for fix point iteration u
	!  vtemp			= temporary for fix point iteration v
	!  uhat 			= Fourier transform of u
	!  vhat				= Fourier transform of v
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction squared
	!  ky				= fourier frequencies in y direction squared
	!  kz				= fourier frequencies in z direction squared
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!  time				= times at which save data
	!  nameconfig		= array to store filename for data to be saved
	!  InputFileName	= name of the Input File
	!  dpcomm
	!  intcomm
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!  sp				see http://www.2decomp.org/ for more information
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library

	PROGRAM main
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io
	USE MPI
	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4)		::  Nx=0
	INTEGER(kind=4) 	::  Ny=0
	INTEGER(kind=4) 	::  Nz=0
	INTEGER(kind=4)		::  Nt=0
	INTEGER(kind=4)		::  plotgap=0
	REAL(kind=8), PARAMETER	::&
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8)		::  Lx=0.0,Ly=0.0,Lz=0.0
	REAL(kind=8)		::  dt=0.0
	REAL(kind=8)		::  tol=0.1**12
	REAL(kind=8)		::  A=0.0
	REAL(kind=8)		::  Ahat=0
	REAL(kind=8)		::  B=0.0
	REAL(kind=8)		::  Du=0.0
	REAL(kind=8)		::  Dv=0.0
	REAL(kind=8)		::  chg=1.0
	REAL(kind=8), DIMENSION(:), ALLOCATABLE	::  kx,ky,kz
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x,y,z
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE	::  u,v
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE	::  uold,vold
	REAL(kind=8) 		:: utemp,vtemp
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE	::  uhat,vhat
	COMPLEX(kind=8) :: uhatmp
	REAL(kind=8) :: umean,vmean
	REAL(kind=8), 	 DIMENSION(:), ALLOCATABLE	::  time
	INTEGER(KIND=4), DIMENSION(1:5)	::  intcomm
	REAL(KIND=8), DIMENSION(1:8)	::  dpcomm
	REAL(kind=8) :: modescalereal
	INTEGER(kind=4)	::  i,j,k,n,AllocateStatus,stat
	INTEGER(kind=4)	:: myid,numprocs,ierr
	TYPE(DECOMP_INFO)	::  decomp,sp
	INTEGER(kind=MPI_OFFSET_KIND) :: filesize, disp
	INTEGER(kind=4)	::  p_row=0, p_col=0
 	INTEGER(kind=4)	::  start, finish, count_rate, ind, plotnum
	CHARACTER*50	::	nameconfig
	CHARACTER*20	::	numberfile, InputFileName
	    ! initialisation of MPI
	CALL MPI_INIT(ierr)
	CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
	CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)

	CALL MPI_BCAST(stat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

	IF(myid.eq.0) THEN
		InputFileName='INPUTFILE'
		OPEN(unit=11,FILE=trim(InputFileName),status="OLD")
		REWIND(11)
		READ(11,*) intcomm(1), intcomm(2), intcomm(3), intcomm(4),intcomm(5),&
			 		dpcomm(1), dpcomm(2),  dpcomm(3),  dpcomm(4),  dpcomm(5), &
					dpcomm(6), dpcomm(7),  dpcomm(8)
		CLOSE(11)
		PRINT *,"NX ",intcomm(1)
		PRINT *,"NY ",intcomm(2)
		PRINT *,"NZ ",intcomm(3)
		PRINT *,"NT ",intcomm(4)
		PRINT *,"plotgap ",intcomm(5)
		PRINT *,"Lx",dpcomm(1)
		PRINT *,"Ly",dpcomm(2)
		PRINT *,"Lz",dpcomm(3)
		PRINT *,"dt",dpcomm(4)
		PRINT *,"Du",dpcomm(5)
		PRINT *,"Dv",dpcomm(6)
		PRINT *,"F",dpcomm(7)
		PRINT *,"k",dpcomm(8)
		PRINT *,"Read inputfile"
	END IF
	CALL MPI_BCAST(dpcomm,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
	CALL MPI_BCAST(intcomm,5,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

	Nx=intcomm(1)
	Ny=intcomm(2)
	Nz=intcomm(3)
	Nt=intcomm(4)
	plotgap=intcomm(5)
	Lx=dpcomm(1)
	Ly=dpcomm(2)
	Lz=dpcomm(3)
	dt=dpcomm(4)
	Du=dpcomm(5)
	Dv=dpcomm(6)
	A=dpcomm(7)
	B=dpcomm(8)+dpcomm(7)
	! initialisation of 2decomp
	! do automatic domain decomposition
	CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
	! get information about domain decomposition choosen
	CALL get_decomp_info(decomp) ! physical domain
	CALL decomp_info_init(Nx/2+1,Ny,Nz,sp) ! spectral domain
	! initialise FFT library
	CALL decomp_2d_fft_init
	ALLOCATE(u(decomp%xst(1):decomp%xen(1),&
   				decomp%xst(2):decomp%xen(2),&
   				decomp%xst(3):decomp%xen(3)),&
            v(decomp%xst(1):decomp%xen(1),&
            	decomp%xst(2):decomp%xen(2),&
            	decomp%xst(3):decomp%xen(3)),&
			uold(decomp%xst(1):decomp%xen(1),&
   				decomp%xst(2):decomp%xen(2),&
   				decomp%xst(3):decomp%xen(3)),&
            vold(decomp%xst(1):decomp%xen(1),&
            	decomp%xst(2):decomp%xen(2),&
            	decomp%xst(3):decomp%xen(3)),&
			uhat(sp%zst(1):sp%zen(1),&
   				sp%zst(2):sp%zen(2),&
   				sp%zst(3):sp%zen(3)),&
            vhat(sp%zst(1):sp%zen(1),&
            	sp%zst(2):sp%zen(2),&
            	sp%zst(3):sp%zen(3)),&
		kx(sp%zst(1):sp%zen(1)), &
		ky(sp%zst(2):sp%zen(2)), &
		kz(sp%zst(3):sp%zen(3)), &
		x(decomp%xst(1):decomp%xen(1)),&
		y(decomp%xst(2):decomp%xen(2)),&
		z(decomp%xst(3):decomp%xen(3)),&
   		time(1:1+Nt/plotgap),&
		stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP

	IF (myid.eq.0) THEN
		PRINT *,'allocated space'
	END IF
	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))

	! setup fourier frequencies and grid points
DO i = 1,1+ Nx/2
		IF ((i.GE.sp%zst(1)).AND.(i.LE.sp%zen(1))) THEN
			kx(i)=-(REAL(i-1,kind(0d0))/Lx)**2
		END IF
	END DO
	IF ((Nx/2 + 1 .GE.sp%zst(1)).AND.(Nx/2 + 1 .LE.sp%zen(1))) THEN
		kx( Nx/2 + 1 ) = 0.0d0
	END IF
	DO i = Nx/2+2, Nx
		IF ((i.GE.sp%zst(1)).AND.(i.LE.sp%zen(1))) THEN
			Kx( i) = -(REAL(1-i+Nx,KIND(0d0))/Lx)**2
		END IF
	END DO
	DO i=decomp%xst(1),decomp%xen(1)
		x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	END DO

	DO j = 1,1+ Ny/2
		IF ((j.GE.sp%zst(2)).AND.(j.LE.sp%zen(2))) THEN
			ky(j)= -(REAL(j-1,kind(0d0))/Ly)**2
		END IF
	END DO
	IF ((Ny/2 + 1 .GE.sp%zst(2)).AND.(Ny/2 + 1 .LE.sp%zen(2))) THEN
		ky( Ny/2 + 1 ) = 0.0d0
	ENDIF
	DO j = Ny/2+2, Ny
		IF ((j.GE.sp%zst(2)).AND.(j.LE.sp%zen(2))) THEN
			ky(j) = -(REAL(1-j+Ny,KIND(0d0))/Ly)**2
		END IF
	END DO
	DO j=decomp%xst(2),decomp%xen(2)
		y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
	END DO

	DO k = 1,1+ Nz/2
		IF ((k.GE.sp%zst(3)).AND.(k.LE.sp%zen(3))) THEN
			kz(k)= -(REAL(k-1,kind(0d0))/Lz)**2
		END IF
	END DO
	IF ((Nz/2 + 1 .GE.sp%zst(3)).AND.(Nz/2 + 1 .LE.sp%zen(3))) THEN
		kz( Nz/2 + 1 ) = 0.0d0
	ENDIF
	DO k = Nz/2+2, Nz
		IF ((k.GE.sp%zst(3)).AND.(k.LE.sp%zen(3))) THEN
			kz(k) = -(REAL(1-k+Nz,KIND(0d0))/Lz)**2
		END IF
	END DO
	DO k=decomp%xst(3),decomp%xen(3)
		z(k)=(-1.0d0 + 2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)))*pi*Lz
	END DO

	IF (myid.eq.0) THEN
		PRINT *,'Setup grid and fourier frequencies'
	END IF
	!compute Ahat
	Ahat=A*Nx*Ny*Nz
	!initial condition
	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)

	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				u(i,j,k)=1+(exp(-1*(x(i)**2+y(j)**2+z(k)**2)-1))
				v(i,j,k)=0+(exp(-1*(x(i)**2+y(j)**2+z(k)**2)-1))
			END DO
		END DO
	END DO
	! write out using 2DECOMP&FFT MPI-IO routines
	nameconfig='./data/u'
	plotnum=0
	WRITE(numberfile,'(i0)') 10000000+plotnum
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//numberfile
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'.datbin'
	CALL decomp_2d_write_one(1,u,nameconfig)
	!same for v
	nameconfig='./data/v'
	plotnum=0
	WRITE(numberfile,'(i0)') 10000000+plotnum
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//numberfile
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'.datbin'
	CALL decomp_2d_write_one(1,v,nameconfig)

	IF (myid.eq.0) THEN
		PRINT *,'Got initial data, starting timestepping'
	END IF
	CALL system_clock(start,count_rate)
	time(1)=0
	DO n=1,Nt
	!use fixed point iteration to solve nonlinear system in real space
		DO k=decomp%xst(3),decomp%xen(3)
			DO j=decomp%xst(2),decomp%xen(2)
				DO i=decomp%xst(1),decomp%xen(1)
					uold(i,j,k)=u(i,j,k)
					vold(i,j,k)=v(i,j,k)
				END DO
			END DO
		END DO
		DO k=decomp%xst(3),decomp%xen(3)
			DO j=decomp%xst(2),decomp%xen(2)
				DO i=decomp%xst(1),decomp%xen(1)
					chg=1
					DO WHILE (chg>tol)
						utemp=u(i,j,k)
						vtemp=v(i,j,k)
						umean=0.5*(u(i,j,k)+uold(i,j,k))
						vmean=0.5*(v(i,j,k)+vold(i,j,k))
						u(i,j,k)=uold(i,j,k)+0.5*dt*(-umean*vmean**2)
						v(i,j,k)=vold(i,j,k)+0.5*dt*(umean*vmean**2)
						utemp=u(i,j,k)-utemp
						vtemp=v(i,j,k)-vtemp
						chg=abs(utemp)+abs(vtemp)
				END DO
			END DO
		END DO
	END DO
! solve linear part exactly in Fourier space
		CALL decomp_2d_fft_3d(u,uhat)
		CALL decomp_2d_fft_3d(v,vhat)
		IF (myid.eq.0) THEN
			uhatmp=uhat(1,1,1)
		END IF
		DO k=sp%zst(3),sp%zen(3)
			DO j=sp%zst(2),sp%zen(2)
				DO i=sp%zst(1),sp%zen(1)
					uhat(i,j,k)=exp(dt*(-A+Du*(kx(i)+ky(j)+kz(k))))*&
								uhat(i,j,k)
					vhat(i,j,k)=exp(dt*(-B+Dv*(kx(i)+ky(j)+kz(k))))*&
								vhat(i,j,k)
				END DO
			END DO
		END DO
		IF (myid.eq.0) THEN
			uhat(1,1,1)=exp(dt*(-A+Du*(kx(1)+ky(1)+kz(1))))*&
						(uhatmp-Ahat/(A+Du*(kx(1)+ky(1)+kz(1))))+&
						(Ahat/(A+Du*(kx(1)+ky(1)+kz(1))))
		END IF
		!dont forget to scale
		CALL decomp_2d_fft_3d(uhat,u)
		CALL decomp_2d_fft_3d(vhat,v)
		DO k=decomp%xst(3),decomp%xen(3)
			DO j=decomp%xst(2),decomp%xen(2)
				DO i=decomp%xst(1),decomp%xen(1)
					u(i,j,k)=u(i,j,k)*modescalereal
					v(i,j,k)=v(i,j,k)*modescalereal
				END DO
			END DO
		END DO
		!use fixed point iteration to solve nonlinear system in real space
		DO k=decomp%xst(3),decomp%xen(3)
			DO j=decomp%xst(2),decomp%xen(2)
				DO i=decomp%xst(1),decomp%xen(1)
					uold(i,j,k)=u(i,j,k)
					vold(i,j,k)=v(i,j,k)
				END DO
			END DO
		END DO
		DO k=decomp%xst(3),decomp%xen(3)
			DO j=decomp%xst(2),decomp%xen(2)
				DO i=decomp%xst(1),decomp%xen(1)
					chg=1
					DO WHILE (chg>tol)
						utemp=u(i,j,k)
						vtemp=v(i,j,k)
						umean=0.5*(u(i,j,k)+uold(i,j,k))
						vmean=0.5*(v(i,j,k)+vold(i,j,k))
						u(i,j,k)=uold(i,j,k)+0.5*dt*(-umean*vmean**2)
						v(i,j,k)=vold(i,j,k)+0.5*dt*(umean*vmean**2)
						utemp=u(i,j,k)-utemp
						vtemp=v(i,j,k)-vtemp
						chg=abs(utemp)+abs(vtemp)
					END DO
				END DO
			END DO
		END DO
!write data
		IF (mod(n,plotgap)==0) THEN
			time(1+n/plotgap)=n*dt
			IF (myid.eq.0) THEN
				PRINT *,'time',n*dt
			END IF
			nameconfig='./data/u'
			plotnum=plotnum+1
			WRITE(numberfile,'(i0)') 10000000+plotnum
			ind=index(nameconfig,' ') -1
			nameconfig=nameconfig(1:ind)//numberfile
			ind=index(nameconfig,' ') -1
			nameconfig=nameconfig(1:ind)//'.datbin'
			!write out using 2DECOMP&FFT MPI-IO routines
			CALL decomp_2d_write_one(1,u,nameconfig)
			nameconfig='./data/v'
			WRITE(numberfile,'(i0)') 10000000+plotnum
			ind=index(nameconfig,' ') -1
			nameconfig=nameconfig(1:ind)//numberfile
			ind=index(nameconfig,' ') -1
			nameconfig=nameconfig(1:ind)//'.datbin'
			!write out using 2DECOMP&FFT MPI-IO routines
			CALL decomp_2d_write_one(1,v,nameconfig)
		END IF
	END DO
	IF (myid.eq.0) THEN
		PRINT *,'Finished time stepping'
	END IF

	CALL system_clock(finish,count_rate)

	IF (myid.eq.0) THEN
		PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),'for execution'
	END IF

	IF (myid.eq.0) THEN
		! Save times at which output was made in text format
		nameconfig = './data/tdata.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO j=1,1+Nt/plotgap
			WRITE(11,*) time(j)
		END DO
		CLOSE(11)
		! Save x grid points in text format
		nameconfig = './data/xcoord.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO i=1,Nx
			WRITE(11,*) x(i)
		END DO
		CLOSE(11)
		! Save y grid points in text format
		nameconfig = './data/ycoord.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO j=1,Ny
			WRITE(11,*) y(j)
		END DO
		CLOSE(11)
		! Save z grid points in text format
		nameconfig = './data/zcoord.dat'
		OPEN(unit=11,FILE=nameconfig,status="UNKNOWN")
		REWIND(11)
		DO k=1,Nz
			WRITE(11,*) z(k)
		END DO
		CLOSE(11)
		PRINT *,'Saved data'
	END IF

	! clean up
  	CALL decomp_2d_fft_finalize
  	CALL decomp_2d_finalize
 	DEALLOCATE(u,v,uold,vold,uhat,vhat,&
   		kx,ky,kz,x,y,z,&
   		time,stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	IF (myid.eq.0) THEN
	   	PRINT *,'Program execution complete'
	END IF
	CALL MPI_FINALIZE(ierr)
	END PROGRAM main


module eigen_module
    !use initialize_pop !, only: assign_par_vectors, assign_transition_matrix   ! For re-assigning values during search for s_juv
    use Declare_variables_module
    implicit none
    contains
!====== +++ === === +++ === === +++ ===
!   * subroutine eigen() *
! Wrapper for calling LAPACK procedure DGEEV, which calculates the eigenvalues and left and right eigenvectors of a
!  non-symmetric square matrix
!
!   * print_eigenvalues() *
! Formatted printing of vector of eigenvalues returned from eigen()
!
!   * print_eigenvectors() *
! Formatted printing of eigenvectors returned from eigen()
!
!   * subroutine extract_lambda() *
! Extract the dominant (largest absolute value) real (not complex) eigenvalue from a vector of eigenvalues
!====== +++ === === +++ === === +++ ===

    ! *
!###### +++ ### ### +++ ### ### +++ ###
!====== +++ === === +++ === === +++ ===
    real (kind=8) function extract_lambda(wr, wi, n)
!====== +++ === === +++ === === +++ ===
! Extract the dominant (largest absolute value) real (not complex) eigenvalue from a vector of eigenvalues
!====== +++ === === +++ === === +++ ===
        integer(kind = 4), intent(in) :: n         ! Length of vector of eigenvalues
        integer(kind = 4) :: j         ! Counter
        integer(kind = 4) :: j_keep    ! Keep track of index with dominant real eigenvalue
        real(kind = 8) :: lambda       ! Dominant real eigenvalue
        real(kind = 8) :: wr(n), wi(n) ! The real and imaginary components of the vector of eigenvalues

        j_keep = 0  ! Initialize
        lambda = 0.

!        print *, "Hello from extract_lambda()" ! DEBUGGING

        do j = 1, n
         if( wi( j ) == 0.0 ) THEN   ! Is the imaginary part of complex number greater than zero? If not, this is a real root.

!            print *, "Real root at index: ", j

            if (ABS(wr(j)) > ABS(lambda))  then
!                print *, "Previous lambda: ", lambda
!                print *, "Proposed lambda wr(j): ", wr(j)
                lambda = wr(j)
!                print *, "New lambda: ", lambda
            end if
         end if
        end do

        extract_lambda = lambda
        return
    end function extract_lambda

!###### +++ ### ### +++ ### ### +++ ###
!====== +++ === === +++ === === +++ ===
    subroutine eigen(A, N, lambda)
!====== +++ === === +++ === === +++ ===
! Wrapper for calling LAPACK procedure DGEEV, which calculates the eigenvalues and left and right eigenvectors of a
!  non-symetric square matrix
! Notes:
!  DGEEV changes the contents of the matrix A on return.
!====== +++ === === +++ === === +++ ===
        integer(kind = 4), intent(in) :: N
        integer(kind = 4) :: ii, jj         ! Counters
        integer(kind = 4) :: LDA, LDVL, LDVR
        integer(kind = 4), parameter :: LWMAX = 1000
        integer(kind = 4) :: INFO, LWORK

        real(kind = 8), intent(in) :: A( 1:N, 1:N ) ! Square, but not necessarily symmetric matrix
        real(kind = 8) :: VL( 1:N, 1:N )            ! Matrix with left eigenvectors
        real(kind = 8) :: VR( 1:N, 1:N )            ! Matrix with right eigenvectors
        real(kind = 8) :: WR( 1:N )                 ! Vector with real part of eigenvalue
        real(kind = 8) :: WI( 1:N )                 ! Vector with complex part of eigenvalue
        real(kind = 8) :: WORK( LWMAX )
        real (kind = 8), intent(out) :: lambda      ! Dominant real eigenvalue

!        EXTERNAL         DGEEV
!        EXTERNAL         PRINT_EIGENVALUES, PRINT_EIGENVECTORS

!*
!*     .. Intrinsic Functions ..
!        INTRINSIC        INT, MIN
!*
!*     .. Executable Statements ..
!        print *, "Hello from testing DGEEV: "
!        print *, "Transition Matrix: "             ! DEBUGGING
!        do ii = 1, N
!            write (*,"(100f8.3)") (A(ii, jj), jj = 1, N)    ! The 100f... is a bit of a hack. Works if <= 100 columns to be printed
!        end do

!        WRITE(*,*)'DGEEV Example Program Results'
!*
!*     Query the optimal workspace.
!*
        LWORK = -1      ! This tells procedure that a workspace query is assumed; the procedure only calculates optimal size of WORK array
        LDVL = N
        LDVR = N
        LDA = N
        !
        CALL DGEEV( 'Vectors', 'Vectors', N, A, LDA, WR, WI, VL, LDVL, &
                   VR, LDVR, WORK, LWORK, INFO )
        LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )  ! Set this for next call to DGEEV, which will return eigenvalues / vectors

!        write(*,*) "LWMAX: ", LWMAX                    ! DEBUGGING
!        write(*,*) "INT( WORK(1) ): ", INT( WORK(1) )
!        write(*,*) "LWORK: ", LWORK
!*
!*     Solve eigenproblem.
!*      Note that matrix A will have been overwritten on return
        CALL DGEEV( 'Vectors', 'Vectors', N, A, LDA, WR, WI, VL, LDVL, &
                 VR, LDVR, WORK, LWORK, INFO )
!*
!*     Check for convergence.
!*
        IF( INFO.GT.0 ) THEN
           WRITE(*,*)'The DGEEV algorithm failed to compute eigenvalues.'
           STOP
        END IF

!     Extract dominant real eigenvalue
        lambda = extract_lambda( WR, WI, N )
!
!     Print eigenvalues.
!
!        CALL print_eigenvalues( 'Eigenvalues', N, WR, WI )
!
!     Print left eigenvectors.
!
!        CALL PRINT_EIGENVECTORS( 'Left eigenvectors', N, WI, VL )
!!
!!     Print right eigenvectors.
!!
!        CALL PRINT_EIGENVECTORS( 'Right eigenvectors', N, WI, VR )

        return
      END subroutine eigen
!
!     End of DGEEV Example.
!
!  =============================================================================
!
!     Auxiliary routine: printing eigenvalues.
!
    subroutine print_eigenvalues( DESC, N, WR, WI )
        character*(*), intent(in) :: DESC
        integer(kind = 4), intent(in) :: N
        real(kind = 8), intent(in) :: WR( 1:N )
        real(kind = 8), intent(in) :: WI( 1:N )
        real(kind = 8), parameter :: zero = 0.0d0
        integer(kind = 4) :: jj
!
        WRITE(*,*)
        WRITE(*,*) DESC
        DO jj = 1, N
           IF( WI( jj ) .EQ. ZERO ) THEN   ! Is the imaginary part of complex number greater than zero? If not, is a real root.
              WRITE(*,9998,ADVANCE='NO') WR( jj )
           ELSE
              WRITE(*,9999,ADVANCE='NO') WR( jj ), WI( jj )
           END IF
        END DO
        WRITE(*,*)

9998    FORMAT( 11(:,1X,F6.2) )
9999    FORMAT( 11(:,1X,'(',F6.2,',',F6.2,')') )

        RETURN
    END subroutine print_eigenvalues
!*
!*     Auxiliary routine: printing eigenvectors.
!*
    SUBROUTINE PRINT_EIGENVECTORS( DESC, N, WI, V )
        character*(*), intent(in) :: DESC
        integer(kind = 4), intent(in) :: N
        real(kind = 8), intent(in) :: WI( 1:N ), V( 1:N, 1:N )
        real(kind = 8), parameter :: ZERO = 0.0d0
        INTEGER          I, J
!*
      WRITE(*,*)
      WRITE(*,*) DESC
      DO I = 1, N
         J = 1
         DO WHILE( J.LE.N )
            IF( WI( J ).EQ.ZERO ) THEN
               WRITE(*,9998,ADVANCE='NO') V( I, J )
               J = J + 1
            ELSE
               WRITE(*,9999,ADVANCE='NO') V( I, J ), V( I, J+1 )
               WRITE(*,9999,ADVANCE='NO') V( I, J ), -V( I, J+1 )
               J = J + 2
            END IF
         END DO
         WRITE(*,*)
      END DO
!*
 9998 FORMAT( 11(:,1X,F6.2) )
 9999 FORMAT( 11(:,1X,'(',F6.2,',',F6.2,')') )
      RETURN
      END subroutine PRINT_EIGENVECTORS

      end module eigen_module


subroutine tdma(a, b, N)
use kind_parameters
implicit none

integer*4:: i, N
real(kind=dp), dimension(N,3):: a
real(kind=dp), intent(inout), dimension(N):: b

a(1,3) = -a(1,3)/a(1,2)
b(1) = b(1)/a(1,2)

do i = 2,N

    a(i,3) = -a(i,3)/(a(i,2) + a(i,1)*a(i-1,3))
    b(i) = (b(i) - a(i,1)*b(i-1))/(a(i,2) + a(i,1)*a(i-1,3))

end do

do i = N-1,1,-1

    b(i) = a(i,3)*b(i+1) + b(i)

end do

end subroutine


: vector:  ( x y - <name> )  create swap , , ;
2 cells constant /vector
: 2.  swap . . ;
: 2?  swap ? ? ;
: x@  @ ;
: y@  cell+ @ ;
: x!  ! ;
: y!  cell+ ! ;
: x+!  +! ;
: y+!  cell+ +! ;
: vclamp  ( lowx lowy highx highy vec - )  >r  2@ 2min 2max r> 2! ;
: 0v  0 0 rot 2! ;
: 1v  1 1 rot 2! ;
: 2rnd  ( x y - x y )  rnd swap rnd swap ;
: uvec  ( deg - x y )   >r  r@ cos  r> sin ;  \ get unit vector from angle
: vec  ( deg len - x y )  >r  uvec  r> dup 2* ;
: angle  ( x y - deg ) 1pf 1pf fatan2 r>d f>p  360 + 360 mod ;
: hypot  ( x y - n )  2pf fdup f* fswap fdup f* f+ fsqrt f>p ;
: 2rotate  ( x y deg - x y )
    swap  >rad dup cos  swap sin  locals| sin(ang) cos(ang) y x |
    x cos(ang) * y sin(ang) * -
    x sin(ang) * y cos(ang) * + ;
: vscale  ( x y vec - )
   >r  2@ 2*  r> 2! ;
: vlerp  ( vec1 vec2 n - x y )
    locals| n v2 v1 |
    v1 x@ v2 x@ n lerp  v1 y@ v2 y@ n lerp ;


      SUBROUTINE DGESL(A, LDA, N, IPVT, B, JOB)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ddot_I
      USE daxpy_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: LDA
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: JOB
      INTEGER , INTENT(IN) :: IPVT(1)
      REAL(DOUBLE)  :: A(LDA,1)
      REAL(DOUBLE)  :: B(1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K, KB, L, NM1
      REAL(DOUBLE) :: T
!-----------------------------------------------
!
!     DGESL SOLVES THE DOUBLE PRECISION SYSTEM
!     A * X = B  OR  TRANS(A) * X = B
!     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
!
!     ON ENTRY
!
!        A       DOUBLE PRECISION(LDA, N)
!                THE OUTPUT FROM DGECO OR DGEFA.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  A .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        IPVT    INTEGER(N)
!                THE PIVOT VECTOR FROM DGECO OR DGEFA.
!
!        B       DOUBLE PRECISION(N)
!                THE RIGHT HAND SIDE VECTOR.
!
!        JOB     INTEGER
!                = 0         TO SOLVE  A*X = B ,
!                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
!                            TRANS(A)  IS THE TRANSPOSE.
!
!     ON RETURN
!
!        B       THE SOLUTION VECTOR  X .
!
!     ERROR CONDITION
!
!        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
!        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
!        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
!        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
!        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
!        OR DGEFA HAS SET INFO .EQ. 0 .
!
!     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
!     WITH  P  COLUMNS
!           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
!           IF (RCOND IS TOO SMALL) GO TO ...
!           DO 10 J = 1, P
!              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
!        10 CONTINUE
!
!     LINPACK. THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS DAXPY,DDOT
!
!     INTERNAL VARIABLES
!
!
      NM1 = N - 1
      IF (JOB == 0) THEN
!
!        JOB = 0 , SOLVE  A * X = B
!        FIRST SOLVE  L*Y = B
!
         IF (NM1 >= 1) THEN
            DO K = 1, NM1
               L = IPVT(K)
               T = B(L)
               IF (L /= K) THEN
                  B(L) = B(K)
                  B(K) = T
               ENDIF
               CALL DAXPY (N - K, T, A(K+1,K), 1, B(K+1), 1)
            END DO
         ENDIF
         DO KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY (K - 1, T, A(1,K), 1, B(1), 1)
         END DO
      ELSE
         DO K = 1, N
            T = DDOT(K - 1,A(1,K),1,B(1),1)
            B(K) = (B(K)-T)/A(K,K)
         END DO
!
!        NOW SOLVE TRANS(L)*X = Y
!
         IF (NM1 >= 1) THEN
            DO KB = 1, NM1
               K = N - KB
               B(K) = B(K) + DDOT(N - K,A(K+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L == K) CYCLE
               T = B(L)
               B(L) = B(K)
               B(K) = T
            END DO
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE DGESL


Real h;
h = MAX(10, plantHeight) / 100
conductance = (wind *(vonKarman**2)) / (LOG((heightWeatherMeasurements - d * h) / (zm * h)) * LOG((heightWeatherMeasurements - d * h) / (zh * h)))


SUBROUTINE setup_accrete
! Calculates sigma dot expected from mass infall rate
! (This version assumes a Gaussian distribution for sigma dot)

  use gravdata
  use unitdata, only: pi,yr,solarmass,AU
  use winddata

  implicit none

  integer :: i,in,out

  real :: inner,outer, term, integral
  real :: mean, sd

  allocate(sigdot_accrete(nmax))

sigdot_accrete(:) = 0.0

  ! Calculate discrete integral from adding together Gaussian over 3 * sd

  mean = 30.0*AU
  sd = 1.0*AU

  inner = mean - 3.0*sd
  outer = mean + 3.0*sd

  ! Find inner annulus

  i=1
  DO WHILE(rf(i) < inner)
     !print*, i,rf(i),inner
     i=i+1
  ENDDO

  in = i

  ! Now calculate integral
  DO WHILE(rf(i) < outer.and. i < ier-1)

     term= exp(-(rf(i)-mean)**2/(2.0*sd*sd))/sqrt(2.0*pi*sd*sd)
     integral = term*2.0*pi*rf(i)*(rf(i+1)-rf(i))
     i=i+1
  ENDDO
  out = i

!  print*, 'Integral is ', integral

! Now add integral to sigmadot

  DO i=in,out
     term =  exp(-(rf(i)-mean)**2/(2.0*sd*sd))/sqrt(2.0*pi*sd*sd)
     sigdot_accrete(i) = sigdot_accrete(i)+mdot_init*term/integral
  ENDDO

return
end subroutine setup_accrete