c ----------------------------------------------------------------------
c
c GC Larsen wake model applied to offshore wind farms (WindFarm object)
c by Juan P. Murcia <jumu@dtu.dk>
c
c ----------------------------------------------------------------------

c ----------------------------------------------------------------------
c get_R96(D,CT,TI)
c ----------------------------------------------------------------------
c Computes the wake radius at 9.6D downstream location of a turbine
c
c
c Inputs
c ----------
c D (float): Wind turbine diameter
c CT (float): Outputs WindTurbine object's thrust coefficient
c TI (float): Ambient turbulence intensity
c
c
c Outputs
c ----------
c R96 (float): Wake radius at 9.6D downstream location
c
      subroutine get_R96(D,CT,TI,a1,a2,a3,a4,b1,b2,R96)

      implicit none
      real(kind=8) D,CT,TI,a1,a2,a3,a4,b1,b2,R96
cf2py real(kind=8) intent(in) :: D, CT, TI
cf2py real(kind=8) optional,intent(in) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in) :: b1=15.6298
cf2py real(kind=8) optional,intent(in) :: b2=1.0
cf2py real(kind=8) intent(out) :: R96

      R96=a1*(EXP(a2*CT*CT+a3*CT+a4))*(b1*TI+b2)*D
      end subroutine get_R96

c ----------------------------------------------------------------------
c get_RW(x,D,CT,TI)
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 TI (float): Ambient turbulence intensity
c CT (float): Outputs WindTurbine object's thrust coefficient
c
c Outputs
c ----------
c Rw (float): Wake radius at a location
c xT_st (float): Distance from rotor disc to origin of wake expansion
c                (wake becomes zero)
c c1(float): Integration constant
      subroutine get_RW(n,x,D,CT,TI,a1,a2,a3,a4,b1,b2,RW,xT_st,c1)

      implicit none
      integer :: n
      real(kind=8) :: x(n),D,CT,TI,a1,a2,a3,a4,b1,b2
      real(kind=8) :: RW(n),xT_st,c1
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,TI
cf2py real(kind=8) optional,intent(in) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in) :: b1=15.6298
cf2py real(kind=8) optional,intent(in) :: b2=1.0
cf2py real(kind=8) intent(out), depend(n),dimension(n) :: RW
cf2py real(kind=8) intent(out) :: xT_st, c1
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i
      real(kind=8) :: Area,a,k,R96,tm1,tm2,tm3,tm4,tm5

      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))
      call get_R96(D,CT,TI,a1,a2,a3,a4,b1,b2,R96)
      ! Distance from rotor disc to origin of wake expansion, where the
      ! wake becomes zero; assuming wake expansion RW ~ (x+xT_st)**(1/3)
      xT_st=(9.6d0*D)/(((2.0d0*R96/(k*D))**3.0d0)-1.0d0)
      do i = 1, n
        if ((x(i)+xT_st) <= 0) then
          ! Null wake radius for locations in front of the rotor disc
          RW(i) = 0.0d0
        else
          ! Integration constant from first order asymptotic solution of
          ! axis-symmetrical momentum balance in the wake
          tm1=(k*D/2.0d0)**(2.5d0)
          tm2=(105.0d0/(2.0d0*pi))**(-0.5d0)
          tm3=(CT*Area*xT_st)**(-5.0d0/6.0d0)
          c1=tm1*tm2*tm3

          tm4=(105.0d0*c1*c1/(2.0d0*pi))**(0.2d0)
          tm5=(CT*Area*(x(i)+xT_st))**(1.0d0/3.0d0)
          RW(i)=tm4*tm5
        end if
      end do
      end subroutine get_RW

c ----------------------------------------------------------------------
c get_dU(x,r,D,CT,TI)
c ----------------------------------------------------------------------
c Computes the wake velocity deficit at a location
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 TI (float): Ambient turbulence intensity [-]
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,TI,a1,a2,a3,a4,b1,b2,dU)

      implicit none
      integer :: n
      real(kind=8) :: x(n),r(n),D,CT,TI,a1,a2,a3,a4,b1,b2,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,TI
cf2py real(kind=8) optional,intent(in) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in) :: b1=15.6298
cf2py real(kind=8) optional,intent(in) :: b2=1.0
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: dU
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i
      real(kind=8) :: Area
      real(kind=8) :: tm10,tm20,tm30,tm31,tm32,tm40,tm41,tm42,xT_st,c1
      real(kind=8), dimension(n) :: RW

      Area=pi*D*D/4.0d0

      call get_RW(n,x,D,CT,TI,a1,a2,a3,a4,b1,b2,RW,xT_st,c1)

      do i = 1, n
        if ((x(i) <= 0).or.(r(i) >= RW(i))) then
          ! Null deficit for locations in front of the rotor disc
          ! and outside the wake radius
          dU(i) = 0.0d0
        else
          tm10=1.0d0/9.0d0
          tm20=(CT*Area*(x(i)+xT_st)**(-2.0d0))**(1.0d0/3.0d0)
          tm31=(r(i)**(1.5d0))
          tm32=(3.0d0*c1*c1*CT*Area*(x(i)+xT_st))**(-0.5d0)
          tm30=tm31*tm32
          tm41=(35.0d0/(2.0d0*pi))**(3.0d0/10.0d0)
          tm42=(3.0d0*c1*c1)**(-0.2d0)
          tm40=tm41*tm42
          dU(i)=-tm10*tm20*(tm30-tm40)**(2.0d0)
        end if
      end do
      end subroutine get_dU

c ----------------------------------------------------------------------
c get_dUeq(x,y,z,DT,D,CT,TI)
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 TI (float): Ambient turbulence intensity [-]
c CT (float): Outputs WindTurbine object's thrust coefficient
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,TI,a1,a2,a3,a4,b1,b2,dUeq)

      implicit none
      integer :: n
      real(kind=8) :: x(n),y(n),z(n),DT(n),D,CT,TI
      real(kind=8) :: a1,a2,a3,a4,b1,b2,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,TI
cf2py real(kind=8) optional,intent(in) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in) :: b1=15.6298
cf2py real(kind=8) optional,intent(in) :: b2=1.0
cf2py real(kind=8) intent(out),depend(n),dimension(n) :: dUeq
      ! internal variables
      real(kind=8), parameter :: pi=3.1415926535897932384626433832795d0
      integer :: i,j
      real(kind=8), dimension(40) :: r_node,th_node,weight
      real(kind=8), dimension(1) :: x_e,y_e,z_e,r_e,dU
      real(kind=8), dimension(n) :: RT

      RT = DT/2.0d0
      ! 2D Gauss quadrature nodes and weights for polar integration
      ! int_(0,R) int_(0,2pi) f(r,theta) r dtheta dr =
      ! sum weight f(r_node, theta_node)
      r_node(1) = 0.26349922998554242692
      th_node(1) = 4.79436403870179805864
      weight(1) = 0.00579798753740115753

      r_node(2) = 0.26349922998554242692
      th_node(2) = 5.13630491629471475079
      weight(2) = 0.01299684397858970851

      r_node(3) = 0.26349922998554242692
      th_node(3) = 5.71955352542765460555
      weight(3) = 0.01905256317618122044

      r_node(4) = 0.26349922998554242692
      th_node(4) = 0.20924454049880022999
      weight(4) = 0.02341643323656225281

      r_node(5) = 0.26349922998554242692
      th_node(5) = 1.10309379714216659885
      weight(5) = 0.02569988335562909190

      r_node(6) = 0.26349922998554242692
      th_node(6) = 2.03849885644762496284
      weight(6) = 0.02569988335562912660

      r_node(7) = 0.26349922998554242692
      th_node(7) = 2.93234811309099407950
      weight(7) = 0.02341643323656214179

      r_node(8) = 0.26349922998554242692
      th_node(8) = 3.70522443534172518653
      weight(8) = 0.01905256317618119616

      r_node(9) = 0.26349922998554242692
      th_node(9) = 4.28847304447466459720
      weight(9) = 0.01299684397858971198

      r_node(10) = 0.26349922998554242692
      th_node(10) = 4.63041392206758217753
      weight(10) = 0.00579798753740114539

      r_node(11) = 0.57446451431535072718
      th_node(11) = 4.79436403870179805864
      weight(11) = 0.01086984853977092380

      r_node(12) = 0.57446451431535072718
      th_node(12) = 5.13630491629471475079
      weight(12) = 0.02436599330905551281

      r_node(13) = 0.57446451431535072718
      th_node(13) = 5.71955352542765460555
      weight(13) = 0.03571902745281423097

      r_node(14) = 0.57446451431535072718
      th_node(14) = 0.20924454049880022999
      weight(14) = 0.04390024659093685194

      r_node(15) = 0.57446451431535072718
      th_node(15) = 1.10309379714216659885
      weight(15) = 0.04818117282305908744

      r_node(16) = 0.57446451431535072718
      th_node(16) = 2.03849885644762496284
      weight(16) = 0.04818117282305915683

      r_node(17) = 0.57446451431535072718
      th_node(17) = 2.93234811309099407950
      weight(17) = 0.04390024659093664378

      r_node(18) = 0.57446451431535072718
      th_node(18) = 3.70522443534172518653
      weight(18) = 0.03571902745281418240

      r_node(19) = 0.57446451431535072718
      th_node(19) = 4.28847304447466459720
      weight(19) = 0.02436599330905552321

      r_node(20) = 0.57446451431535072718
      th_node(20) = 4.63041392206758217753
      weight(20) = 0.01086984853977089951

      r_node(21) = 0.81852948743000586429
      th_node(21) = 4.79436403870179805864
      weight(21) = 0.01086984853977090992

      r_node(22) = 0.81852948743000586429
      th_node(22) = 5.13630491629471475079
      weight(22) = 0.02436599330905548505

      r_node(23) = 0.81852948743000586429
      th_node(23) = 5.71955352542765460555
      weight(23) = 0.03571902745281418934

      r_node(24) = 0.81852948743000586429
      th_node(24) = 0.20924454049880022999
      weight(24) = 0.04390024659093679643

      r_node(25) = 0.81852948743000586429
      th_node(25) = 1.10309379714216659885
      weight(25) = 0.04818117282305903193

      r_node(26) = 0.81852948743000586429
      th_node(26) = 2.03849885644762496284
      weight(26) = 0.04818117282305909438

      r_node(27) = 0.81852948743000586429
      th_node(27) = 2.93234811309099407950
      weight(27) = 0.04390024659093658826

      r_node(28) = 0.81852948743000586429
      th_node(28) = 3.70522443534172518653
      weight(28) = 0.03571902745281413383

      r_node(29) = 0.81852948743000586429
      th_node(29) = 4.28847304447466459720
      weight(29) = 0.02436599330905549199

      r_node(30) = 0.81852948743000586429
      th_node(30) = 4.63041392206758217753
      weight(30) = 0.01086984853977088737

      r_node(31) = 0.96465960618086743494
      th_node(31) = 4.79436403870179805864
      weight(31) = 0.00579798753740116100

      r_node(32) = 0.96465960618086743494
      th_node(32) = 5.13630491629471475079
      weight(32) = 0.01299684397858971545

      r_node(33) = 0.96465960618086743494
      th_node(33) = 5.71955352542765460555
      weight(33) = 0.01905256317618123432

      r_node(34) = 0.96465960618086743494
      th_node(34) = 0.20924454049880022999
      weight(34) = 0.02341643323656226669

      r_node(35) = 0.96465960618086743494
      th_node(35) = 1.10309379714216659885
      weight(35) = 0.02569988335562910925

      r_node(36) = 0.96465960618086743494
      th_node(36) = 2.03849885644762496284
      weight(36) = 0.02569988335562914394

      r_node(37) = 0.96465960618086743494
      th_node(37) = 2.93234811309099407950
      weight(37) = 0.02341643323656215567

      r_node(38) = 0.96465960618086743494
      th_node(38) = 3.70522443534172518653
      weight(38) = 0.01905256317618120657

      r_node(39) = 0.96465960618086743494
      th_node(39) = 4.28847304447466459720
      weight(39) = 0.01299684397858972065

      r_node(40) = 0.96465960618086743494
      th_node(40) = 4.63041392206758217753
      weight(40) = 0.00579798753740114886

      do i = 1, n
        dUeq(i) = 0.0d0
        if (x(i) > 0.0) then
          ! Evaluation of wake and sum of quadrature
          do j = 1, 40
            ! Location of evaluation points in the local rotor coordinates
            x_e = x(i)
            y_e = y(i) + RT(i)*r_node(j)*cos(th_node(j))
            z_e = z(i) + RT(i)*r_node(j)*sin(th_node(j))
            r_e  = (y_e**(2.0d0) + z_e**(2.0d0))**(0.5d0)
            call get_dU(1,x_e,r_e,D,CT,TI,a1,a2,a3,a4,b1,b2,dU)
            dUeq(i)=dUeq(i)+dU(1)*weight(j)
          end do
        end if
      end do

      end subroutine get_dUeq

c ----------------------------------------------------------------------
c gcl_s(x,y,z,DT,P_c,CT_c,WS,TI)
c ----------------------------------------------------------------------
c SINGLE FLOW CASE
c Computes the WindFarm flow and Power using G. C. Larsen model:
c Larsen, G. C., and P. E. Re'thore'. A simple stationary semi-analytical
c wake model. Technical Report Risoe, 2009.
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 TI (float): Ambient turbulence intensity [-]
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 gcl_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,TI,
     &a1,a2,a3,a4,b1,b2,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT
      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,TI,a1,a2,a3,a4,b1,b2
      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,TI
cf2py real(kind=8) optional,intent(in) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in) :: b1=15.6298
cf2py real(kind=8) optional,intent(in) :: b2=1.0
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,TI,a1,a2,a3,a4,b1,b2,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 gcl_s

c ----------------------------------------------------------------------
c gcl(x,y,z,DT,P_c,CT_c,WS,WD,TI)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES
c Computes the WindFarm flow and Power using G. C. Larsen model:
c Larsen, G. C., and P. E. Re'thore'. A simple stationary semi-analytical
c wake model. Technical Report Risoe, 2009.
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 TI (array): Ambient turbulence intensity [-]
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 gcl(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,TI,a1,a2,
     &a3,a4,b1,b2,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF
      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,TI,a1,a2,a3,a4,b1,b2
      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,TI
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b1=15.6298
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b2=1.0
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 gcl_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i),WD(i),TI(i),
     &       a1(i),a2(i),a3(i),a4(i),b1(i),b2(i),rho,WS_CI,WS_CO,
     &       CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine gcl

c ----------------------------------------------------------------------
c gcl_av(x,y,z,DT,P_c,CT_c,WS,WD,TI,AV)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES with wt available
c Computes the WindFarm flow and Power using G. C. Larsen model:
c Larsen, G. C., and P. E. Re'thore'. A simple stationary semi-analytical
c wake model. Technical Report Risoe, 2009.
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 TI (array): Ambient turbulence intensity [-]
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 gcl_av(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,TI,AV,
     &a1,a2,a3,a4,b1,b2,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,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,TI,a1,a2,a3,a4,b1,b2
      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,TI
cf2py integer intent(in),dimension(nF,n) :: AV
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b1=15.6298
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b2=1.0
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 gcl_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c_AV,CT_c_AV,WS(i),WD(i),
     &       TI(i),a1(i),a2(i),a3(i),a4(i),b1(i),b2(i),rho,WS_CI,
     &       WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine gcl_av

c ----------------------------------------------------------------------
c New Multiple turbine types (height, P and CT curves) implementation
c ----------------------------------------------------------------------

c ----------------------------------------------------------------------
c gclm_s(x,y,z,DT,P_c,CT_c,WS,TI)
c ----------------------------------------------------------------------
c SINGLE FLOW CASE
c Computes the WindFarm flow and Power using G. C. Larsen model:
c Larsen, G. C., and P. E. Re'thore'. A simple stationary semi-analytical
c wake model. Technical Report Risoe, 2009.
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] for each wind turbine
c WD (array): Undisturbed wind direction at hub height [deg.] for each
c             turbine. Meteorological coordinates (N=0,E=90,S=180,W=270)
c TI (array): Turbulence intensity [-] for each turbine
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 gclm_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,TI,
     &a1,a2,a3,a4,b1,b2,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT
      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(n),WD(n),TI(n),a1,a2,a3,a4,b1,b2
      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),dimension(n) :: WS,WD,TI
cf2py real(kind=8) optional,intent(in) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in) :: b1=15.6298
cf2py real(kind=8) optional,intent(in) :: b2=1.0
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
      do i=1,n
        angle = pi*(270.0d0-WD(i))/180.0d0
        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,TI(i),a1,a2,a3,a4,b1,b2,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 gclm_s

c ----------------------------------------------------------------------
c gclm(x,y,z,DT,P_c,CT_c,WS,WD,TI)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES
c Computes the WindFarm flow and Power using G. C. Larsen model:
c Larsen, G. C., and P. E. Re'thore'. A simple stationary semi-analytical
c wake model. Technical Report Risoe, 2009.
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] for each wind turbine x flow [nF,n]
c WD (array): Undisturbed wind direction at hub height [deg.] for each
c             turbine x flow [nF,n]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c TI (array): Turbulence intensity [-] for each turbine x 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 gclm(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,TI,a1,
     &a2,a3,a4,b1,b2,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF
      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) :: a1,a2,a3,a4,b1,b2
      real(kind=8) :: WS(nF,n),WD(nF,n),TI(nF,n),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 = size(WS,1)
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,n) :: WS,WD,TI
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b1=15.6298
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b2=1.0
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(nF,nF,n),dimension(nF,n) :: P,T,U
      ! internal variables
      integer :: i

      do i=1,nF
        call gclm_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c,CT_c,WS(i,:),WD(i,:),
     &       TI(i,:),a1(i),a2(i),a3(i),a4(i),b1(i),b2(i),rho,WS_CI,
     &       WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine gclm

c ----------------------------------------------------------------------
c gclm_av(x,y,z,DT,P_c,CT_c,WS,WD,TI,AV)
c ----------------------------------------------------------------------
c MULTIPLE FLOW CASES with wt available
c Computes the WindFarm flow and Power using G. C. Larsen model:
c Larsen, G. C., and P. E. Re'thore'. A simple stationary semi-analytical
c wake model. Technical Report Risoe, 2009.
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] for each wind turbine x flow [nF,n]
c WD (array): Undisturbed wind direction at hub height [deg.] for each
c             turbine x flow [nF,n]
c             Meteorological coordinates (N=0,E=90,S=180,W=270)
c TI (array): Turbulence intensity [-] for each turbine x flow [nF,n]
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 gclm_av(n,nP,nCT,nF,x_g,y_g,z_g,DT,P_c,CT_c,WS,WD,TI,
     &AV,a1,a2,a3,a4,b1,b2,rho,WS_CI,WS_CO,CT_idle,P,T,U)

      implicit none
      integer :: n,nP,nCT,nF,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) :: a1,a2,a3,a4,b1,b2
      real(kind=8) :: WS(nF,n),WD(nF,n),TI(nF,n),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 = size(WS,1)
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,n) :: WS,WD,TI
cf2py integer intent(in),dimension(nF,n) :: AV
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a1=0.435449861
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a2=0.797853685
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a3=-0.124807893
cf2py real(kind=8) optional,intent(in),dimension(nF) :: a4=0.136821858
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b1=15.6298
cf2py real(kind=8) optional,intent(in),dimension(nF) :: b2=1.0
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(nF,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 gclm_s(n,nP,nCT,x_g,y_g,z_g,DT,P_c_AV,CT_c_AV,WS(i,:),
     &       WD(i,:),TI(i,:),a1(i),a2(i),a3(i),a4(i),b1(i),b2(i),rho,
     &       WS_CI,WS_CO,CT_idle,P(i,:),T(i,:),U(i,:))
      end do

      end subroutine gclm_av

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 fitlogistic(s,ydl,y,w,nlocal,yfit)

!  (1) Fit local double logistic functions                                      !
!                                                                               !
!  y(t) = c(1) + c(2)*(1/(1+exp((x(1)-t)/x(2))) - 1/(1+exp((x(3)-t)/x(4)))      !
!                                                                               !
!  in an iterative proceedure to approach the upper/lower envelope of           !
!  the data values. The linear, c(1) and c(2), and non-linear x(1),...,x(4)     !
!  parameters are determined using Marquard's method. Note that we separate     !
!  the two parameter sets in order to improve performance. The non-linear       !
!  parameters are box constrained bl(i) <= x(i) <= bu(i) to ensure that we      !
!  find a phenologically sound solution.                                        !
!                                                                               !
!  (2) Merge the local functions to a global function                           !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Improved estimates of starting parameters                                    !
!                                                                               !
!  Updated September 2006                                                       !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,k,l,nmid,nyear,nptperyear,npt,nenvi,printflag,debugflag,win(3)
integer :: m0,m1,m2,n,n1,n2,nlocal,s(4*nyear+2),term,kmin,lmin,nseason
integer :: sumnonconstant
double precision :: wfact,y(npt),w(npt),yfit(npt),wfit(npt),ylocal(nlocal,npt)
double precision :: width,x(4),xn(4),ones(npt),t(npt),cut,ndiff,mid
double precision :: exp12(npt),ytilde(npt),Btilde(npt,2),c(2),bl(4),bu(4)
double precision :: ydl(2*nptperyear,5,2),fact(5),chi2,chi2min,ymed

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

yfit = y
wfit = w
ylocal = 0.d0
ones = 1.d0

!---- Initiate matrix that will contain the local functions ---------------------

ylocal = 0.d0

!---- Define widths for one and two seasons respectively ------------------------

if (nlocal/nyear == 2) then
  width = nptperyear/4.d0
  nseason = 1
else
  width = nptperyear/8.d0
  nseason = 2
end if

fact = (/ 0.3d0, 0.6d0, 1.d0, 1.5d0, 1.9d0 /)

!---- Iterative fits to local double logistic functions in all intervalls -------

do j = 1,nenvi
  do i = 1,nlocal

!---- Fitting intervall given by [m0,m2] ----------------------------------------

    m0 = s(i)
    m1 = s(i+1)
    m2 = s(i+2)
	n = m2 - m0 + 1

!---- Check if the are enought non constant data values in the intervall ---------

    sumnonconstant = 0
	do k = m0,m2-1
	  if (abs(y(k) - y(k+1)) < 1.d-6) then
	    sumnonconstant = sumnonconstant + 1
	  end if
	end do

	if ((sumnonconstant < 3.d0*(m2-m0+1)/4.d0) .and. (count(w(m0:m2) == 0.d0) < 3.d0*(m2-m0+1)/4.d0)) then

!---- Initial estimates of fitting parameters -----------------------------------
!     Loop over width and position in time

      chi2min = 1.d60

	  do k = 1,5
	    do l = 1,5
          nmid = floor(m1 - m0 + (l-3.d0)*width/3.d0)
	      exp12(1:n) = ydl(nptperyear-nmid+1:nptperyear+n-nmid,k,nseason)
          ytilde(1:n) = wfit(m0:m2)*y(m0:m2)
          Btilde(1:n,1:2) = reshape(source = (/ wfit(m0:m2), wfit(m0:m2)*exp12(1:n) /), &
	                           shape = (/ n,2 /))
	      call gauss(2,matmul(transpose(Btilde(1:n,1:2)),Btilde(1:n,1:2)), &
	             matmul(ytilde(1:n),Btilde(1:n,1:2)),c)

!---- Evaluate the fitted function ----------------------------------------------

          ylocal(i,m0:m2) = c(1) + c(2)*exp12(1:n)
		  chi2 = sum((wfit(m0:m2)*(ylocal(i,m0:m2)-y(m0:m2)))**2.d0)
		  if (chi2 < chi2min) then
		    chi2min = chi2
	        kmin = k
		    lmin = l
	      end if

	    end do
	  end do

!---- Best starting values ------------------------------------------------------

      x(1) = m1 - m0 - width*fact(kmin) + (lmin-3.d0)*width/3.d0
      x(3) = m1 - m0 + width*fact(kmin) + (lmin-3.d0)*width/3.d0
      x(2) = nptperyear/20.d0
      x(4) = nptperyear/20.d0

!---- Set constraints -----------------------------------------------------------

      bl = (/ x(1)-width/2.d0, 0.5d0*x(2), x(3)-width/2.d0, 0.5d0*x(4) /)
      bu = (/ x(1)+width/2.d0, 10.d0*x(2), x(3)+width/2.d0, 10.d0*x(4) /)

!---- Separable box constrained non-linear least squares fit --------------------

!     write(*,*) 'Log,x,chi2min',x,chi2min
	  call marquardt(2,term,x,xn,bl,bu,4,y(m0:m2),wfit(m0:m2),n)
!     write(*,*) 'xn',xn
!	  pause

!---- Final linear fit to determine c(1) and c(2) -------------------------------

      t = dble((/(i,i=1,npt)/))
	  exp12(1:n) = 1.d0/(1.d0 + exp((xn(1)-t(1:n))/xn(2))) &
	                            - 1.d0/(1.d0 + exp((xn(3)-t(1:n))/xn(4)))

      ytilde(1:n) = wfit(m0:m2)*y(m0:m2)
      Btilde(1:n,1:2) = reshape(source = (/ wfit(m0:m2), wfit(m0:m2)*exp12(1:n) /), &
	                           shape = (/ n,2 /))
	  call gauss(2,matmul(transpose(Btilde(1:n,1:2)),Btilde(1:n,1:2)), &
	           matmul(ytilde(1:n),Btilde(1:n,1:2)),c)

!---- Evaluate the fitted function ----------------------------------------------

      ylocal(i,m0:m2) = c(1) + c(2)*exp12(1:n)

    else

!---- If many constant values in interval replace with median value -------------

	  call median(y(m0:m2),m2-m0+1,ymed)
	  ylocal(i,m0:m2) = ymed

	end if

  end do ! end loop over local functions

!---- Merge local functions to a global function --------------------------------

  do i = 2,nlocal
    n1 = s(i)
    n2 = s(i+1)
	ndiff = dble(n2 - n1)
    mid = (n1 + n2)/2.d0
    do k = n1,n2
      cut = (atan(10.d0*(k-mid)/ndiff) - atan(10.d0*(n1-mid)/ndiff))/ &
            (atan(10.d0*(n2-mid)/ndiff) - atan(10.d0*(n1-mid)/ndiff))
      yfit(k) = cut*ylocal(i,k) + (1.d0-cut)*ylocal(i-1,k)
    end do
  end do

!---- Add points in the beginning and at the end -------------------------------

  yfit(s(1):s(2)) = ylocal(1,s(1):s(2))
  yfit(s(nlocal+1):s(nlocal+2)) = ylocal(nlocal,s(nlocal+1):s(nlocal+2))

!---- Modify weights -----------------------------------------------------------

  if (j < nenvi) then
    call modweight(j,npt,wfit,y,yfit)
  end if

end do ! end loop over envelope iterations

!---- Output for debug purposes ------------------------------------------------

! write(*,*) 3,sum(yfit)

end subroutine fitlogistic


C
C $Id: curvss.f,v 1.5 2008-07-27 03:10:11 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      subroutine curvss (n,x,y,d,isw,s,eps,ys,ysp,sigma,td,
     *                   tsd1,hd,hsd1,hsd2,rd,rsd1,rsd2,v,
     *                   ierr)
c
      integer n,isw,ierr
      real x(n),y(n),d(n),s,eps,ys(n),ysp(n),sigma,td(n),
     *     tsd1(n),hd(n),hsd1(n),hsd2(n),rd(n),rsd1(n),
     *     rsd2(n),v(n)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a smoothing spline under tension. for a given
c increasing sequence of abscissae (x(i)), i = 1,..., n and
c associated ordinates (y(i)), i = 1,..., n, the function
c determined minimizes the summation from i = 1 to n-1 of
c the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with two continuous derivatives such that the
c summation of the square of (f(x(i))-y(i))/d(i) is less
c than or equal to a given constant s, where (d(i)), i = 1,
c ..., n are a given set of observation weights. the
c function determined is a spline under tension with third
c derivative discontinuities at (x(i)), i = 2,..., n-1. for
c actual computation of points on the curve it is necessary
c to call the function curv2.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than equal or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   td, tsd1, hd, hsd1, hsd2, rd, rsd1, rsd2, and v are
c   arrays of length at least n which are used for scratch
c   storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive.
c
c and
c
c   n, x, y, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules ftstore, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      if (n .lt. 2) go to 24
      if (s .lt. 0.) go to 25
      if (eps .lt. 0. .or. eps .gt. 1.) go to 26
      ierr = 0
      p = 0.
      v(1) = 0.
      v(n) = 0.
      ysp(1) = 0.
      ysp(n) = 0.
      if (n .eq. 2) go to 14
      rsd1(1) = 0.
      rd(1) = 0.
      rsd2(n) = 0.
      rdim1 = 0.
      yspim2 = 0.
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c form t matrix and second differences of y into ys
c
      nm1 = n-1
      nm3 = n-3
      delxi1 = 1.
      delyi1 = 0.
      dim1 = 0.
      do 1 i = 1,nm1
        delxi = x(i+1)-x(i)
        if (delxi .le. 0.) go to 27
        delyi = (y(i+1)-y(i))/delxi
        ys(i) = delyi-delyi1
        call terms (di,tsd1(i+1),sigmap,delxi)
        td(i) = di+dim1
        hd(i) = -(1./delxi+1./delxi1)
        hsd1(i+1) = 1./delxi
        delxi1 = delxi
        delyi1 = delyi
    1   dim1 = di
c
c calculate lower and upper tolerances
c
      sl = s*(1.-eps)
      su = s*(1.+eps)
      if (isw .eq. 1) go to 3
c
c form h matrix - d array
c
      if (d(1) .le. 0. .or. d(2) .le. 0.) go to 28
      betapp = 0.
      betap = 0.
      alphap = 0.
      do 2 i = 2,nm1
        alpha = hd(i)*d(i)*d(i)
        if (d(i+1) .le. 0.) go to 28
        beta = hsd1(i+1)*d(i+1)*d(i+1)
        hd(i) = (hsd1(i)*d(i-1))**2+alpha*hd(i)
     *                             +beta*hsd1(i+1)
        hsd2(i) = hsd1(i)*betapp
        hsd1(i) = hsd1(i)*(alpha+alphap)
        alphap = alpha
        betapp = betap
    2   betap = beta
      go to 5
c
c form h matrix - d constant
c
    3 if (d(1) .le. 0.) go to 28
      sl = d(1)*d(1)*sl
      su = d(1)*d(1)*su
      hsd1p = 0.
      hdim1 = 0.
      do 4 i = 2,nm1
        hdi = hd(i)
        hd(i) = hsd1(i)*hsd1(i)+hdi*hdi+hsd1(i+1)*hsd1(i+1)
        hsd2(i) = hsd1(i)*hsd1p
        hsd1p = hsd1(i)
        hsd1(i) = hsd1p*(hdi+hdim1)
    4   hdim1 = hdi
c
c top of iteration
c cholesky factorization of p*t+h into r
c
    5 do 6 i = 2,nm1
        rsd2i = hsd2(i)
        rsd1i = p*tsd1(i)+hsd1(i)-rsd2i*rsd1(i-1)
        rsd2(i) = rsd2i*rdim1
        rdim1 = rd(i-1)
        rsd1(i) = rsd1i*rdim1
        rd(i) = 1./(p*td(i)+hd(i)-rsd1i*rsd1(i)
     *                           -rsd2i*rsd2(i))
        ysp(i) = ys(i)-rsd1(i)*ysp(i-1)-rsd2(i)*yspim2
    6   yspim2 = ysp(i-1)
c
c back solve of r(transpose)* r * ysp = ys
c
      ysp(nm1) = rd(nm1)*ysp(nm1)
      if (n .eq. 3) go to 8
      do 7 ibak = 1,nm3
        i = nm1-ibak
    7   ysp(i) = rd(i)*ysp(i)-rsd1(i+1)*ysp(i+1)
     *                       -rsd2(i+2)*ysp(i+2)
    8 sum = 0.
      delyi1 = 0.
      if (isw .eq. 1) go to 10
c
c calculation of residual norm
c  - d array
c
      do 9 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = (delyi-delyi1)*d(i)*d(i)
        sum = sum+v(i)*(delyi-delyi1)
    9   delyi1 = delyi
      v(n) = -delyi1*d(n)*d(n)
      go to 12
c
c calculation of residual norm
c  - d constant
c
   10 do 11 i = 1,nm1
        delyi = (ysp(i+1)-ysp(i))/(x(i+1)-x(i))
        v(i) = delyi-delyi1
        sum = sum+v(i)*(delyi-delyi1)
   11   delyi1 = delyi
      v(n) = -delyi1
   12 sum = sum-v(n)*delyi1
c
c test for convergence
c
      if (sum .le. su) go to 14
c
c calculation of newton correction
c
      f = 0.
      g = 0.
      wim2 = 0.
      wim1 = 0.
      do 13 i = 2,nm1
        tui = tsd1(i)*ysp(i-1)+td(i)*ysp(i)
     *                        +tsd1(i+1)*ysp(i+1)
        wi = tui-rsd1(i)*wim1-rsd2(i)*wim2
        f = f+tui*ysp(i)
        g = g+wi*wi*rd(i)
        wim2 = wim1
   13   wim1 = wi
      h = f-p*g
      if (h .le. 0.) go to 14
c
c update p - newton step
c
      step = (sum-sqrt(sum*sl))/h
      if (sl .ne. 0.) step = step*sqrt(sum/sl)
      if (ftstore(p+step) .eq. p) go to 14
      p = p+step
      go to 5
c
c store smoothed y-values and second derivatives
c
   14 if (p .eq. 0.) go to 16
      do 15 i = 1,n
        ys(i) = y(i)-v(i)
   15   ysp(i) = p*ysp(i)
      return
c
c straight line is acceptable
c
   16 sumx = 0.
      sumy = 0.
      if (isw .eq. 1) go to 19
      sum = 0.
c
c compute straight line coefficients
c   d - vector
c
      do 17 i = 1, n
        dinvsq = 1./(d(i)*d(i))
        sum = sum+dinvsq
        sumx = sumx+x(i)*dinvsq
   17   sumy = sumy+y(i)*dinvsq
      xbar = sumx/sum
      ybar = sumy/sum
      sumx = 0.
      sumy = 0.
      do 18 i = 1, n
        fac = (x(i)-xbar)/(d(i)*d(i))
        sumx = sumx+(x(i)-xbar)*fac
   18   sumy = sumy+(y(i)-ybar)*fac
      go to 22
c
c compute straight line coefficients
c   d - constant
c
   19 sum = float(n)*dinvsq
      do 20 i = 1, n
        sumx = sumx+x(i)
   20   sumy = sumy+y(i)
      xbar = sumx/float(n)
      ybar = sumy/float(n)
      sumx = 0.
      sumy = 0.
      do 21 i = 1, n
        sumx = sumx+(x(i)-xbar)*(x(i)-xbar)
   21   sumy = sumy+(y(i)-ybar)*(x(i)-xbar)
c
c store straight line values
c
   22 slp = sumy/sumx
      do 23 i = 1, n
        ys(i) = ybar+slp*(x(i)-xbar)
   23   ysp(i) = 0.
      return
c
c n less than 2
c
   24 ierr = 1
      return
c
c s negative
c
   25 ierr = 2
      return
c
c eps negative or greater than 1
c
   26 ierr = 3
      return
c
c x-values not strictly increasing
c
   27 ierr = 4
      return
c
c weight non-positive
c
   28 ierr = 5
      return
      end


      SUBROUTINE QGAUS(FUNC,A,B,SS)
      IMPLICIT NONE
C
      REAL A,B,SS,FUNC
      EXTERNAL FUNC
C
      REAL X(5),W(5)
      REAL XM,XR,DX
      INTEGER J
C
      DATA X/0.1488743389, 0.4333953941, 0.6794095682, 0.8650633666,
     &       0.9739065285/
      DATA W/0.2955242247, 0.2692667193, 0.2190863625, 0.1494513491,
     &       0.0666713443/
C
      XM = 0.5*(B+A)
      XR = 0.5*(B-A)
      SS = 0.0
      DO 10 J=1,5
         DX = XR*X(J)
         SS = SS + W(J)*(FUNC(XM+DX)+FUNC(XM-DX))
 10   CONTINUE
      SS = XR*SS
      RETURN
      END


use LinearSolverClass
use TimeClass
implicit none

type(LinearSolver_) :: solver
type(Time_) :: time
real(real64) :: Amat(5,5),mm(5)
integer(int32) :: i, j

Amat(1,:) = [ 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0 ]
Amat(2,:) = [ 2.0d0, 2.0d0, 0.0d0, 0.0d0, 0.0d0 ]
Amat(3,:) = [ 0.0d0, 3.0d0, 3.0d0, 0.0d0, 0.0d0 ]
Amat(4,:) = [ 2.0d0, 2.0d0, 2.0d0, 1.0d0, 0.0d0 ]
Amat(5,:) = [ 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0 ]

solver%val = [1.0d0,2.0d0,2.0d0,3.0d0,3.0d0,2.0d0,2.0d0,2.0d0,1.0d0,1.0d0]
solver%Index_I = [1, 2, 2, 3, 3, 4,4,4,4,5]
solver%Index_J = [1, 1, 2, 2, 3, 1,2,3,4,5]

solver%b = [1.0d0, 2.0d0, 3.0d0,4.0d0,5.0d0]
solver%b_Index_J = [1, 2, 3, 4, 5]
call solver%convertCOOtoCRS()

print *, solver%CRS_val
print *, solver%CRS_Index_I
print *, solver%CRS_Index_J

call time%start()
mm = matmul(Amat,solver%b)
call time%show()
print *, mm

mm(:) = 0.0d0
call time%start()
mm = solver%matmulCRS()
call time%show()
print *, mm

end


*DECK CPSI
      COMPLEX FUNCTION CPSI (ZIN)
C***BEGIN PROLOGUE  CPSI
C***PURPOSE  Compute the Psi (or Digamma) function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7C
C***TYPE      COMPLEX (PSI-S, DPSI-D, CPSI-C)
C***KEYWORDS  DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C PSI(X) calculates the psi (or digamma) function of X.  PSI(X)
C is the logarithmic derivative of the gamma function of X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CCOT, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  CPSI
      COMPLEX ZIN, Z, Z2INV, CORR, CCOT
      DIMENSION BERN(13)
      LOGICAL FIRST
      EXTERNAL CCOT
      SAVE BERN, PI, NTERM, BOUND, DXREL, RMIN, RBIG, FIRST
      DATA BERN( 1) /   .8333333333 3333333 E-1 /
      DATA BERN( 2) /  -.8333333333 3333333 E-2 /
      DATA BERN( 3) /   .3968253968 2539683 E-2 /
      DATA BERN( 4) /  -.4166666666 6666667 E-2 /
      DATA BERN( 5) /   .7575757575 7575758 E-2 /
      DATA BERN( 6) /  -.2109279609 2796093 E-1 /
      DATA BERN( 7) /   .8333333333 3333333 E-1 /
      DATA BERN( 8) /  -.4432598039 2156863 E0 /
      DATA BERN( 9) /   .3053954330 2701197 E1 /
      DATA BERN(10) /  -.2645621212 1212121 E2 /
      DATA BERN(11) /   .2814601449 2753623 E3 /
      DATA BERN(12) /  -.3454885393 7728938 E4 /
      DATA BERN(13) /   .5482758333 3333333 E5 /
      DATA PI / 3.141592653 589793 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  CPSI
      IF (FIRST) THEN
         NTERM = -0.30*LOG(R1MACH(3))
C MAYBE BOUND = N*(0.1*EPS)**(-1/(2*N-1)) / (PI*EXP(1))
         BOUND = 0.1171*NTERM*(0.1*R1MACH(3))**(-1.0/(2*NTERM-1))
         DXREL = SQRT(R1MACH(4))
         RMIN = EXP (MAX (LOG(R1MACH(1)), -LOG(R1MACH(2))) + 0.011 )
         RBIG = 1.0/R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      Z = ZIN
      X = REAL(Z)
      Y = AIMAG(Z)
      IF (Y.LT.0.0) Z = CONJG(Z)
C
      CORR = (0.0, 0.0)
      CABSZ = ABS(Z)
      IF (X.GE.0.0 .AND. CABSZ.GT.BOUND) GO TO 50
      IF (X.LT.0.0 .AND. ABS(Y).GT.BOUND) GO TO 50
C
      IF (CABSZ.LT.BOUND) GO TO 20
C
C USE THE REFLECTION FORMULA FOR REAL(Z) NEGATIVE, ABS(Z) LARGE, AND
C ABS(AIMAG(Y)) SMALL.
C
      CORR = -PI*CCOT(PI*Z)
      Z = 1.0 - Z
      GO TO 50
C
C USE THE RECURSION RELATION FOR ABS(Z) SMALL.
C
 20   IF (CABSZ .LT. RMIN) CALL XERMSG ('SLATEC', 'CPSI',
     +   'CPSI CALLED WITH Z SO NEAR 0 THAT CPSI OVERFLOWS', 2, 2)
C
      IF (X.GE.(-0.5) .OR. ABS(Y).GT.DXREL) GO TO 30
      IF (ABS((Z-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
     +   'CPSI',
     +   'ANSWER LT HALF PRECISION BECAUSE Z TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
      IF (Y .EQ. 0.0 .AND. X .EQ. AINT(X)) CALL XERMSG ('SLATEC',
     +   'CPSI', 'Z IS A NEGATIVE INTEGER', 3, 2)
C
 30   N = SQRT(BOUND**2-Y**2) - X + 1.0
      DO 40 I=1,N
        CORR = CORR - 1.0/Z
        Z = Z + 1.0
 40   CONTINUE
C
C NOW EVALUATE THE ASYMPTOTIC SERIES FOR SUITABLY LARGE Z.
C
 50   IF (CABSZ.GT.RBIG) CPSI = LOG(Z) + CORR
      IF (CABSZ.GT.RBIG) GO TO 70
C
      CPSI = (0.0, 0.0)
      Z2INV = 1.0/Z**2
      DO 60 I=1,NTERM
        NDX = NTERM + 1 - I
        CPSI = BERN(NDX) + Z2INV*CPSI
 60   CONTINUE
      CPSI = LOG(Z) - 0.5/Z - CPSI*Z2INV + CORR
C
 70   IF (Y.LT.0.0) CPSI = CONJG(CPSI)
C
      RETURN
      END


chapter xii, example 4. quasi-interpolant with good knots.
c  from  * a practical guide to splines *  by c. de boor
calls bsplpp(bsplvb)
c
      integer i,irate,istep,j,l,m,mmk,n,nlow,nhigh,nm1
      real algerp,aloger,bcoef(22),break(20),c(4,20),decay,dg,ddg,x
     *	  ,dtip1,dtip2,dx,errmax,g,h,pnatx,scrtch(4,4),step,t(26),taui
c     istep and step = float(istep) specify point density for error det-
c     ermination.
      data step, istep /20., 20/
c	 g  is the function to be approximated,  dg  is its first, and
c	 ddg  its second derivative .
      g(x) = sqrt(x+1.)
      dg(x) = .5/g(x)
      ddg(x) = -.5*dg(x)/(x+1.)
      decay = 0.
c      read in the exponent  irate  for the knot distribution and the
c      lower and upper limit for the number  n	.
      read 500,irate,nlow,nhigh
  500 format(3i3)
      print 600
  600 format(28h  n   max.error   decay exp./)
c			       loop over  n = dim( spline(4,t) ) - 2 .
c	       n  is chosen as the parameter in order to afford compar-
c	       ison with examples 2 and 3  in which cubic spline interp-
c	       olation at  n  data points was used .
      do 40 n=nlow,nhigh,2
	 nm1 = n-1
	 h = 1./float(nm1)
	 m = n+2
	 mmk = m-4
	 do 5 i=1,4
	    t(i) = -1.
    5	    t(m+i) = 1.
c		  interior knots are equidistributed with respect to the
c		  function  (x + 1)**(1/irate) .
	 do 6 i=1,mmk
    6	    t(i+4) = 2.*(float(i)*h)**irate - 1.
c					    construct quasi-interpolant.
c						 bcoef(1) = g(-1.) = 0.
	 bcoef(1) = 0.
	 dtip2 = t(5) - t(4)
	 taui = t(5)
c			    special choice of  tau(2)  to avoid infinite
c			    derivatives of  g  at left endpoint .
	 bcoef(2) = g(taui) - 2.*dtip2*dg(taui)/3.
     *		   + dtip2**2*ddg(taui)/6.
	 do 15 i=3,m
	    taui = t(i+2)
	    dtip1 = dtip2
	    dtip2 = t(i+3) - t(i+2)
c				       formula xii(30) of text is used .
   15	    bcoef(i) = g(taui) + (dtip2-dtip1)*dg(taui)/3.
     *		     - dtip1*dtip2*ddg(taui)/6.
c					  convert to pp-representation .
	 call bsplpp(t,bcoef,m,4,scrtch,break,c,l)
c			     estimate max.interpolation error on (-1,1).
	 errmax = 0.
c					      loop over cubic pieces ...
	 do 30 i=1,l
	    dx = (break(i+1)-break(i))/step
c			error is calculated at	istep  points per piece.
	    do 30 j=1,istep
	       h = float(j)*dx
	       pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
   30	       errmax = amax1(errmax,abs(g(break(i)+h)-pnatx))
c					      calculate decay exponent .
	 aloger = alog(errmax)
	 if (n .gt. nlow)  decay =
     *	     (aloger - algerp)/alog(float(n)/float(n-2))
	 algerp = aloger
c
   40	 print 640,n,errmax,decay
  640 format(i3,e12.4,f11.2)
					stop
      end


     !Programa principal líneas de la 1 a la 9
      program llamar_funcion
        implicit none
        real :: un_vector(9)
        real :: norma_del_vector
        !Inicializar en 9 todas las componentes del vector
        un_vector(:)=9
        print *, 'Norma del vector= ',norma_del_vector(9,un_vector)
      end program llamar_funcion

      !Función usada en el programa principal de las líneas 11 a 18
      function norma_del_vector(longitud_del_vector,nombre_del_vector) result(valor_norma)
        implicit none
        integer, intent(in) :: longitud_del_vector
        real, intent(in) :: nombre_del_vector(longitud_del_vector)
        real :: valor_norma
        valor_norma= sqrt(sum(nombre_del_vector**2))
      end function norma_del_vector


*> \brief \b SPFTRS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SPFTRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANSR, UPLO
*       INTEGER            INFO, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       REAL               A( 0: * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SPFTRS solves a system of linear equations A*X = B with a symmetric
*> positive definite matrix A using the Cholesky factorization
*> A = U**T*U or A = L*L**T computed by SPFTRF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANSR
*> \verbatim
*>          TRANSR is CHARACTER*1
*>          = 'N':  The Normal TRANSR of RFP A is stored;
*>          = 'T':  The Transpose TRANSR of RFP A is stored.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of RFP A is stored;
*>          = 'L':  Lower triangle of RFP A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension ( N*(N+1)/2 )
*>          The triangular factor U or L from the Cholesky factorization
*>          of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF.
*>          See note below for more details about RFP A.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the right hand side matrix B.
*>          On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  We first consider Rectangular Full Packed (RFP) Format when N is
*>  even. We give an example where N = 6.
*>
*>      AP is Upper             AP is Lower
*>
*>   00 01 02 03 04 05       00
*>      11 12 13 14 15       10 11
*>         22 23 24 25       20 21 22
*>            33 34 35       30 31 32 33
*>               44 45       40 41 42 43 44
*>                  55       50 51 52 53 54 55
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
*>  the transpose of the first three columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
*>  the transpose of the last three columns of AP lower.
*>  This covers the case N even and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>        03 04 05                33 43 53
*>        13 14 15                00 44 54
*>        23 24 25                10 11 55
*>        33 34 35                20 21 22
*>        00 44 45                30 31 32
*>        01 11 55                40 41 42
*>        02 12 22                50 51 52
*>
*>  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
*>  transpose of RFP A above. One therefore gets:
*>
*>
*>           RFP A                   RFP A
*>
*>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
*>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
*>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
*>
*>
*>  We then consider Rectangular Full Packed (RFP) Format when N is
*>  odd. We give an example where N = 5.
*>
*>     AP is Upper                 AP is Lower
*>
*>   00 01 02 03 04              00
*>      11 12 13 14              10 11
*>         22 23 24              20 21 22
*>            33 34              30 31 32 33
*>               44              40 41 42 43 44
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
*>  the transpose of the first two columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
*>  the transpose of the last two columns of AP lower.
*>  This covers the case N odd and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>        02 03 04                00 33 43
*>        12 13 14                10 11 44
*>        22 23 24                20 21 22
*>        00 33 34                30 31 32
*>        01 11 44                40 41 42
*>
*>  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
*>  transpose of RFP A above. One therefore gets:
*>
*>           RFP A                   RFP A
*>
*>     02 12 22 00 01             00 10 20 30 40 50
*>     03 13 23 33 11             33 11 21 31 41 51
*>     04 14 24 34 44             43 44 22 32 42 52
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          TRANSR, UPLO
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      REAL               A( 0: * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, NORMALTRANSR
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, STFSM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NORMALTRANSR = LSAME( TRANSR, 'N' )
      LOWER = LSAME( UPLO, 'L' )
      IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SPFTRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
*     start execution: there are two triangular solves
*
      IF( LOWER ) THEN
         CALL STFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B,
     $               LDB )
         CALL STFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B,
     $               LDB )
      ELSE
         CALL STFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B,
     $               LDB )
         CALL STFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B,
     $               LDB )
      END IF
*
      RETURN
*
*     End of SPFTRS
*
      END


SUBROUTINE SSPGVX_F95( AP, BP, W, ITYPE, UPLO, Z, VL, VU, IL, IU, &
     &  M, IFAIL, ABSTOL, INFO )
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO, LSAME
      USE F77_LAPACK, ONLY: LAMCH_F77 => SLAMCH
      USE F77_LAPACK, ONLY: SPGVX_F77 => LA_SPGVX
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. CHARACTER ARGUMENTS ..
      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!  .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(IN), OPTIONAL :: IL, IU, ITYPE
      INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
      REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
!  .. ARRAY ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IFAIL(:)
      REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
      REAL(WP), INTENT(INOUT) :: AP(:), BP(:)
      REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_SPGVX and LA_HPGVX compute selected eigenvalues and, optionally,
! the corresponding eigenvectors of generalized eigenvalue problems of
! the form
!       A*z = lambda*B*z, A*B*z = lambda*z, and B*A*z = lambda*z,
! where A and B are real symmetric in the case of LA_SPGVX and complex
! Hermitian in the case of LA_HPGVX. In both cases B is positive
! definite. Eigenvalues and eigenvectors can be selected by specifying
! either a range of values or a range of indices for the desired
! eigenvalues. Matrices A and B are stored in a packed format.
!
! =========
!
!       SUBROUTINE LA_SPGVX / LA_HPGVX( AP, BP, W, ITYPE= itype, &
!             UPLO= uplo, Z= z, VL= vl, VU= vu, IL= il, IU= iu, M= m, &
!             IFAIL= ifail, ABSTOL= abstol, INFO= info )
!         <type>(<wp>), INTENT(INOUT) :: AP(:), BP(:)
!         REAL(<wp>), INTENT(OUT) :: W(:)
!         INTEGER, INTENT(IN), OPTIONAL :: ITYPE
!         CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!         <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!         REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
!         INTEGER, INTENT(IN), OPTIONAL :: IL, IU
!         INTEGER, INTENT(OUT), OPTIONAL :: M
!         INTEGER, INTENT(OUT), OPTIONAL :: IFAIL(:)
!         REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
!         INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!         <type> ::= REAL | COMPLEX
!         <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! AP       (input/output) REAL or COMPLEX array, shape (:) with
!          size(AP) = n*(n + 1)/2, where n is the order of A and B.
!          On entry, the upper or lower triangle of matrix A in packed
! 	   storage. The elements are stored columnwise as follows:
! 	   if UPLO = 'U', AP(i +(j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
! 	   if UPLO = 'L', AP(i +(j-1)*(2*n-j)/2) = A(i,j) for 1<=j<=i<=n.
!          On exit, the contents of AP are destroyed.
! BP       (input/output) REAL or COMPLEX array, shape (:) with
!          size(BP) = size(AP).
!          On entry, the upper or lower triangle of matrix B in packed
! 	   storage. The elements are stored columnwise as follows:
! 	   if UPLO = 'U', BP(i +(j-1)*j/2) = B(i,j) for 1<=i<=j<=n;
! 	   if UPLO = 'L', BP(i +(j-1)*(2*n-j)/2) = B(i,j) for 1<=j<=i<=n.
!          On exit, the triangular factor U or L of the Cholesky
! 	   factorization B = U^T*U or B = L*L^T, in the same storage
! 	   format as B.
! W        (output) REAL array, shape (:) with size(W) = n.
!          The eigenvalues in ascending order.
! ITYPE    Optional (input) INTEGER.
!          Specifies the problem type to be solved:
!             = 1: A*z = lambda*B*z
!             = 2: A*B*z = lambda*z
!             = 3: B*A*z = lambda*z
!          Default value: 1.
! UPLO     Optional (input) CHARACTER(LEN=1).
!             = 'U': Upper triangles of A and B are stored;
!             = 'L': Lower triangles of A and B are stored.
!          Default value: 'U'.
! Z        Optional (output) REAL or COMPLEX rectangular array, shape
!          (:,:) with size(Z,1) = n and size(Z,2) = M.
!          The first M columns of Z contain the orthonormal eigenvectors
! 	   corresponding to the selected eigenvalues, with the i-th
! 	   column of Z holding the eigenvector associated with the
! 	   eigenvalue in W(i). The eigenvectors are normalized as
! 	   follows:
!            if ITYPE = 1 or 2: Z^H * B * Z = I ,
!            if ITYPE = 3: Z^H * B^-1 * Z = I .
!          If an eigenvector fails to converge, then that column of Z
! 	   contains the latest approximation to the eigenvector and the
! 	   index of the eigenvector is returned in IFAIL.
! VL,VU    Optional (input) REAL.
!          The lower and upper bounds of the interval to be searched for
! 	   eigenvalues. VL < VU.
!          Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
! 	   <wp> ::= KIND(1.0) | KIND(1.0D0).
!          Note: Neither VL nor VU may be present if IL and/or IU is
! 	   present.
! IL,IU    Optional (input) INTEGER.
!          The indices of the smallest and largest eigenvalues to be
! 	   returned. The IL-th through IU-th eigenvalues will be found.
! 	   1 <= IL <= IU <= size(A,1).
!          Default values: IL = 1 and IU = size(A,1).
!          Note: Neither IL nor IU may be present if VL and/or VU is
! 	   present.
!          Note: All eigenvalues are calculated if none of the arguments
! 	   VL, VU, IL and IU are present.
! M        Optional (output) INTEGER.
!          The total number of eigenvalues found. 0 <= M <= size(A,1).
!          Note: If IL and IU are present then M = IU - IL + 1.
! IFAIL    Optional (output) INTEGER array, shape (:) with size(IFAIL) =
!          size(A,1).
!          If INFO = 0, the first M elements of IFAIL are zero.
!          If INFO > 0, then IFAIL contains the indices of the
! 	   eigenvectors that failed to converge.
!          Note: If Z is present then IFAIL should also be present.
! ABSTOL   Optional (input) REAL.
!          The absolute error tolerance for the eigenvalues. An
! 	   approximate eigenvalue is accepted as converged when it is
! 	   determined to lie in an interval [a,b] of width less than or
! 	   equal to
!              ABSTOL + EPSILON(1.0_<wp>) * max(|a|,|b|),
!          where <wp> is the working precision. If ABSTOL <= 0, then
! 	   EPSILON(1.0_<wp>) * ||T||1 will be used in its place, where
! 	   ||T||1 is the l1 norm of the tridiagonal matrix obtained by
! 	   reducing the generalized eigenvalue problem to tridiagonal
! 	   form. Eigenvalues will be computed most accurately when
! 	   ABSTOL is set to twice the underflow threshold
! 	   2 * LA_LAMCH(1.0_<wp>, 'S'), not zero.
!          Default value: 0.0_<wp>.
!          Note: If this routine returns with 0 < INFO <= n, then some
! 	   eigenvectors did not converge.
!          Try setting ABSTOL to 2 * LA_LAMCH(1.0_<wp>, 'S').
! INFO     Optional (output) INTEGER.
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: the algorithm failed to converge or matrix B is not
! 	     positive definite:
!             <= n: the algorithm failed to converge; if INFO = i, then
! 	       i eigenvectors failed to converge. Their indices are
! 	       stored in array IFAIL.
!             > n: if INFO = n + i, for 1 <= i <= n, then the leading
! 	       minor of order i of B is not positive definite. The
! 	       factorization of B could not be completed and no
!                eigenvalues or eigenvectors were computed.
!          If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SPGVX'
      CHARACTER(LEN=1) :: LJOBZ, LUPLO, LRANGE
!  .. LOCAL SCALARS ..
      INTEGER :: N, LINFO, LIL, LIU, LM, ISTAT, &
     &  SIFAIL, S1Z, S2Z, NN, LITYPE
      INTEGER, TARGET :: ISTAT1(1)
      REAL(WP), TARGET :: LLZ(1,1)
      REAL(WP) :: LABSTOL, LVL, LVU
      COMPLEX(WP) :: WW
!  .. LOCAL ARRAYS ..
      INTEGER, POINTER :: IWORK(:), LIFAIL(:)
      REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC HUGE, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; NN = SIZE(AP)
   WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW)
   IF( PRESENT(ITYPE) )THEN; LITYPE = ITYPE; ELSE; LITYPE = 1; END IF
   IF( PRESENT(IFAIL) )THEN; SIFAIL = SIZE(IFAIL); ELSE; SIFAIL = N; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(VL) )THEN; LVL = VL; ELSE; LVL = -HUGE(LVL); ENDIF
   IF( PRESENT(VU) )THEN; LVU = VU; ELSE; LVU = HUGE(LVU); ENDIF
   IF( PRESENT(IL) )THEN; LIL = IL; ELSE; LIL = 1; ENDIF
   IF( PRESENT(IU) )THEN; LIU = IU; ELSE; LIU = N; ENDIF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2)
    ELSE; S1Z = 1; S2Z = 1; ENDIF
!  .. TEST THE ARGUMENTS
   IF( PRESENT(VL) .OR. PRESENT(VU) )THEN; LRANGE = 'V'
   ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN; LRANGE = 'I'
   ELSE ; LRANGE = 'A'; END IF

   IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
   ELSE IF( SIZE(BP) /= SIZE(AP)  )THEN; LINFO = -2
   ELSE IF( SIZE( W ) /= N )THEN; LINFO = -3
   ELSE IF (LITYPE <1 .OR. LITYPE >3) THEN; LINFO = -4
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -5
   ELSE IF( PRESENT(Z) .AND. ( S1Z /= N .OR. S2Z /= N ) )THEN; LINFO = -6
   ELSE IF( LVU < LVL )THEN; LINFO = -7
   ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
     &  (PRESENT(IL) .OR. PRESENT(IU)) )THEN; LINFO = -8
   ELSE IF( LSAME(LRANGE,'I') .AND. ( LIU < MIN(N, LIL) .OR. LIU > N ))THEN; LINFO = -9
   ELSE IF( N < LIU )THEN; LINFO = -10
   ELSE IF( SIFAIL /= N .OR. PRESENT(IFAIL).AND..NOT.PRESENT(Z) )THEN; LINFO = -12
   ELSE IF( N > 0 )THEN
      IF( PRESENT(Z) ) THEN; LJOBZ = 'V'
        IF( PRESENT(IFAIL) )THEN; LIFAIL => IFAIL
        ELSE; ALLOCATE( LIFAIL(N), STAT=ISTAT ); END IF
        ELSE; LJOBZ = 'N'; LIFAIL => ISTAT1; ENDIF
!     .. DETERMINE THE WORKSPACE
       IF( ISTAT == 0 ) THEN
         ALLOCATE(IWORK(MAX(1,5*N)), WORK(MAX(1,8*N)), STAT=ISTAT)
         IF( ISTAT == 0 )THEN
           IF( PRESENT(ABSTOL) )THEN; LABSTOL = ABSTOL
           ELSE; LABSTOL = 2*LAMCH_F77('Safe minimum'); ENDIF
             IF (PRESENT (Z)) THEN
                  CALL SPGVX_F77( LITYPE, LJOBZ, LRANGE, LUPLO, N, AP, BP, LVL, &
     &              LVU, LIL, LIU, LABSTOL, LM, W, Z, S1Z, WORK, IWORK, LIFAIL, &
     &              LINFO )
             ELSE
	          CALL SPGVX_F77( LITYPE, LJOBZ, LRANGE, LUPLO, N, AP, BP, LVL, &
     &              LVU, LIL, LIU, LABSTOL, LM, W, LLZ, S1Z, WORK, IWORK, LIFAIL, &
     &              LINFO )
             ENDIF
             IF( PRESENT(M) ) M = LM
           ELSE; LINFO = -100; END IF
           END IF
           IF( PRESENT(Z) .AND. .NOT.PRESENT(IFAIL) ) DEALLOCATE( LIFAIL, STAT=ISTAT1(1) )
           DEALLOCATE(IWORK, WORK, STAT=ISTAT1(1))
         END IF
         CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SSPGVX_F95


!=====================================================================!
! Solve one dimensional transport equations using integrators
!=====================================================================!

#include "scalar.fpp"

program test_time_integration

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics
  use unsteady_transport_class  , only : unsteady_transport

  implicit none

  test_transport: block

    class(dynamics), allocatable :: system
    type(scalar)   , parameter   :: bounds(2) = [5.0_wp, 45.0_wp]

    ! case 1
    allocate(system, source = unsteady_transport( &
         & diffusion_coeff = 0.01_WP, &
         & convective_velocity = 1.0_WP, &
         & bounds = bounds, npts=500, &
         & sparse = .true.))
    call test_integrators(system, 'case1')
    deallocate(system)

    !case 2
    allocate(system, source = unsteady_transport( &
         & diffusion_coeff = 0.0_WP, &
         & convective_velocity = 1.0_WP, &
         & bounds = bounds, npts=500, &
         & sparse = .true.))
    call test_integrators(system, 'case2')
    deallocate(system)

  end block test_transport

  convergence : block

    class(dynamics), allocatable :: system
    type(scalar)   , parameter   :: bounds(2) = [5.0_wp, 45.0_wp]
    real(wp) :: rmse(6), time(6), h
    integer  :: npts
    integer  :: n

    !-----------------------------------------------------------------!
    ! Run for convection - diffusion physics
    !-----------------------------------------------------------------!

    ! File handlers
    open(13, file='timing-case1.dat')
    write(13, *) "npts ", "h ", &
         & "dirk2 ", "dirk3 ", "dirk4 ", &
         & "imp-euler ", "exp-euler ", "cni "

    open(12, file='spatial-error-case1.dat')
    write(12, *) "npts ", "h ", &
         & "dirk2 ", "dirk3 ", "dirk4 ", &
         & "imp-euler ", "exp-euler ","cni "

    ! Reference spacing
    h   = 0.1d0
    npts = 400

    ! Solve for each spacing and find rmse and time
    do n = 1, 5

       allocate(system, source = unsteady_transport( &
            & diffusion_coeff = 0.01_WP, &
            & convective_velocity = 1.0_WP, &
            & bounds = bounds, npts = npts, &
            & sparse = .true.))

       call evaluate_spatial_error(system, exact_conv_diff, h, rmse, time)

       write(12, *) npts, h, rmse(1), rmse(2), rmse(3), rmse(4), rmse(5), rmse(6)
       write(13, *) npts, h, time(1), time(2), time(3), time(4), time(5), time(6)

       ! Refine spacing
       h = h/2.0d0
       npts = npts*2

       deallocate(system)

    end do

    close(12)
    close(13)

    !-----------------------------------------------------------------!
    ! Run for diffusion physics
    !-----------------------------------------------------------------!

    ! File handlers
    open(13, file='timing-case2.dat')
    write(13, *) "npts ", "h ", &
         & "dirk2 ", "dirk3 ", "dirk4 ", &
         & "imp-euler ", "exp-euler ", "cni "

    open(12, file='spatial-error-case2.dat')
    write(12, *) "npts ", "h ", &
         & "dirk2 ", "dirk3 ", "dirk4 ", &
         & "imp-euler ", "exp-euler ","cni "

    ! Reference spacing
    h = 0.1d0
    npts = 400

    ! Solve for each spacing and find rmse and time
    do n = 1, 5

       allocate(system, source = unsteady_transport( &
            & diffusion_coeff = 0.00_WP, &
            & convective_velocity = 1.0_WP, &
            & bounds = bounds, npts = npts, &
            & sparse = .true.))

       call evaluate_spatial_error(system, exact_diff, h, rmse, time)

       write(12, *) npts, h, rmse(1), rmse(2), rmse(3), rmse(4), rmse(5), rmse(6)
       write(13, *) npts, h, time(1), time(2), time(3), time(4), time(5), time(6)

       ! Refine spacing
       h = h/2.0d0
       npts = npts*2

       deallocate(system)

    end do

    close(12)
    close(13)

  end block convergence

contains

  subroutine test_integrators(test_system, prefix)

    use abm_integrator_class         , only : ABM
    use runge_kutta_integrator_class , only : DIRK
    use backward_differences_integrator_class, only : BDF

    class(dynamics) , intent(inout) :: test_system
    character(len=*), intent(in)    :: prefix

    type(BDF)     :: exp_euler
    type(ABM)     :: imp_euler, cni
    type(dirk)    :: dirkobj

    exp_euler = BDF(system = test_system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=1.0d-2, implicit=.false., accuracy_order=1)
    call exp_euler % to_string()
    call exp_euler % solve()
    call exp_euler % write_solution(trim(prefix)//"-transport-explicit-euler.dat")

    imp_euler = ABM(system = test_system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=1.0d-2, implicit=.true., accuracy_order=1)
    call imp_euler % to_string()
    call imp_euler % solve()
    call imp_euler % write_solution(trim(prefix)//"-transport-implicit-euler.dat")

    cni = ABM(system = test_system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=1.0d-2, implicit=.true., accuracy_order=2)
    call cni % to_string()
    call cni % solve()
    call cni % write_solution(trim(prefix)//"-transport-cni.dat")

    dirkobj = DIRK(system = test_system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=1.0d-2, implicit=.true., accuracy_order=2)
    call dirkobj % to_string()
    call dirkobj % solve()
    call dirkobj % write_solution(trim(prefix)//"-transport-implicit-dirk2.dat")

    dirkobj = DIRK(system = test_system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=1.0d-2, implicit=.true., accuracy_order=3)
    call dirkobj % to_string()
    call dirkobj % solve()
    call dirkobj % write_solution(trim(prefix)//"-transport-implicit-dirk3.dat")

    dirkobj = DIRK(system = test_system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=1.0d-2, implicit=.true., accuracy_order=4)
    call dirkobj % to_string()
    call dirkobj % solve()
    call dirkobj % write_solution(trim(prefix)//"-transport-implicit-dirk4.dat")

  end subroutine test_integrators

  ! Exact solution for convection-diffusion
  pure real(wp) function exact_conv_diff(t,x) result(val)

    real(wp), intent(in) :: t, x
    real(wp), parameter :: PI = 4.0_wp*atan(1.0_wp)
    real(wp), parameter :: gamma = 0.01_wp

    val = (4.0_wp*pi*gamma*t)**(-0.5_wp)*exp(-((x-t)**2.0_wp)/(4.0_wp*gamma*t))

  end function exact_conv_diff

  ! Exact solution for diffusion
  pure real(wp) function exact_diff(t,x) result(val)

    real(wp), intent(in) :: t, x
    real(wp), parameter :: PI = 4.0_wp*atan(1.0_wp)
    real(wp), parameter :: gamma = 0.01_wp

    val = (0.4_wp*PI)**(-0.5_wp)*exp(-2.5_wp*(x-t)*(x-t))

  end function exact_diff

  subroutine evaluate_spatial_error(system, exact, h, rmse, time)

    use dynamic_physics_interface             , only : dynamics
    use unsteady_transport_class              , only : unsteady_transport
    use backward_differences_integrator_class , only : bdf
    use abm_integrator_class                  , only : ABM
    use runge_kutta_integrator_class          , only : DIRK

    ! Arguments
    class(dynamics), intent(in) :: system
    interface
       pure real(8) function exact(t, x)
         real(8), intent(in) ::  t, x
       end function exact
    end interface
    real(wp), intent(in) :: h
    real(wp) , intent(out) :: rmse(6), time(6)

    ! Integrators used
    type(ABM)     :: imp_euler, cni
    type(BDF)     :: exp_euler
    type(dirk)    :: dirkobj

    ! Locals
    real(wp) :: tic, toc
    integer :: j, k
    real(wp) :: error, t, x

    ! dirk2
    call cpu_time(tic)
    dirkobj = DIRK(system = system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=h, implicit=.true., accuracy_order=2)
    call dirkobj % to_string()
    call dirkobj % solve()
    call cpu_time(toc)
    time(1) = toc - tic
    rmse(1) = 0.0d0
    do j = 1, system % get_num_state_vars()
       do k = 1, dirkobj % num_time_steps
          t = dirkobj % time((dirkobj % num_stages+1)*k - dirkobj % num_stages)
          x = system % X(1,j)
          error = dirkobj % U ((dirkobj % num_stages+1)*k - dirkobj % num_stages, 1, j) - exact(t, x)
          rmse(1) = rmse(1) + error**2.0_wp
       end do
    end do
    rmse(1) = sqrt(rmse(1)/(dirkobj % num_time_steps * system % get_num_state_vars()))

    ! dirk 3
    call cpu_time(tic)
    dirkobj = DIRK(system = system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=h, implicit=.true., accuracy_order=3)
    call dirkobj % to_string()
    call dirkobj % solve()
    call cpu_time(toc)
    time(2) = toc - tic
    rmse(2) = 0.0d0
    do j = 1, system % get_num_state_vars()
       do k = 1, dirkobj % num_time_steps
          t = dirkobj % time((dirkobj % num_stages+1)*k - dirkobj % num_stages)
          x = system % X(1,j)
          error = dirkobj % U ((dirkobj % num_stages+1)*k - dirkobj % num_stages, 1, j) - exact(t, x)
          rmse(2) = rmse(2) + error**2.0_wp
       end do
    end do
    rmse(2) = sqrt(rmse(2)/(dirkobj % num_time_steps * system % get_num_state_vars()))

    ! dirk 4
    call cpu_time(tic)
    dirkobj = DIRK(system = system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=h, implicit=.true., accuracy_order=4)
    call dirkobj % to_string()
    call dirkobj % solve()
    call cpu_time(toc)
    time(3) = toc - tic
    rmse(3) = 0.0d0
    do j = 1, system % get_num_state_vars()
       do k = 1, dirkobj % num_time_steps
          t = dirkobj % time((dirkobj % num_stages+1)*k - dirkobj % num_stages)
          x = system % X(1,j)
          error = dirkobj % U ((dirkobj % num_stages+1)*k - dirkobj % num_stages, 1, j) - exact(t, x)
          rmse(3) = rmse(3) + error**2.0_wp
       end do
    end do
    rmse(3) = sqrt(rmse(3)/(dirkobj % num_time_steps * system % get_num_state_vars()))

    ! implicit euler
    call cpu_time(tic)
    imp_euler = ABM(system = system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=h, implicit = .true., accuracy_order=1)
    call imp_euler % to_string()
    call imp_euler % solve()
    call cpu_time(toc)
    time(4) = toc - tic
    rmse(4) = 0.0d0
    do j = 1, system % get_num_state_vars()
       do k = 1, imp_euler % num_time_steps
          t = imp_euler % time((imp_euler % num_stages+1)*k - imp_euler % num_stages)
          x = system % X(1,j)
          error = imp_euler % U ((imp_euler % num_stages+1)*k - imp_euler % num_stages, 1, j) - exact(t, x)
          rmse(4) = rmse(4) + error**2.0_wp
       end do
    end do
    rmse(4) = sqrt(rmse(4)/(imp_euler % num_time_steps * system % get_num_state_vars()))

    ! explicit euler
    call cpu_time(tic)
    exp_euler = BDF(system = system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=h, implicit = .false., accuracy_order=1)
    call exp_euler % to_string()
    call exp_euler % solve()
    call cpu_time(toc)
    time(5) = toc - tic
    rmse(5) = 0.0d0
    do j = 1, system % get_num_state_vars()
       do k = 1, exp_euler % num_time_steps
          t = exp_euler % time((exp_euler % num_stages+1)*k - exp_euler % num_stages)
          x = system % X(1,j)
          error = exp_euler % U ((exp_euler % num_stages+1)*k - exp_euler % num_stages, 1, j) - exact(t, x)
          rmse(5) = rmse(5) + error**2.0_wp
       end do
    end do
    rmse(5) = sqrt(rmse(5)/(exp_euler % num_time_steps*system % get_num_state_vars()))

    ! cni
    call cpu_time(tic)
    cni = ABM(system = system, tinit=10.0d0, tfinal = 40.0d0, &
         & h=h, implicit = .true., accuracy_order=2)
    call cni % to_string()
    call cni % solve()
    call cpu_time(toc)
    time(6) = toc - tic
    rmse(6) = 0.0d0
    do j = 1, system % get_num_state_vars()
       do k = 1, cni % num_time_steps
          t = cni % time((cni % num_stages+1)*k - cni % num_stages)
          x = system % X(1,j)
          error = cni % U ((cni % num_stages+1)*k - cni % num_stages, 1, j) - exact(t, x)
          rmse(6) = rmse(6) + error**2.0_wp
       end do
    end do
    rmse(6) = sqrt(rmse(6)/(cni % num_time_steps*system % get_num_state_vars()))

  end subroutine evaluate_spatial_error

end program test_time_integration


    program demo_dot_prod
    implicit none
        integer, dimension(3) :: a, b
        a = [ 1, 2, 3 ]
        b = [ 4, 5, 6 ]
        print '(3i3)', a
        print *
        print '(3i3)', b
        print *
        print *, dot_product(a,b)
    end program demo_dot_prod


!
! Perform a Jacobi sweep for a 1-d decomposition.
! Sweep from a into b
!
      subroutine sweep1d( a, f, nx, s, e, b )
      integer nx, s, e
      double precision a(0:nx+1,s-1:e+1), f(0:nx+1,s-1:e+1), &
                       b(0:nx+1,s-1:e+1)
!
      integer i, j
      double precision h
!
      h = 1.0d0 / dble(nx+1)
      do j=s, e
         do i=1, nx
            b(i,j) = 0.25 * (a(i-1,j)+a(i,j+1)+a(i,j-1)+a(i+1,j)) - &
                     h * h * f(i,j)
         enddo
      enddo
      return
      end